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
open Picos
exception Terminate
let terminate_bt = Exn_bt.get_callstack 0 Terminate
let terminate_bt ?callstack () =
match callstack with
| None -> terminate_bt
| Some n -> Exn_bt.get_callstack n Terminate
exception Errors of Exn_bt.t list
let () =
Printexc.register_printer @@ function
| Errors exn_bts ->
let causes =
List.map (fun exn_bt -> Printexc.to_string exn_bt.Exn_bt.exn) exn_bts
|> String.concat "; "
in
Some (Printf.sprintf "Errors[%s]" causes)
| _ -> None
module Errors = struct
type t = Exn_bt.t list Atomic.t
let create () = Atomic.make []
let rec check (exn_bts : Exn_bt.t list) exns =
match exn_bts with
| [] -> ()
| [ exn_bt ] ->
Printexc.raise_with_backtrace (Errors (exn_bt :: exns)) exn_bt.bt
| exn_bt :: exn_bts -> check exn_bts (exn_bt :: exns)
let check t =
match Atomic.get t with
| [] -> ()
| [ exn_bt ] -> Exn_bt.raise exn_bt
| exn_bts -> check exn_bts []
let rec push t exn_bt backoff =
let before = Atomic.get t in
let after = exn_bt :: before in
if not (Atomic.compare_and_set t before after) then
push t exn_bt (Backoff.once backoff)
let push t exn_bt = push t exn_bt Backoff.default
end
let raise_if_canceled () = Fiber.check (Fiber.current ())
let yield = Fiber.yield
let sleep = Fiber.sleep
let block () =
match Trigger.await (Trigger.create ()) with
| None -> failwith "impossible"
| Some exn_bt -> Exn_bt.raise exn_bt
let protect thunk = Fiber.forbid (Fiber.current ()) thunk