Ensure signals are handled before Unix.{kill,sigprocmask} return (#9802)

Changes

@@ -197,6 +197,9 @@ Working version
   error handling when Unix.symlink is unavailable)
   (David Allsopp, review by Xavier Leroy)
 
+- #9802: Ensure signals are handled before Unix.kill returns
+  (Stephen Dolan, review by Jacques-Henri Jourdan)
+
 ### Tools:
 
 - #9551: ocamlobjinfo is now able to display information on .cmxs shared

otherlibs/unix/kill.c

@@ -27,5 +27,6 @@ CAMLprim value unix_kill(value pid, value signal)
   sig = caml_convert_signal_number(Int_val(signal));
   if (kill(Int_val(pid), sig) == -1)
     uerror("kill", Nothing);
+  caml_process_pending_actions();
   return Val_unit;
 }

testsuite/tests/callback/callbackprim.c

@@ -13,6 +13,7 @@
 /*                                                                        */
 /**************************************************************************/
 
+#include <signal.h>
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
 #include "caml/callback.h"
@@ -67,3 +68,9 @@ value mycamlparam (value v, value fun, value arg)
   v = x;
   CAMLreturn (v);
 }
+
+value raise_sigusr1(value unused)
+{
+  raise(SIGUSR1);
+  return Val_unit;
+}

testsuite/tests/callback/signals_alloc.ml

@@ -1,11 +1,11 @@
 (* TEST
    include unix
+   modules = "callbackprim.c"
    * libunix
    ** bytecode
    ** native
 *)
-
-let pid = Unix.getpid ()
+external raise_sigusr1 : unit -> unit = "raise_sigusr1" [@@noalloc]
 
 let do_test () =
   let seen_states = Array.make 5 (-1) in
@@ -19,7 +19,7 @@ let do_test () =
   seen_states.(!pos) <- 0; pos := !pos + 1;
   Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler);
   seen_states.(!pos) <- 1; pos := !pos + 1;
-  Unix.kill pid Sys.sigusr1;
+  raise_sigusr1 ();
   seen_states.(!pos) <- 2; pos := !pos + 1;
   let _ = Sys.opaque_identity (ref 1) in
   seen_states.(!pos) <- 4; pos := !pos + 1;

testsuite/tests/callback/tcallback.ml

@@ -52,17 +52,14 @@ let sighandler signo =
   (* Thoroughly wipe the minor heap *)
   ignore (tak (18, 12, 6))
 
-external unix_getpid : unit -> int = "unix_getpid" [@@noalloc]
-external unix_kill : int -> int -> unit = "unix_kill" [@@noalloc]
+external raise_sigusr1 : unit -> unit = "raise_sigusr1" [@@noalloc]
 
 let callbacksig () =
-  let pid = unix_getpid() in
   (* Allocate a block in the minor heap *)
   let s = String.make 5 'b' in
   (* Send a signal to self.  We want s to remain in a register and
-     not be spilled on the stack, hence we declare unix_kill
-     [@@noalloc]. *)
-  unix_kill pid Sys.sigusr1;
+     not be spilled on the stack, hence we use a [@@noalloc] stub *)
+  raise_sigusr1 ();
   (* Allocate some more so that the signal will be tested *)
   let u = (s, s) in
   fst u

testsuite/tests/lib-unix/kill/unix_kill.ml

@@ -0,0 +1,26 @@
+(* TEST
+include unix
+* libunix
+** bytecode
+** native
+*)
+
+let () =
+  let r = ref false in
+  Sys.set_signal Sys.sigint (Signal_handle (fun _ -> r := true));
+  Unix.kill (Unix.getpid ()) Sys.sigint;
+  let x = !r in
+  Printf.printf "%b " x;
+  Printf.printf "%b\n" !r
+
+let () =
+  let r = ref false in
+  let _ = Unix.sigprocmask SIG_BLOCK [Sys.sigint] in
+  Sys.set_signal Sys.sigint (Signal_handle (fun _ -> r := true));
+  Unix.kill (Unix.getpid ()) Sys.sigint;
+  Gc.full_major ();
+  let a = !r in
+  let _ = Unix.sigprocmask SIG_UNBLOCK [Sys.sigint] in
+  let b = !r in
+  Printf.printf "%b %b " a b;
+  Printf.printf "%b\n" !r

testsuite/tests/lib-unix/kill/unix_kill.reference

@@ -0,0 +1,2 @@
+true true
+false true true