Fix Thread.sigmask, take 2 (#2211)

Fix Thread.sigmaks, by checking whether a signal is masked before handling it.

We use [sigprocmask] (if available) to check whether a signal is
blocked when the systhread library is not loaded. As soon as the
[Thread] module gets loaded, we use [pthread_sigmask] instead, and
redirect all the calls to [sigprocmask] to [pthread_sigmask].  Indeed,
the latter has unspecified behavior in a multi-threaded context
anyway.  In practice, this should not change the semantics of
[Unix.sigprocmask] on Linux, since on this platform, [pthread_sigmask]
is actually an alias for [sigprocmask]. On MacOSX, the semantics will
change, since [sigprocmask] changes the masks of the whole process on
this platform.

Also, include [caml_pending_signals] in signals returned by
[Unix.sigpending]. Indeed, some signals might have been handled in the
POSIX sense by the C handler in the OCaml runtime, but not been
handled in the OCaml sense (for example, because they are blocked).

This commit un-reverts 1c82c481a, which has been reverted in
79eb572e4. The issues of the original commit are corrected in this commit.

Changes

@@ -244,6 +244,12 @@ OCaml 4.08.0
 
 ### Other libraries:
 
+* GPR#2104, GPR#2211, PR#4127, PR#7709: Fix Thread.sigmask. When
+  system threads are loaded, Unix.sigprocmask is now an alias for
+  Thread.sigmask. This changes the behavior at least on MacOS, where
+  Unix.sigprocmask used to change the masks of all threads.
+  (Jacques-Henri Jourdan, review by Jérémie Dimino)
+
 - GPR#1061: Add ?follow parameter to Unix.link. This allows hardlinking
   symlinks.
   (Christopher Zimmermann, review by Xavier Leroy, Damien Doligez, David

otherlibs/systhreads/st_posix.h

@@ -45,6 +45,7 @@ typedef int st_retcode;
 
 static int st_initialize(void)
 {
+  caml_sigmask_hook = pthread_sigmask;
   return 0;
 }
 

otherlibs/unix/signals.c

@@ -69,16 +69,20 @@ CAMLprim value unix_sigprocmask(value vaction, value vset)
   how = sigprocmask_cmd[Int_val(vaction)];
   decode_sigset(vset, &set);
   caml_enter_blocking_section();
-  retcode = sigprocmask(how, &set, &oldset);
+  retcode = caml_sigmask_hook(how, &set, &oldset);
   caml_leave_blocking_section();
-  if (retcode == -1) uerror("sigprocmask", Nothing);
+  if (retcode != 0) unix_error(retcode, "sigprocmask", Nothing);
   return encode_sigset(&oldset);
 }
 
 CAMLprim value unix_sigpending(value unit)
 {
   sigset_t pending;
+  int i;
   if (sigpending(&pending) == -1) uerror("sigpending", Nothing);
+  for (i = 1; i < NSIG; i++)
+    if(caml_pending_signals[i])
+      sigaddset(&pending, i);
   return encode_sigset(&pending);
 }
 

otherlibs/unix/unix.mli

@@ -1023,6 +1023,10 @@ val sigprocmask : sigprocmask_command -> int list -> int list
    from the set of blocked signals.
    [sigprocmask] returns the set of previously blocked signals.
 
+   When the systhreads version of the [Thread] module is loaded, this
+   function redirects to [Thread.sigmask]. I.e., [sigprocmask] only
+   changes the mask of the current thread.
+
    On Windows: not implemented (no inter-process signals on Windows). *)
 
 val sigpending : unit -> int list

runtime/caml/signals.h

@@ -16,6 +16,10 @@
 #ifndef CAML_SIGNALS_H
 #define CAML_SIGNALS_H
 
+#if defined(CAML_INTERNALS) && defined(POSIX_SIGNALS)
+#include<signal.h>
+#endif
+
 #ifndef CAML_NAME_SPACE
 #include "compatibility.h"
 #endif
@@ -47,6 +51,9 @@ CAMLextern void (*caml_enter_blocking_section_hook)(void);
 CAMLextern void (*caml_leave_blocking_section_hook)(void);
 CAMLextern int (*caml_try_leave_blocking_section_hook)(void);
 CAMLextern void (* volatile caml_async_action_hook)(void);
