Source file raw_signal_manager.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
open Core
module Signal = Core.Signal

module Handlers = struct
  type t = { bag : ((Signal.t -> unit)[@sexp.opaque]) Bag.t } [@@deriving sexp_of]

  let create () = { bag = Bag.create () }
  let add t handler = Bag.add t.bag handler
  let remove t handler_elt = Bag.remove t.bag handler_elt

  let deliver t signal =
    Bag.iter t.bag ~f:(fun handler ->
      try handler signal with
      | exn -> raise_s [%message "signal handler unexpectedly raised" (exn : exn)])
  ;;
end

type delivered = (Signal.t * Handlers.t) Thread_safe_queue.t

type t =
  { handlers_by_signal : Handlers.t Signal.Table.t
  ; delivered : (delivered[@sexp.opaque])
  ; thread_safe_notify_signal_delivered : unit -> unit
  }
[@@deriving sexp_of]

let invariant _ = ()

let create ~thread_safe_notify_signal_delivered =
  { handlers_by_signal = Signal.Table.create ()
  ; delivered = Thread_safe_queue.create ()
  ; thread_safe_notify_signal_delivered
  }
;;

let is_managing t signal = Hashtbl.mem t.handlers_by_signal signal

module Handler = struct
  type t = T of (Handlers.t * (Signal.t -> unit) Bag.Elt.t) list
end

type handler = Handler.t

let get_handlers t signal =
  Hashtbl.find_or_add t.handlers_by_signal signal ~default:(fun () ->
    let handlers = Handlers.create () in
    Signal.Expert.handle signal (fun _ ->
      (* Everything in this function body must be thread safe, since it is running in an
         OCaml signal handler. *)
      Thread_safe_queue.enqueue t.delivered (signal, handlers);
      t.thread_safe_notify_signal_delivered ());
    handlers)
;;

let manage t signal = ignore (get_handlers t signal : Handlers.t)

let install_handler t signals handler =
  Handler.T
    (List.map signals ~f:(fun signal ->
       let handlers = get_handlers t signal in
       handlers, Handlers.add handlers handler))
;;

let remove_handler _t (Handler.T handler) =
  List.iter handler ~f:(fun (handlers, handler_elt) ->
    Handlers.remove handlers handler_elt)
;;

let handle_delivered t =
  while Thread_safe_queue.length t.delivered > 0 do
    let signal, handlers = Thread_safe_queue.dequeue_exn t.delivered in
    Handlers.deliver handlers signal
  done
;;