Source file proc_state.ml

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
71
72
73
74
75
76
type ('a, 'b) continuation = ('a, 'b) Effect.Shallow.continuation

type 'a t =
  | Finished of ('a, exn) result
  | Suspended : ('a, 'b) continuation * 'a Effect.t -> 'b t
  | Unhandled : ('a, 'b) continuation * 'a -> 'b t

type 'a step =
  | Continue of 'a
  | Discontinue of exn
  | Reperform : 'a Effect.t -> 'a step
  | Delay : 'a step
  | Suspend : 'a step
  | Yield : unit step

type ('a, 'b) step_callback = ('a step -> 'b t) -> 'a Effect.t -> 'b t
type perform = { perform : 'a 'b. ('a, 'b) step_callback } [@@unboxed]

let finished x = Finished x
let suspended_with k e = Suspended (k, e)

let handler_continue =
  let retc signal = finished (Ok signal) in
  let exnc exn = finished (Error exn) in
  let effc : type c. c Effect.t -> ((c, 'a) continuation -> 'b) option =
   fun e -> Some (fun k -> suspended_with k e)
  in
  Effect.Shallow.{ retc; exnc; effc }

let continue_with k v = Effect.Shallow.continue_with k v handler_continue

let handler_discontinue exn =
  let retc _ = finished (Error exn) in
  let exnc = retc in
  let effc : type c. c Effect.t -> ((c, 'a) continuation -> 'b) option =
   fun _ -> Some retc
  in
  Effect.Shallow.{ retc; exnc; effc }

let discontinue_with k exn =
  Effect.Shallow.discontinue_with k exn (handler_discontinue exn)

let unhandled_with k v = Unhandled (k, v)

let make fn eff =
  let k = Effect.Shallow.fiber fn in
  Suspended (k, eff)

let run : type a. reductions:int -> perform:perform -> a t -> a t =
 fun ~reductions ~perform t ->
  let exception Yield of a t in
  let reductions = ref reductions in
  let t = ref t in
  try
    while true do
      Log.trace (fun f -> f "stepping process %d" !reductions);
      if !reductions = 0 then raise_notrace (Yield !t);
      reductions := !reductions - 1;
      match !t with
      | Finished _ as finished -> raise_notrace (Yield finished)
      | Unhandled (fn, v) -> raise_notrace (Yield (continue_with fn v))
      | Suspended (fn, e) as suspended ->
          let k : type c. (c, a) continuation -> c step -> a t =
           fun fn step ->
            match step with
            | Delay -> suspended
            | Continue v -> continue_with fn v
            | Discontinue exn -> discontinue_with fn exn
            | Reperform eff -> unhandled_with fn (Effect.perform eff)
            | Yield -> raise_notrace (Yield (continue_with fn ()))
            | Suspend -> raise_notrace (Yield suspended)
          in
          t := perform.perform (k fn) e
    done;
    !t
  with Yield t -> t