Make Picos_select explicitly configurable

polytypic · polytypic · commit 7cf277ebc7e1 · 2024-04-15T10:53:40.000+03:00
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,8 +1,11 @@
 ## Next version
 
+- Added `Picos_select.configure` to allow, and sometimes require, configuring
+  `Picos_select` for co-operation with libraries that also deal with signals
+  (@polytypic)
 - Moved `Picos_tls` into `Picos_thread.TLS` (@polytypic)
 - Enhanced `sleep` and `sleepf` in `Picos_stdio.Unix` to block in a scheduler
-  friendly manner (@polytypic).
+  friendly manner (@polytypic)
 
 ## 0.1.0
 
diff --git a/lib/picos_fifos/picos_fifos.ml b/lib/picos_fifos/picos_fifos.ml
@@ -104,6 +104,7 @@ let rec next t =
       end
 
 let run ~forbid main =
+  Select.check_configured ();
   let ready = Queue.create ()
   and needs_wakeup = Atomic.make false
   and num_alive_fibers = Atomic.make 1
diff --git a/lib/picos_fifos/select.none.ml b/lib/picos_fifos/select.none.ml
@@ -1,2 +1,4 @@
 let cancel_after _ ~seconds:_ _ =
   raise (Sys_error "Computation: cancel_after unavailable")
+
+let check_configured = Fun.id
diff --git a/lib/picos_fifos/select.some.ml b/lib/picos_fifos/select.some.ml
@@ -1 +1,2 @@
 let cancel_after = Picos_select.cancel_after
+let check_configured = Picos_select.check_configured
diff --git a/lib/picos_select/picos_select.ml b/lib/picos_select/picos_select.ml
@@ -1,8 +1,10 @@
 open Picos
 