+#ifdef POSIX_SIGNALS
+CAMLextern int (*caml_sigmask_hook)(int, const sigset_t *, sigset_t *);
+#endif
 #endif /* CAML_INTERNALS */
 
 CAMLextern void caml_enter_blocking_section (void);

runtime/signals.c

@@ -44,20 +44,57 @@
 CAMLexport intnat volatile caml_signals_are_pending = 0;
 CAMLexport intnat volatile caml_pending_signals[NSIG];
 
+#ifdef POSIX_SIGNALS
+/* This wrapper makes [sigprocmask] compatible with
+   [pthread_sigmask]. Indeed, the latter returns the error code while
+   the former sets [errno].
+ */
+static int sigprocmask_wrapper(int how, const sigset_t *set, sigset_t *oldset) {
+  if(sigprocmask(how, set, oldset) != 0) return errno;
+  else return 0;
+}
+
+CAMLexport int (*caml_sigmask_hook)(int, const sigset_t *, sigset_t *)
+  = sigprocmask_wrapper;
+#endif
+
 /* Execute all pending signals */
 
 void caml_process_pending_signals(void)
 {
   int i;
+  int really_pending;
+#ifdef POSIX_SIGNALS
+  sigset_t set;
+#endif
 
-  if (caml_signals_are_pending) {
-    caml_signals_are_pending = 0;
-    for (i = 0; i < NSIG; i++) {
-      if (caml_pending_signals[i]) {
-        caml_pending_signals[i] = 0;
-        caml_execute_signal(i, 0);
-      }
+  if(!caml_signals_are_pending)
+    return;
+  caml_signals_are_pending = 0;
+
+  /* Check that there is indeed a pending signal before issuing the
+     syscall in [caml_sigmask_hook]. */
+  really_pending = 0;
+  for (i = 0; i < NSIG; i++)
+    if (caml_pending_signals[i]) {
+      really_pending = 1;
+      break;
     }
+  if(!really_pending)
+    return;
+
+#ifdef POSIX_SIGNALS
+  caml_sigmask_hook(/* dummy */ SIG_BLOCK, NULL, &set);
+#endif
+  for (i = 0; i < NSIG; i++) {
+    if (!caml_pending_signals[i])
+      continue;
+#ifdef POSIX_SIGNALS
+    if(sigismember(&set, i))
+      continue;
+#endif
+    caml_pending_signals[i] = 0;
+    caml_execute_signal(i, 0);
   }
 }
 
@@ -128,7 +165,22 @@ CAMLexport void caml_leave_blocking_section(void)
   /* Save the value of errno (PR#5982). */
   saved_errno = errno;
   caml_leave_blocking_section_hook ();
+
+  /* Some other thread may have switched
+     [caml_signals_are_pending] to 0 even though there are still
+     pending signals (masked in the other thread). To handle this
+     case, we force re-examination of all signals by setting it back
+     to 1.
+
+     Another case where this is necessary (even in a single threaded
+     setting) is when the blocking section unmasks a pending signal:
+     If the signal is pending and masked but has already been
+     examinated by [caml_process_pending_signals], then
+     [caml_signals_are_pending] is 0 but the signal needs to be
+     handled at this point. */
+  caml_signals_are_pending = 1;
   caml_process_pending_signals();
+
   errno = saved_errno;
 }
 
@@ -149,7 +201,7 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
      the original signal mask */
   sigemptyset(&nsigs);
   sigaddset(&nsigs, signal_number);
-  sigprocmask(SIG_BLOCK, &nsigs, &sigs);
+  caml_sigmask_hook(SIG_BLOCK, &nsigs, &sigs);
 #endif
 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
   /* We record the signal handler's execution separately, in the same
@@ -184,11 +236,11 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
 #ifdef POSIX_SIGNALS
   if (! in_signal_handler) {
     /* Restore the original signal mask */
-    sigprocmask(SIG_SETMASK, &sigs, NULL);
+    caml_sigmask_hook(SIG_SETMASK, &sigs, NULL);
   } else if (Is_exception_result(res)) {
     /* Restore the original signal mask and unblock the signal itself */
     sigdelset(&sigs, signal_number);
-    sigprocmask(SIG_SETMASK, &sigs, NULL);
+    caml_sigmask_hook(SIG_SETMASK, &sigs, NULL);
   }
 #endif
   if (Is_exception_result(res)) caml_raise(Extract_exception(res));

