mirror of
https://gitlab.com/scemama/QCaml.git
synced 2024-10-06 16:26:03 +02:00
Ordering is preserved
This commit is contained in:
parent
b95b80000c
commit
60b4bc6713
@ -13,31 +13,44 @@ let run_sequential f stream =
|
|||||||
|
|
||||||
(* Multi-process functions *)
|
(* Multi-process functions *)
|
||||||
|
|
||||||
|
type task_id = int
|
||||||
|
|
||||||
|
|
||||||
(* Server side *)
|
(* Server side *)
|
||||||
let run_parallel_server stream =
|
let run_parallel_server ~ordered stream =
|
||||||
|
|
||||||
|
|
||||||
let fetch_result () : 'a option * int =
|
let fetch_result () : (task_id * 'a) option * int =
|
||||||
let result, rank, _tag =
|
let (message, rank, _tag) : (task_id * 'a) option * int * int =
|
||||||
Mpi.receive_status Mpi.any_source Mpi.any_tag Mpi.comm_world
|
Mpi.receive_status Mpi.any_source Mpi.any_tag Mpi.comm_world
|
||||||
in
|
in
|
||||||
result, rank
|
message, rank
|
||||||
in
|
in
|
||||||
|
|
||||||
|
|
||||||
let send_task (client_rank : int) : unit =
|
let send_task (client_rank : int) : unit =
|
||||||
let task =
|
let task =
|
||||||
try Some (Stream.next stream)
|
try
|
||||||
|
let task_id = Stream.count stream in
|
||||||
|
let element = Stream.next stream in
|
||||||
|
Some (task_id, element)
|
||||||
with Stream.Failure -> None
|
with Stream.Failure -> None
|
||||||
in
|
in
|
||||||
Mpi.send task client_rank 0 Mpi.comm_world
|
Mpi.send task client_rank 0 Mpi.comm_world
|
||||||
in
|
in
|
||||||
|
|
||||||
|
|
||||||
|
(* n_todo is required for clean termination. It is the
|
||||||
|
number of tasks to wait for when the input stream is
|
||||||
|
empty. *)
|
||||||
let n_todo = ref (Mpi.comm_size Mpi.comm_world ) in
|
let n_todo = ref (Mpi.comm_size Mpi.comm_world ) in
|
||||||
|
|
||||||
let f i =
|
(* buffer of finished tasks with a task_id greater than the
|
||||||
let rec get_result () =
|
current result_id. It allows to put back the results in
|
||||||
|
the correct order.
|
||||||
|
*)
|
||||||
|
|
||||||
|
let rec get_result () : (task_id * 'a ) option =
|
||||||
begin
|
begin
|
||||||
match Stream.peek stream with
|
match Stream.peek stream with
|
||||||
| None -> decr n_todo
|
| None -> decr n_todo
|
||||||
@ -51,14 +64,39 @@ let run_parallel_server stream =
|
|||||||
end
|
end
|
||||||
| _ ->
|
| _ ->
|
||||||
begin
|
begin
|
||||||
let result, client = fetch_result () in
|
let message, rank = fetch_result () in
|
||||||
send_task client;
|
send_task rank;
|
||||||
match result with
|
match message with
|
||||||
| None -> get_result ()
|
| None -> get_result ()
|
||||||
| _ -> result
|
| Some (task_id, result) -> Some (task_id, result)
|
||||||
end
|
end
|
||||||
in
|
in
|
||||||
get_result ()
|
|
||||||
|
let f =
|
||||||
|
if ordered then
|
||||||
|
let buffer = Hashtbl.create 67 in
|
||||||
|
fun i ->
|
||||||
|
begin
|
||||||
|
match Hashtbl.find_opt buffer i with
|
||||||
|
| Some x ->
|
||||||
|
begin
|
||||||
|
Hashtbl.remove buffer i;
|
||||||
|
Some x
|
||||||
|
end
|
||||||
|
| None ->
|
||||||
|
let rec loop () =
|
||||||
|
match get_result () with
|
||||||
|
| None -> None
|
||||||
|
| Some (task_id, result) ->
|
||||||
|
if task_id = i then Some result
|
||||||
|
else (Hashtbl.add buffer task_id result; loop () )
|
||||||
|
in loop ()
|
||||||
|
end
|
||||||
|
else
|
||||||
|
fun _ ->
|
||||||
|
match get_result () with
|
||||||
|
| Some (_, result) -> Some result
|
||||||
|
| None -> None
|
||||||
in
|
in
|
||||||
Stream.from f
|
Stream.from f
|
||||||
|
|
||||||
@ -68,16 +106,16 @@ let run_parallel_client f =
|
|||||||
Mpi.send None 0 0 Mpi.comm_world;
|
Mpi.send None 0 0 Mpi.comm_world;
|
||||||
|
|
||||||
let rec run () =
|
let rec run () =
|
||||||
let task =
|
let message =
|
||||||
Mpi.receive 0 Mpi.any_tag Mpi.comm_world
|
Mpi.receive 0 Mpi.any_tag Mpi.comm_world
|
||||||
in
|
in
|
||||||
|
|
||||||
match task with
|
match message with
|
||||||
| None -> Mpi.barrier Mpi.comm_world
|
| None -> Mpi.barrier Mpi.comm_world
|
||||||
| Some task ->
|
| Some (task_id, task) ->
|
||||||
let result = f task in
|
let result = f task in
|
||||||
begin
|
begin
|
||||||
Mpi.send (Some result) 0 0 Mpi.comm_world;
|
Mpi.send (Some (task_id, result)) 0 0 Mpi.comm_world;
|
||||||
run ()
|
run ()
|
||||||
end
|
end
|
||||||
in
|
in
|
||||||
@ -86,14 +124,14 @@ let run_parallel_client f =
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
let run_parallel f stream =
|
let run_parallel ~ordered f stream =
|
||||||
match Mpi.comm_rank Mpi.comm_world with
|
match Mpi.comm_rank Mpi.comm_world with
|
||||||
| 0 -> run_parallel_server stream
|
| 0 -> run_parallel_server ~ordered stream
|
||||||
| _ -> run_parallel_client f
|
| _ -> run_parallel_client f
|
||||||
|
|
||||||
|
|
||||||
let run f stream =
|
let run ?(ordered=true) ~f stream =
|
||||||
match Mpi.comm_size Mpi.comm_world with
|
match Mpi.comm_size Mpi.comm_world with
|
||||||
| 1 -> run_sequential f stream
|
| 1 -> run_sequential f stream
|
||||||
| _ -> run_parallel f stream
|
| _ -> run_parallel ~ordered f stream
|
||||||
|
|
||||||
|
@ -24,10 +24,13 @@ let v = Parallel.Vec.init 47 (fun i -> float_of_int i) in
|
|||||||
let () =
|
let () =
|
||||||
let f (a,b) = (Parallel.rank, a+b) in
|
let f (a,b) = (Parallel.rank, a+b) in
|
||||||
let input = Stream.of_list
|
let input = Stream.of_list
|
||||||
[ (1,2) ; (3,4) ; (5,6) ; (7,8) ; (9,10) ]
|
[ (1,2) ; (3,4) ; (5,6) ; (7,8) ; (9,10)
|
||||||
|
; (1,2) ; (3,4) ; (5,6) ; (7,8) ; (9,10)
|
||||||
|
; (1,2) ; (3,4) ; (5,6) ; (7,8) ; (9,10)
|
||||||
|
; (1,2) ; (3,4) ; (5,6) ; (7,8) ; (9,10) ]
|
||||||
in
|
in
|
||||||
let stream =
|
let stream =
|
||||||
Farm.run f input
|
Farm.run ~f input
|
||||||
in
|
in
|
||||||
Stream.iter (fun (x,y) -> Printf.printf "%d %d\n%!" x y) stream
|
Stream.iter (fun (x,y) -> Printf.printf "%d %d\n%!" x y) stream
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user