-let intr_sig = Sys.sigusr2
-let is_intr_sig s = s == intr_sig
-let intr_sigs = [ intr_sig ]
+type config = { mutable intr_sig : int; mutable intr_sigs : int list }
+
+let config = { intr_sig = 0; intr_sigs = [] }
+
+(* *)
 
 type cancel_at =
   | Cancel_at : {
@@ -65,6 +67,15 @@ type counter_state = { value : int; req : req }
 let intr_pending = Atomic.make { value = 0; req = R Nothing }
 let exit_exn_bt = Exn_bt.get_callstack 0 Exit
 
+let cleared =
+  let computation = Computation.create () in
+  Computation.return computation Cleared;
+  computation
+
+let intr_key =
+  Picos_thread.TLS.new_key @@ fun () : [ `Req ] tdt ->
+  invalid_arg "Picos_select has not been configured"
+
 let key =
   Picos_domain.DLS.new_key @@ fun () ->
   {
@@ -198,15 +209,17 @@ and select_thread_continue s rd wr ex (rd_fds, wr_fds, ex_fds) =
     if state.value = 0 then tos
     else begin
       assert (0 < state.value);
-      Unix.kill (Unix.getpid ()) intr_sig;
+      Unix.kill (Unix.getpid ()) config.intr_sig;
       let idle = 0.000_001 (* 1μs *) in
       if tos < 0.0 || idle <= tos then idle else tos
     end
   in
   select_thread s tos rd wr ex
 
 let select_thread s =
-  if not Sys.win32 then Thread.sigmask SIG_BLOCK intr_sigs |> ignore;
+  if not Sys.win32 then begin
+    Thread.sigmask SIG_BLOCK config.intr_sigs |> ignore
+  end;
   begin
     try
       let pipe_inn, pipe_out = Unix.pipe ~cloexec:true () in
@@ -220,7 +233,46 @@ let select_thread s =
   if s.pipe_inn != Unix.stdin then Unix.close s.pipe_inn;
   if s.pipe_out != Unix.stdin then Unix.close s.pipe_out
 
+let[@poll error] [@inline never] try_configure ~intr_sig ~intr_sigs =
+  config.intr_sigs == []
+  && begin
+       config.intr_sig <- intr_sig;
+       config.intr_sigs <- intr_sigs;
+       true
+     end
+
+let is_intr_sig signum = signum = config.intr_sig
+
+let rec configure ?(intr_sig = Sys.sigusr2) () =
+  if not (Picos_thread.is_main_thread ()) then
+    invalid_arg
+      "Picos_select must be configured from the main thread on the main domain";
+  assert (Sys.sigabrt = -1 && Sys.sigxfsz < Sys.sigabrt);
+  if intr_sig < Sys.sigxfsz || 0 <= intr_sig || intr_sig = Sys.sigchld then
+    invalid_arg "Invalid interrupt signal number";
+  if not (try_configure ~intr_sig ~intr_sigs:[ intr_sig ]) then
+    invalid_arg "Picos_select.configure already configured";
+
+  if not Sys.win32 then begin
+    begin
+      let previously_blocked = Thread.sigmask SIG_BLOCK config.intr_sigs in
+      assert (not (List.exists is_intr_sig previously_blocked));
+      let old_behavior =
+        Sys.signal config.intr_sig (Sys.Signal_handle handle_signal)
+      in
+      assert (old_behavior == Signal_default)
+    end
+  end
+
+and handle_signal signal =
+  if signal = config.intr_sig then
+    let (Req r) = Picos_thread.TLS.get intr_key in
+    Computation.return r.computation Signaled
+
+let check_configured () = if config.intr_sigs = [] then configure ()
+
 let[@inline never] init s =
+  check_configured ();
   if try_transition s `Initial `Starting then begin
     match Thread.create select_thread s with
     | thread ->
@@ -319,21 +371,8 @@ let await_on file_descr op =
 module Intr = struct
   type t = req
 
-  let cleared =
-    let computation = Computation.create () in
-    Computation.return computation Cleared;
-    computation
-
-  let intr_key =
-    Picos_thread.TLS.new_key @@ fun () : [ `Req ] tdt ->
-    Req { state = get (); unused = false; computation = cleared }
-
   let[@inline] use = function R Nothing -> () | R (Req r) -> r.unused <- false
 
-  let handle _ =
-    let (Req r) = Picos_thread.TLS.get intr_key in
-    Computation.return r.computation Signaled
-
   (** This is used to ensure that the [intr_pending] counter is incremented
       exactly once before the counter is decremented. *)
   let rec incr_once (Req r as req : [ `Req ] tdt) backoff =
@@ -366,14 +405,6 @@ module Intr = struct
         let _ : bool = incr_once req Backoff.default in
         ()
 
-  let () =
-    if not Sys.win32 then begin
-      let previously_blocked = Thread.sigmask SIG_BLOCK intr_sigs in
-      assert (not (List.exists is_intr_sig previously_blocked));
-      let old_behavior = Sys.signal intr_sig (Sys.Signal_handle handle) in
-      assert (old_behavior == Signal_default)
-    end
-
   let nothing = R Nothing
 
   let[@alert "-handler"] req ~seconds =
@@ -392,8 +423,10 @@ module Intr = struct
       Picos_thread.TLS.set intr_key req;
       let entry = Cancel_at { time; exn_bt = exit_exn_bt; computation } in
       add_timeout state id entry;
-      let _was_blocked : int list = Thread.sigmask SIG_UNBLOCK intr_sigs in
-      (* assert (List.exists is_intr_sig was_blocked); *)
+      let was_blocked : int list =
+        Thread.sigmask SIG_UNBLOCK config.intr_sigs
+      in
+      assert (List.exists is_intr_sig was_blocked);
       R req
     end
 
@@ -408,8 +441,10 @@ module Intr = struct
   let clr = function
     | R Nothing -> ()
     | R (Req r as req) ->
-        let _was_blocked : int list = Thread.sigmask SIG_BLOCK intr_sigs in
-        (* assert (not (List.exists is_intr_sig was_blocked)); *)
+        let was_blocked : int list =
+          Thread.sigmask SIG_BLOCK config.intr_sigs
+        in
+        assert (not (List.exists is_intr_sig was_blocked));
         if not (Computation.try_return r.computation Cleared) then begin
           let _ : bool = incr_once req Backoff.default in
           (* We ensure that the associated increment has been done before we
diff --git a/lib/picos_select/picos_select.mli b/lib/picos_select/picos_select.mli
@@ -3,6 +3,12 @@
     The operations in this module automatically manage a {!Thread} per domain
     that runs a {!Unix.select} loop to support the operations.
 
+    ⚠️ Signal handlers are unfortunately fundamentally non-compositional.  The
+    use of signal handlers in this module has been designed to be {{!configure}
+    configurable}, which should allow co-operating with other libraries using
+    signals as long as care is taken at application startup to {!configure}
+    things.
+
     ⚠️ All the usual limitations of the {!Unix} module apply. *)
 
 open Picos
@@ -35,8 +41,8 @@ val await_on : Picos_fd.t -> [ `R | `W | `E ] -> Picos_fd.t
 module Intr : sig
   (** A mechanism to interrupt blocking {!Unix} IO operations.
 
-      ⚠️ The mechanism uses the {!Sys.sigusr2} signal which should not be used
-      for other purposes at the same time.
+      ⚠️ The mechanism uses {{!configure} a signal} which should not be used for
+      other purposes.
 
       ⚠️ Beware that signal handling in OCaml 5.0.0 is known to be broken and
       several fixes were included in OCaml {{:https://ocaml.org/releases/5.1.0}
@@ -63,3 +69,32 @@ module Intr : sig
   (** [clr req] either cancels or acknowledges the interrupt request.  Every
       {!req} must be cleared exactly once! *)
 end
+
+(** {1 Configuration} *)
+
+val configure : ?intr_sig:int -> unit -> unit
+(** [configure ~intr_sig ()] can, and sometimes must, be called by an
+    application to configure the use of signals by this module.
+
+    The optional [intr_sig] argument can be used to specify the signal used by
+    the {{!Intr} interrupt} mechanism.  The default is to use {!Sys.sigusr2}.
+
+    ⚠️ This module must always be configured before use.  Unless this module has
+    been explicitly configured, calling a method of this module from the main
+    thread on the main domain will automatically configure this module with
+    default options.  In case the application uses multiple threads or multiple
+    domains, the application should arrange to call [configure] from the main
+    thread on the main domain before any threads or domains besides the main are
+    created or spawned. *)
+
+val handle_signal : int -> unit
+(** [handle_signal signum] should be called to notify this module of a signal
+    when {{!configure} configured} to not handle said signals. *)
+
+val check_configured : unit -> unit
+(** [check_configured ()] checks whether this module has already been
+    {{!configure} configured} or not and, if not, calls {!configure} with
+    default arguments.
+
+    ℹ️ The intended use case for [check_configure ()] is at the point of
+    entry of schedulers and other facilities that use this module. *)
diff --git a/lib/picos_stdio/picos_stdio.mli b/lib/picos_stdio/picos_stdio.mli
@@ -29,6 +29,9 @@ module Unix : sig
 
       also block in a scheduler friendly manner.
 
+      ⚠️ This module uses {!Picos_select} and you may need to
+      {{!Picos_select.configure} configure} it at start of your application.
+
       Please consult the documentation of the {{!Deps.Unix} [Unix]} module that
       comes with OCaml. *)
 
diff --git a/lib/picos_threaded/picos_threaded.ml b/lib/picos_threaded/picos_threaded.ml
@@ -83,4 +83,5 @@ and spawn : type a. _ -> forbid:bool -> a Computation.t -> _ =
 and handler = Handler.{ current; spawn; yield; cancel_after; await }
 
 let run ~forbid main =
+  Select.check_configured ();
   Handler.using handler (create ~forbid (Computation.create ())) main
diff --git a/lib/picos_threaded/select.none.ml b/lib/picos_threaded/select.none.ml
@@ -1,2 +1,4 @@
 let cancel_after _ ~seconds:_ _ =
   raise (Sys_error "Computation: cancel_after unavailable")
+
+let check_configured = Fun.id
diff --git a/lib/picos_threaded/select.some.ml b/lib/picos_threaded/select.some.ml
@@ -1 +1,2 @@
 let cancel_after = Picos_select.cancel_after
+let check_configured = Picos_select.check_configured
diff --git a/test/test_select.ml b/test/test_select.ml
@@ -1,5 +1,7 @@
 open Picos
 
+let () = Picos_select.configure ()
+
 let test_intr () =
   let inn, out = Unix.pipe ~cloexec:true () in
   let main () =

Original file line number	Diff line number	Diff line change
`@@ -1 +1,2 @@`
`1`	`1`	`let cancel_after = Picos_select.cancel_after`
	`2`	`+let check_configured = Picos_select.check_configured`