runtime/signals_nat.c

@@ -166,7 +166,7 @@ DECLARE_SIGNAL_HANDLER(trap_handler)
   { sigset_t mask;
     sigemptyset(&mask);
     sigaddset(&mask, SIGTRAP);
-    sigprocmask(SIG_UNBLOCK, &mask, NULL);
+    caml_sigmask_hook(SIG_UNBLOCK, &mask, NULL);
   }
 #endif
   caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;

testsuite/tests/lib-systhreads/ocamltests

@@ -1,3 +1,4 @@
 testfork.ml
 testpreempt.ml
 testyield.ml
+threadsigmask.ml

testsuite/tests/lib-systhreads/threadsigmask.ml

@@ -0,0 +1,80 @@
+(* TEST
+
+* hassysthreads
+include systhreads
+** not-windows
+*** bytecode
+*** native
+*)
+
+let stopped = ref false
+
+(* This function is purposed to do some computations which allocate,
+   so that the corresponding thread is likely to handle signals if it
+   is allowed to. *)
+let rec loop () =
+  let rec generate_list n =
+    let rec aux acc = function
+      | 0 -> acc
+      | n -> aux (float n :: acc) (n-1)
+    in
+    aux [] n
+  in
+  let long_list = generate_list 100000 in
+  let res = List.length (List.rev_map sin long_list) in
+  ignore (Sys.opaque_identity res)
+
+let thread s =
+  ignore (Thread.sigmask Unix.SIG_UNBLOCK [s]);
+  while not !stopped do loop () done
+
+let handler tid_exp cnt signal =
+  incr cnt;
+  if Thread.id (Thread.self ()) != !tid_exp then
+    Printf.printf "Signal received in an unexpected thread !\n"
+
+let _ =
+  ignore (Thread.sigmask Unix.SIG_BLOCK [Sys.sigusr1; Sys.sigusr2]);
+
+  (* Install the signal handlers *)
+  let (tid1, tid2) = (ref 0, ref 0) in
+  let (cnt1, cnt2) = (ref 0, ref 0) in
+  Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (handler tid1 cnt1));
+  Sys.set_signal Sys.sigusr2 (Sys.Signal_handle (handler tid2 cnt2));
+
+  (* Spawn the other thread and unblock sigusr2 in the main thread *)
+  let t1 = Thread.create thread Sys.sigusr1 in
+  let t2 = Thread.self () in
+  ignore (Thread.sigmask Unix.SIG_UNBLOCK [Sys.sigusr2]);
+  tid1 := Thread.id t1;
+  tid2 := Thread.id t2;
+
+  (* Send signals to the current process. They should be received by the
+     correct respective threads. *)
+  let pid = Unix.getpid () in
+  let cntsent = ref 0 in
+  (* We loop until each thread has received at least 5 signals and we
+    have sent more than 100 signals in total. We do not check that all
+    signals get handled, because they could be missed because of the
+    lack of fairness of the scheduler. *)
+  while !cntsent < 100 || !cnt1 < 5 || !cnt2 < 5 do
+    Unix.kill pid Sys.sigusr1;
+    Unix.kill pid Sys.sigusr2;
+    incr cntsent;
+    Thread.delay 0.07;
+
+    (* Still, if too many signals have been sent, we interrupt the
+       test to avoid a timeout. *)
+    if !cntsent > 2000 then begin
+        stopped := true;
+        Thread.join t1;
+        Printf.printf "A thread does not receive signals. %d %d %d\n" !cnt1 !cnt2 !cntsent;
+        exit 0
+    end
+  done;
+
+  (* Join worker thread *)
+  stopped := true;
+  Thread.join t1;
+
+  Printf.printf "OK\n"

testsuite/tests/lib-systhreads/threadsigmask.reference

@@ -0,0 +1 @@
+OK

testsuite/tests/lib-threads/signal.ml

@@ -34,7 +34,7 @@ program = "${test_build_directory}/signal.opt"
 program = "sigint"
 all_modules = "sigint.c"
 
-***** ocamlc.byte
+***** ocamlopt.byte
 
 program = "${test_build_directory}/signal.opt"
 all_modules = "signal.ml"