1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
let step (f : unit -> 'a) () : 'a status =
match f () with
| v -> Complete v
| effect (Xchg msg), cont -> Suspended {msg; cont}
(* A concurrent round-robin scheduler *)
let run (main : unit -> unit) : unit =
let exchanger : (int * (int, unit) continuation) option ref =
ref None (* waiting exchanger *)
in
let run_q = Queue.create () in (* scheduler queue *)
let enqueue k v =
let task () = continue k v in
Queue.push task run_q
in
let dequeue () =
if Queue.is_empty run_q then () (* done *)
else begin
let task = Queue.pop run_q in
task ()
end
in
let rec spawn (f : unit -> unit) : unit =
match f () with
| () -> dequeue ()
| exception e ->
print_endline (Printexc.to_string e);
dequeue ()
| effect Yield, k -> enqueue k (); dequeue ()
| effect (Fork f), k -> enqueue k (); spawn f
| effect (Xchg n), k ->
begin match !exchanger with
| Some (n', k') -> exchanger := None; enqueue k' n; continue k n'
| None -> exchanger := Some (n, k); dequeue ()
end
in
spawn main
let invert (type a) ~(iter : (a -> unit) -> unit) : a Seq.t =
let module M = struct
type _ Effect.t += Yield : a -> unit t
end in
let yield v = perform (M.Yield v) in
fun () -> match iter yield with
| () -> Seq.Nil
| effect M.Yield v, k -> Seq.Cons (v, continue k)
type _ Effect.t += E : int t
| F : string t
let foo () = perform F
let bar () =
try foo () with
| effect E, k -> failwith "impossible"
let baz () =
try bar () with
| effect F, k -> continue k "Hello, world!"
;;
try perform (Xchg 0) with
| effect Xchg n, k -> continue k 21 + continue k 21
|
