anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* KC Sivaramakrishnan, Indian Institute of Technology, Madras *)
6(* *)
7(* Copyright 2021 Indian Institute of Technology, Madras *)
8(* *)
9(* All rights reserved. This file is distributed under the terms of *)
10(* the GNU Lesser General Public License version 2.1, with the *)
11(* special exception on linking described in the file LICENSE. *)
12(* *)
13(**************************************************************************)
14
15type 'a t = 'a eff = ..
16external perform : 'a t -> 'a = "%perform"
17
18type exn += Unhandled: 'a t -> exn
19exception Continuation_already_resumed
20
21let () =
22 let printer = function
23 | Unhandled x ->
24 let msg = Printf.sprintf "Stdlib.Effect.Unhandled(%s)"
25 (Printexc.string_of_extension_constructor @@ Obj.repr x)
26 in
27 Some msg
28 | _ -> None
29 in
30 Printexc.register_printer printer
31
32(* Register the exceptions so that the runtime can access it *)
33type _ t += Should_not_see_this__ : unit t
34let _ = Callback.register_exception "Effect.Unhandled"
35 (Unhandled Should_not_see_this__)
36let _ = Callback.register_exception "Effect.Continuation_already_resumed"
37 Continuation_already_resumed
38
39type ('a, 'b) stack [@@immediate]
40type last_fiber [@@immediate]
41
42external resume :
43 ('a, 'b) stack -> ('c -> 'a) -> 'c -> last_fiber -> 'b = "%resume"
44external runstack : ('a, 'b) stack -> ('c -> 'a) -> 'c -> 'b = "%runstack"
45
46module Deep = struct
47
48 type nonrec ('a,'b) continuation = ('a,'b) continuation
49
50 external take_cont_noexc : ('a, 'b) continuation -> ('a, 'b) stack =
51 "caml_continuation_use_noexc" [@@noalloc]
52 external alloc_stack :
53 ('a -> 'b) ->
54 (exn -> 'b) ->
55 ('c t -> ('c, 'b) continuation -> last_fiber -> 'b) ->
56 ('a, 'b) stack = "caml_alloc_stack"
57 external cont_last_fiber : ('a, 'b) continuation -> last_fiber = "%field1"
58
59 let continue k v =
60 resume (take_cont_noexc k) (fun x -> x) v (cont_last_fiber k)
61
62 let discontinue k e =
63 resume (take_cont_noexc k) (fun e -> raise e) e (cont_last_fiber k)
64
65 let discontinue_with_backtrace k e bt =
66 resume (take_cont_noexc k) (fun e -> Printexc.raise_with_backtrace e bt)
67 e (cont_last_fiber k)
68
69 type ('a,'b) handler =
70 { retc: 'a -> 'b;
71 exnc: exn -> 'b;
72 effc: 'c.'c t -> (('c,'b) continuation -> 'b) option }
73
74 external reperform :
75 'a t -> ('a, 'b) continuation -> last_fiber -> 'b = "%reperform"
76
77 let match_with comp arg handler =
78 let effc eff k last_fiber =
79 match handler.effc eff with
80 | Some f -> f k
81 | None -> reperform eff k last_fiber
82 in
83 let s = alloc_stack handler.retc handler.exnc effc in
84 runstack s comp arg
85
86 type 'a effect_handler =
87 { effc: 'b. 'b t -> (('b,'a) continuation -> 'a) option }
88
89 let try_with comp arg handler =
90 let effc' eff k last_fiber =
91 match handler.effc eff with
92 | Some f -> f k
93 | None -> reperform eff k last_fiber
94 in
95 let s = alloc_stack (fun x -> x) (fun e -> raise e) effc' in
96 runstack s comp arg
97
98 external get_callstack :
99 ('a,'b) continuation -> int -> Printexc.raw_backtrace =
100 "caml_get_continuation_callstack"
101end
102
103module Shallow = struct
104
105 type ('a,'b) continuation
106
107 external alloc_stack :
108 ('a -> 'b) ->
109 (exn -> 'b) ->
110 ('c t -> ('c, 'b) continuation -> last_fiber -> 'b) ->
111 ('a, 'b) stack = "caml_alloc_stack"
112
113 external cont_last_fiber : ('a, 'b) continuation -> last_fiber = "%field1"
114
115 let fiber : type a b. (a -> b) -> (a, b) continuation = fun f ->
116 let module M = struct type _ t += Initial_setup__ : a t end in
117 let exception E of (a,b) continuation in
118 let f' () = f (perform M.Initial_setup__) in
119 let error _ = failwith "impossible" in
120 let effc eff k _last_fiber =
121 match eff with
122 | M.Initial_setup__ -> raise_notrace (E k)
123 | _ -> error ()
124 in
125 let s = alloc_stack error error effc in
126 match runstack s f' () with
127 | exception E k -> k
128 | _ -> error ()
129
130 type ('a,'b) handler =
131 { retc: 'a -> 'b;
132 exnc: exn -> 'b;
133 effc: 'c.'c t -> (('c,'a) continuation -> 'b) option }
134
135 external update_handler :
136 ('a,'b) continuation ->
137 ('b -> 'c) ->
138 (exn -> 'c) ->
139 ('d t -> ('d,'b) continuation -> last_fiber -> 'c) ->
140 ('a,'c) stack = "caml_continuation_use_and_update_handler_noexc" [@@noalloc]
141
142 external reperform :
143 'a t -> ('a, 'b) continuation -> last_fiber -> 'c = "%reperform"
144
145 let continue_gen k resume_fun v handler =
146 let effc eff k last_fiber =
147 match handler.effc eff with
148 | Some f -> f k
149 | None -> reperform eff k last_fiber
150 in
151 let last_fiber = cont_last_fiber k in
152 let stack = update_handler k handler.retc handler.exnc effc in
153 resume stack resume_fun v last_fiber
154
155 let continue_with k v handler =
156 continue_gen k (fun x -> x) v handler
157
158 let discontinue_with k v handler =
159 continue_gen k (fun e -> raise e) v handler
160
161 let discontinue_with_backtrace k v bt handler =
162 continue_gen k (fun e -> Printexc.raise_with_backtrace e bt) v handler
163
164 external get_callstack :
165 ('a,'b) continuation -> int -> Printexc.raw_backtrace =
166 "caml_get_continuation_callstack"
167end