let (<) = lt_big_int
let (>) = gt_big_int
let ( × ) = mult_big_int
Merge thread
let rec mergeb q1 q2 qo v1 v2 =
let v1, v2 =
if v1 < v2 then begin
put_mvar qo v1;
(take_mvar q1, v2)
end
else if v1 > v2 then begin
put_mvar qo v2;
(v1, take_mvar q2)
end
else begin
put_mvar qo v1;
(take_mvar q1, take_mvar q2)
end
in
mergeb q1 q2 qo v1 v2
Initializer for merge thread
let merge q1 q2 qo () =
let v1 = take_mvar q1
and v2 = take_mvar q2 in
mergeb q1 q2 qo v1 v2
Multiplier thread
let rec times a f qo () =
let v = take_fifo f in
put_mvar qo (a×v);
times a f qo ()
The x thread itself
let rec x mv f2 f3 f5 () =
let v = take_mvar mv in
if v > !last then stop ();
if !print then
Printf.printf "%s " (string_of_big_int v);
put_fifo f2 v;
put_fifo f3 v;
put_fifo f5 v;
x mv f2 f3 f5 ()
Set up and start
let main () =
(∗ fifo + times = mult ∗)
let make_mult a =
let f = make_fifo ()
and mv = make_mvar () in
let t = times a f mv
in
spawn t; (f, mv)
in
let make_merge q1 q2 =
let qo = make_mvar () in
let m = merge q1 q2 qo
in
spawn m; qo
in
let f2, m2 = make_mult (big_int_of_int 2)
and f3, m3 = make_mult (big_int_of_int 3)
and f5, m5 = make_mult (big_int_of_int 5) in
let m35 = make_merge m3 m5 in
let m235 = make_merge m2 m35
in
spawn (x m235 f2 f3 f5);
put_mvar m235 unit_big_int; start ()
let (<) = lt_big_int
let (>) = gt_big_int
let ( × ) = mult_big_int
Merge thread
let rec mergeb q1 q2 qo v1 v2 =
if v1 < v2 then begin
put_mvar qo v1 >>= fun () →
take_mvar q1 >>= fun v1 →
mergeb q1 q2 qo v1 v2
end
else if v1 > v2 then begin
put_mvar qo v2 >>= fun () →
take_mvar q2 >>= fun v2 →
mergeb q1 q2 qo v1 v2
end
else begin
put_mvar qo v1 >>= fun () →
take_mvar q1 >>= fun v1 →
take_mvar q2 >>= fun v2 →
mergeb q1 q2 qo v1 v2
end
Initializer for merge thread
let merge q1 q2 qo () =
take_mvar q1 >>= fun v1 →
take_mvar q2 >>= fun v2 →
mergeb q1 q2 qo v1 v2
Multiplier thread
let rec times a f qo () =
take_fifo f >>= fun v →
put_mvar qo (a×v) >>=
times a f qo
The x thread itself
let rec x mv f2 f3 f5 () =
take_mvar mv >>= fun v →
if v > !last then stop ()
else skip >>= fun () →
if !print then
Printf.printf "%s " (string_of_big_int v);
put_fifo f2 v;
put_fifo f3 v;
put_fifo f5 v;
x mv f2 f3 f5 ()
Set up and start
let main () =
(∗ fifo + times = mult ∗)
let make_mult a =
let f = make_fifo ()
and mv = make_mvar () in
let t = times a f mv
in
spawn t; (f, mv)
in
let make_merge q1 q2 =
let qo = make_mvar () in
let m = merge q1 q2 qo
in
spawn m; qo
in
let f2, m2 = make_mult (big_int_of_int 2)
and f3, m3 = make_mult (big_int_of_int 3)
and f5, m5 = make_mult (big_int_of_int 5) in
let m35 = make_merge m3 m5 in
let m235 = make_merge m2 m35
in
spawn (x m235 f2 f3 f5);
spawn (fun () → put_mvar m235 unit_big_int >>=
halt);
start ()
let rec integers out i () =
put_mvar out i;
integers out (i+1) ()
let rec output inp () =
let v = take_mvar inp in
if !print then (Printf.printf "%i " v; flush stdout);
if v < !last then output inp () else stop ()
let rec filter n inp out () =
let v = take_mvar inp in
if v mod n ≠ 0 then put_mvar out v;
filter n inp out ()
let rec sift inp out () =
let v = take_mvar inp in
put_mvar out v;
let mid = make_mvar () in
spawn (filter v inp mid);
sift mid out ()
let sieve () =
let mi = make_mvar () in
let mo = make_mvar () in
spawn (integers mi 2);
spawn (sift mi mo);
spawn (output mo);
start ()
let rec integers out i () =
put_mvar out i >>= integers out (i+1)
let rec output inp () =
take_mvar inp >>= fun v →
if !print then (Printf.printf "%i " v; flush stdout);
if v < !last then output inp () else (stop (); halt())
let rec filter n inp out () =
take_mvar inp >>= fun v →
(if v mod n ≠ 0 then put_mvar out v else skip) >>=
filter n inp out
let rec sift inp out () =
take_mvar inp >>= fun v →
put_mvar out v >>= fun () →
let mid = make_mvar () in
spawn (filter v inp mid);
sift mid out ()
let sieve () =
let mi = make_mvar () in
let mo = make_mvar () in
spawn (integers mi 2);
spawn (sift mi mo);
spawn (output mo);
start ()
let minmax a b =
if a<b then (a,b) else (b,a)
let rec comparator x y hi lo =
let a = take_mvar x
and b = take_mvar y in
let (l,h) = minmax a b
in
put_mvar lo l;
put_mvar hi h;
comparator x y hi lo
let make_list n fct =
let rec loop n acc =
if n=0 then acc
else
loop (n−1) (fct n ::acc)
in
loop n [ ]
let make_n_mvars n =
make_list n (fun _ → make_mvar ())
let rec iter4 fct l1 l2 l3 l4 =
match (l1,l2,l3,l4) with
∣ [ ],[ ],[ ],[ ] → [ ]
∣ l1::l1s,l2::l2s,l3::l3s,l4::l4s →
fct (l1,l2,l3,l4);
iter4 fct l1s l2s l3s l4s
∣ _ → failwith "iter4"
let column (i::is) y =
let n = List.length is in
let ds = make_n_mvars (n−1) in
let os = make_n_mvars n
in
iter4
(fun (i,di,o,od) →
spawn (fun () → comparator i di o od))
is (i::ds) os (ds @ [y]);
os
let sorter xs ys =
let rec help is ys n =
if n>2 then
let os = column is (List.hd ys) in
help os (List.tl ys) (n−1)
else
spawn (fun () → comparator
(List.hd (List.tl is)) (List.hd is)
(List.hd (List.tl ys)) (List.hd ys))
in
help xs ys (List.length xs)
let set_list ms l () =
List.iter (fun (mv,v) → put_mvar mv v)
(List.map2 (fun a b → (a,b)) ms l);
halt ()
let print_list ms () =
List.iter (fun n → Printf.printf "%i " n)
(List.map take_mvar ms);
flush stdout; stop ()
let sort l =
let n = List.length l in
let xs = make_n_mvars n
and ys = make_n_mvars n
in
sorter xs ys;
spawn (set_list xs l);
spawn (print_list ys);
if ¬ !dont then start ()
let doit () =
let l = make_list !last (fun _ → Random.int 999) in
sort l
let minmax a b =
if a<b then (a,b) else (b,a)
let rec comparator x y hi lo () =
take_mvar x >>= fun a →
take_mvar y >>= fun b →
let (l,h) = minmax a b
in
put_mvar lo l >>= fun () →
put_mvar hi h >>=
comparator x y hi lo
let make_list n fct =
let rec loop n acc =
if n=0 then acc
else
loop (n−1) (fct n ::acc)
in
loop n [ ]
let make_n_mvars n =
make_list n (fun _ → make_mvar ())
let rec iter4 fct l1 l2 l3 l4 =
match (l1,l2,l3,l4) with
∣ [ ],[ ],[ ],[ ] → [ ]
∣ l1::l1s,l2::l2s,l3::l3s,l4::l4s →
fct (l1,l2,l3,l4);
iter4 fct l1s l2s l3s l4s
∣ _ → failwith "iter4"
let column (i::is) y =
let n = List.length is in
let ds = make_n_mvars (n−1) in
let os = make_n_mvars n
in
iter4
(fun (i,di,o,od) →
spawn (comparator i di o od))
is (i::ds) os (ds @ [y]);
os
let sorter xs ys () =
let rec help is ys n =
if n>2 then
let os = column is (List.hd ys) in
help os (List.tl ys) (n−1)
else
spawn (comparator
(List.hd (List.tl is)) (List.hd is)
(List.hd (List.tl ys)) (List.hd ys))
in
help xs ys (List.length xs)
let rec set_list mvs l () =
match mvs,l with
∣ [ ],[ ] → halt ()
∣ m::r,h::t → put_mvar m h >>= set_list r t
let print_list mvs () =
let rec loop mvs acc k =
match mvs with
∣ [ ] → k acc
∣ h::t → take_mvar h >>= fun v →
loop t (v::acc) k
in
loop mvs [ ] >>= fun l →
List.iter (fun n → Printf.printf "%i " n) (List.rev l);
halt ()
let sort l =
let n = List.length l in
let xs = make_n_mvars n
and ys = make_n_mvars n
in
sorter xs ys ();
spawn (set_list xs l);
spawn (print_list ys);
if ¬ !dont then start ()
let doit () =
let l = make_list !last (fun _ → Random.int 999) in
sort l