Source file `execution_context.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
open! Core
open! Import
module Monitor = Monitor0

type t = Types.Execution_context.t =
  { monitor : Monitor.t
  ; priority : Priority.t
  ; local_storage : Univ_map.t
  ; backtrace_history : Backtrace.t list
  }
[@@deriving fields ~getters, sexp_of]

let invariant (_ : t) = ()

let main =
  { monitor = Monitor.main
  ; priority = Priority.normal
  ; local_storage = Univ_map.empty
  ; backtrace_history = []
  }
;;

let create_like ?monitor ?priority ?local_storage t =
  match monitor, priority, local_storage with
  | None, None, None ->
    (* avoid allocating in the trivial case, which e.g. happens when calling
       [Async.schedule] without optional args *)
    t
  | _ ->
    let monitor = Option.value monitor ~default:t.monitor in
    { monitor
    ; priority = Option.value priority ~default:t.priority
    ; local_storage = Option.value local_storage ~default:t.local_storage
    ; backtrace_history = t.backtrace_history
    }
;;

let find_local t key = Univ_map.find t.local_storage key

let with_local t key data =
  match data with
  | Some data -> { t with local_storage = Univ_map.set t.local_storage ~key ~data }
  | None -> { t with local_storage = Univ_map.remove t.local_storage key }
;;

let record_backtrace t =
  { t with backtrace_history = Backtrace.get () :: t.backtrace_history }
;;