address some TODOs and then make new ones

raphael-proust · raphael-proust · commit f4aa1518ea96 · 2025-09-16T11:13:59.000+02:00
diff --git a/src/unix/lwt_unix.cppo.ml b/src/unix/lwt_unix.cppo.ml
@@ -2228,15 +2228,13 @@ let init_domain () =
    | Signals                                                         |
    +-----------------------------------------------------------------+ *)
 
-(* TODO: should all notifications for signals be on domain0? or should each
-   domain be able to install their own signal handler? what domain receives a
-   signal? *)
-
 external set_signal : int -> int -> bool -> unit = "lwt_unix_set_signal"
 external remove_signal : int -> bool -> unit = "lwt_unix_remove_signal"
 external init_signals : unit -> unit = "lwt_unix_init_signals"
 external handle_signal : int -> unit = "lwt_unix_handle_signal"
 
+let signal_setting_mutex = Mutex.create ()
+
 let () = init_signals ()
 
 let set_signal signum notification =
@@ -2254,22 +2252,28 @@ type signal_handler = {
 
 and signal_handler_id = signal_handler option ref
 
-(* TODO: make parallel safe *)
-let signals : (notification * ((signal_handler_id -> file_perm -> unit) Lwt_sequence.t) ) Signal_map.t ref = ref Signal_map.empty
+let signals
+  (* a simple ref, but all access for write are behind a mutex *)
+  : (notification * ((signal_handler_id -> file_perm -> unit) Lwt_sequence.t) ) Signal_map.t ref
+  = ref Signal_map.empty
 let signal_count () =
   Signal_map.fold
     (fun _signum (_notification, actions) len -> len + Lwt_sequence.length actions)
     !signals
     0
 
 let on_signal_full signum handler =
+  Mutex.lock signal_setting_mutex;
   let id = ref None in
   let _, actions =
     try
       Signal_map.find signum !signals
     with Not_found ->
       let actions = Lwt_sequence.create () in
       let notification =
+        (* TODO: this assumes `on_signal` is called from domain0 where an lwt
+           scheduler is running running, should it be possible to set a signal
+           handler to execute in a specific domain?? *)
         make_notification
           (fun () ->
              Lwt_sequence.iter_l
@@ -2286,6 +2290,7 @@ let on_signal_full signum handler =
   in
   let node = Lwt_sequence.add_r handler actions in
   id := Some { sh_num = signum; sh_node = node };
+  Mutex.unlock signal_setting_mutex;
   id
 
 let on_signal signum f = on_signal_full signum (fun _notification num -> f num)
@@ -2295,27 +2300,32 @@ let disable_signal_handler id =
   | None ->
     ()
   | Some sh ->
+    Mutex.lock signal_setting_mutex;
     id := None;
     Lwt_sequence.remove sh.sh_node;
     let notification, actions = Signal_map.find sh.sh_num !signals in
     if Lwt_sequence.is_empty actions then begin
       remove_signal sh.sh_num;
       signals := Signal_map.remove sh.sh_num !signals;
       stop_notification notification
-    end
+    end;
+    Mutex.unlock signal_setting_mutex
 
 let reinstall_signal_handler signum =
   match Signal_map.find signum !signals with
   | exception Not_found -> ()
   | notification, _ ->
-    set_signal signum notification.id
+    Mutex.lock signal_setting_mutex;
+    set_signal signum notification.id;
+    Mutex.unlock signal_setting_mutex
 
 (* +-----------------------------------------------------------------+
    | Processes                                                       |
    +-----------------------------------------------------------------+ *)
 
 external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork"
 
+(* TODO: replace fork with something thread+domain safe *)
 let fork () =
   match Unix.fork () with
   | 0 ->
@@ -2367,7 +2377,6 @@ let do_wait4 flags pid =
 let wait_children = Lwt_sequence.create ()
 let wait_count () = Lwt_sequence.length wait_children
 
-(* TODO: what to do about signals? especially sigchld signal? *)
 let sigchld_handler_installed = ref false
 
 let install_sigchld_handler () =
@@ -2396,12 +2405,15 @@ let install_sigchld_handler () =
    install the SIGCHLD handler, in order to cause any EINTR-unsafe code to
    fail (as it should). *)
 let () =
-  (* TODO: figure out what to do about signals *)
-  (* TODO: this interferes with tests because it leaves a pause hanging? *)
-  if (Domain.self () :> int) = 0 then
-    Lwt.async (fun () ->
-      Lwt.pause () >|= fun () ->
-      install_sigchld_handler ())
+  (* TODO: this assumes that an Lwt main loop will be started in domain0 (where
+     this value is allocated bc top-level initialisation), instead
+     [install_sigchld_handler] should be called when the first lwt-scheduler is
+     started which could be in a non-zero domain
+
+     or TODO: remove sigchld handler if fork is completely abandonned?? *)
+  Lwt.async (fun () ->
+    Lwt.pause () >|= fun () ->
+    install_sigchld_handler ())
 
 let _waitpid flags pid =
   Lwt.catch
