QCaml/Parallel/Farm.ml

(* Single process function *)
let run_sequential f stream =

  let rec next _ =
    try
      let task = Stream.next stream in
      Some (f task) 
    with Stream.Failure -> None in
    Stream.from next




(* Multi-process functions *)

(* Server side *)
let run_parallel_server stream =


  let fetch_result () =
    let  result, rank, _tag  =
      Mpi.receive_status  Mpi.any_source  Mpi.any_tag  Mpi.comm_world
    in
    result, rank
  in


  let send_task client_rank task_list =
    let task, rest = 
      match task_list with
      | []           -> None     , []
      | task :: rest -> Some task, rest
    in
    Mpi.send  task  client_rank  0  Mpi.comm_world;
    rest
  in


  let rec run result_list task_list = function
    | 0 -> result_list
    | n_todo ->
      begin
        let result, client  = fetch_result () in
        let new_result_list =
          match result with
          | None -> result_list
          | Some result -> result :: result_list
        in
        let new_tasklist    = send_task  client  task_list in
        run  new_result_list  new_tasklist  (n_todo-1)
      end
  in
  
  let result =
    let task_list =
      let rec to_list accu =
        try to_list (Stream.next stream :: accu)
        with Stream.Failure -> List.rev accu
      in to_list []
    in
    let n_todo = List.length task_list in
    run [] task_list (n_todo + Parallel.size - 1)
    |> Stream.of_list
  in
  Mpi.barrier  Mpi.comm_world;
  result


(** Client side *)
let run_parallel_client f =
  Mpi.send  None  0  0  Mpi.comm_world;

  let rec run () =
    let task = 
      Mpi.receive  0  Mpi.any_tag  Mpi.comm_world
    in

    match task with
    | None -> Mpi.barrier  Mpi.comm_world
    | Some task ->
      let result = f task in
      begin
        Mpi.send  (Some result)  0  0  Mpi.comm_world;
        run ()
      end
  in
  run ();
  Stream.of_list []



let run_parallel f stream =
  match Mpi.comm_rank  Mpi.comm_world with
  | 0 -> run_parallel_server stream
  | _ -> run_parallel_client f


let run f stream =
  match Mpi.comm_size Mpi.comm_world with
  | 1 -> run_sequential f stream
  | _ -> run_parallel   f stream