Stop signal thread before forking, restart it afterwards.

Fixes <https://bugs.gnu.org/68087>.

* libguile/scmsigs.h (scm_i_signals_pre_fork, scm_i_signals_post_fork):
New declarations.
(scm_i_signal_delivery_thread): Change type to SCM..
* libguile/threads.c (scm_all_threads): Adjust accordingly and exclude
threads that have ‘t->exited’.  Access ‘thread_count’ after grabbing
‘thread_admin_mutex’.
* libguile/posix.c (scm_fork): Add calls to ‘scm_i_signals_pre_fork’ and
‘scm_i_signals_post_fork’.
* libguile/scmsigs.c (signal_delivery_thread): Close signal_pipe[0] upon
exit and set it to -1.
(once): New file-global variable, moved from…
(scm_i_ensure_signal_delivery_thread): … here.
(stop_signal_delivery_thread, scm_i_signals_pre_fork)
(scm_i_signals_post_fork): New functions.
* test-suite/standalone/test-sigaction-fork: New file.
* test-suite/standalone/Makefile.am (check_SCRIPTS, TESTS): Add it.

libguile/posix.c

@@ -1295,7 +1295,10 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
 #define FUNC_NAME s_scm_fork
 {
   int pid;
+
   scm_i_finalizer_pre_fork ();
+  scm_i_signals_pre_fork ();
+
   if (scm_ilength (scm_all_threads ()) != 1)
     /* Other threads may be holding on to resources that Guile needs --
        it is not safe to permit one thread to fork while others are
@@ -1317,6 +1320,9 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
 
   if (pid == -1)
     SCM_SYSERROR;
+
+  scm_i_signals_post_fork ();
+
   return scm_from_int (pid);
 }
 #undef FUNC_NAME

libguile/scmsigs.c

@@ -86,7 +86,7 @@ static SCM signal_handler_asyncs;
 static SCM signal_handler_threads;
 
 /* The signal delivery thread.  */
-scm_thread *scm_i_signal_delivery_thread = NULL;
+SCM scm_i_signal_delivery_thread = SCM_BOOL_F;
 
 /* The mutex held when launching the signal delivery thread.  */
 static scm_i_pthread_mutex_t signal_delivery_thread_mutex =
@@ -196,6 +196,9 @@ signal_delivery_thread (void *data)
 	perror ("error in signal delivery thread");
     }
 
+  close (signal_pipe[0]);
+  signal_pipe[0] = -1;
+
   return SCM_UNSPECIFIED; /* not reached unless all other threads exited */
 }
 
@@ -211,18 +214,35 @@ start_signal_delivery_thread (void)
   signal_thread = scm_spawn_thread (signal_delivery_thread, NULL,
 				    scm_handle_by_message,
 				    "signal delivery thread");
-  scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread);
+  scm_i_signal_delivery_thread = signal_thread;
 
   scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
 }
 
+static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+
 void
 scm_i_ensure_signal_delivery_thread ()
 {
-  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
   scm_i_pthread_once (&once, start_signal_delivery_thread);
 }
 
+static void
+stop_signal_delivery_thread ()
+{
+  scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);
+
+  if (scm_is_true (scm_i_signal_delivery_thread))
+    {
+      close (signal_pipe[1]);
+      signal_pipe[1] = -1;
+      scm_join_thread (scm_i_signal_delivery_thread);
+      scm_i_signal_delivery_thread = SCM_BOOL_F;
+    }
+
+  scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
+}
+
 #else /* !SCM_USE_PTHREAD_THREADS */
 
 static void
@@ -248,8 +268,44 @@ scm_i_ensure_signal_delivery_thread ()
   return;
 }
 
+static void
+stop_signal_delivery_thread ()
+{
+  return;
+}
+
 #endif /* !SCM_USE_PTHREAD_THREADS */
 
