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
63
64
65
66
67
68
69
70
|
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
|