+/* Perform pre-fork cleanup by stopping the signal delivery thread.  */
+void
+scm_i_signals_pre_fork ()
+{
+  stop_signal_delivery_thread ();
+}
+
+/* Perform post-fork setup by restarting the signal delivery thread if
+   it was active before fork.  This happens in both the parent and the
+   child process.  */
+void
+scm_i_signals_post_fork ()
+{
+  int active = 0;
+
+  for (int sig = 0; sig < NSIG; sig++)
+    {
+      if (scm_is_true (SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig))
+          || scm_is_true (SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig)))
+        {
+          active = 1;
+          break;
+        }
+    }
+
+  once = SCM_I_PTHREAD_ONCE_INIT;
+  if (active)
+    scm_i_ensure_signal_delivery_thread ();
+}
+
 static void
 install_handler (int signum, SCM thread, SCM handler)
 {

libguile/scmsigs.h

@@ -1,7 +1,7 @@
 #ifndef SCM_SCMSIGS_H
 #define SCM_SCMSIGS_H
 
-/* Copyright 1995-1998,2000,2002,2006-2008,2018
+/* Copyright 1995-1998,2000,2002,2006-2008,2018,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -43,7 +43,9 @@ SCM_INTERNAL void scm_init_scmsigs (void);
 
 SCM_INTERNAL void scm_i_close_signal_pipe (void);
 SCM_INTERNAL void scm_i_ensure_signal_delivery_thread (void);
+SCM_INTERNAL void scm_i_signals_pre_fork (void);
+SCM_INTERNAL void scm_i_signals_post_fork (void);
 
-SCM_INTERNAL scm_thread *scm_i_signal_delivery_thread;
+SCM_INTERNAL SCM scm_i_signal_delivery_thread;
 
 #endif  /* SCM_SCMSIGS_H */

libguile/threads.c

@@ -1681,18 +1681,19 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
 	    "Return a list of all threads.")
 #define FUNC_NAME s_scm_all_threads
 {
-  /* We can not allocate while holding the thread_admin_mutex because
-     of the way GC is done.
-  */
-  int n = thread_count;
   scm_thread *t;
-  SCM list = scm_c_make_list (n, SCM_UNSPECIFIED), *l;
 
   scm_i_pthread_mutex_lock (&thread_admin_mutex);
-  l = &list;
+
+  int n = thread_count;
+  SCM list = scm_c_make_list (n, SCM_UNSPECIFIED);
+  SCM *l = &list;
+
   for (t = all_threads; t && n > 0; t = t->next_thread)
     {
-      if (t != scm_i_signal_delivery_thread)
+      if (!t->exited
+          && (scm_is_false (scm_i_signal_delivery_thread)
+              || (!scm_is_eq (t->handle, scm_i_signal_delivery_thread))))
 	{
 	  SCM_SETCAR (*l, t->handle);
 	  l = SCM_CDRLOC (*l);
@@ -1700,7 +1701,9 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
       n--;
     }
   *l = SCM_EOL;
+
   scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
   return list;
 }
 #undef FUNC_NAME

test-suite/standalone/Makefile.am

@@ -1,7 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-##   2011, 2012, 2013, 2014, 2020, 2021, 2022 Free Software Foundation, Inc.
+## Copyright 2003-2014, 2020-2023 Free Software Foundation, Inc.
 ##
 ## This file is part of GUILE.
 ##
@@ -96,6 +95,9 @@ EXTRA_DIST += test-language.el test-language.js
 check_SCRIPTS += test-guild-compile
 TESTS += test-guild-compile
 
+check_SCRIPTS += test-sigaction-fork
+TESTS += test-sigaction-fork
+
 check_SCRIPTS += test-signal-fork
 TESTS += test-signal-fork
 

test-suite/standalone/test-sigaction-fork

@@ -0,0 +1,85 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+;;; test-sigaction-fork --- Signal thread vs. fork, again.
+;;;
+;;; Copyright (C) 2024 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Test the bug described at <https://bugs.gnu.org/68087>: the signal
+;;; thread would not be restarted after a call to 'primitive-fork',
+;;; leading signals to be silently ignored.
+
+(use-modules (ice-9 match))
+
+(define signals-handled
+  ;; List of signals handled.
+  '())
+
+(define parent
+  ;; PID of the parent process.
+  (getpid))
+
+(unless (provided? 'fork)
+  (exit 77))
+
+;; This call spawns the signal delivery thread as a side effect.
+(sigaction SIGALRM
+  (lambda (signal)
+    (call-with-blocked-asyncs
+     (lambda ()
+       (set! signals-handled
+             (cons `(first-handler . ,(getpid))
+                   signals-handled))))))
+
+(kill (getpid) SIGALRM)
+(while (null? signals-handled)                    ;let the async run
+  (sleep 1))
+
+(match (primitive-fork)
+  (0
+   (pk 'child (getpid) signals-handled)
+   (kill (getpid) SIGALRM)                        ;first handler
+   (sleep 1)                                      ;let the async run
+   (sigaction SIGALRM
+     (lambda (signal)
+       (call-with-blocked-asyncs
+        (lambda ()
+          (set! signals-handled
+                (cons `(second-handler . ,(getpid))
+                      signals-handled))))))
+   (kill (getpid) SIGALRM)           ;second handler
+   (sleep 1)                         ;give asyncs one more chance to run
+   (format (current-error-port) "signals handled by the child + parent: ~s~%"
+           signals-handled)
+   (exit (equal? signals-handled
+                 `((second-handler . ,(getpid))
+                   (first-handler . ,(getpid))
+                   (first-handler . ,parent)))))
+
+  (child
+   (kill (getpid) SIGALRM)           ;first handler
+   (sleep 1)                         ;give asyncs one more chance to run
+   (format (current-error-port) "signals handled by the parent: ~s~%"
+           signals-handled)
+   (exit (and (equal? signals-handled
+                      `((first-handler . ,parent)
+                        (first-handler . ,parent)))
+              (zero? (cdr (waitpid child)))))))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; End: