'primitive-fork' closes and recreates the current thread's 'sleep_pipe'.

Partly fixes <https://bugs.gnu.org/41948>.

Previously, the child process could end up using the same 'sleep_pipe'
as its parent, leading to a race condition handling signals.

* libguile/posix.c (do_fork): New function.
(scm_fork): Call 'do_fork' via 'scm_without_guile'.
* test-suite/standalone/test-signal-fork: New test.
* test-suite/standalone/Makefile.am (check_SCRIPTS, TESTS): Add it.

libguile/posix.c

@@ -1217,6 +1217,31 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
 #undef FUNC_NAME
 
 #ifdef HAVE_FORK
+
+/* Create a process and perform post-fork cleanups in the child.  */
+static void *
+do_fork (void *ret)
+{
+  pid_t pid = fork ();
+
+  if (pid == 0)
+    {
+      /* The child process must not share its sleep pipe with the
+         parent.  Close it and create a new one.  */
+      int err;
+      scm_thread *t = SCM_I_CURRENT_THREAD;
+
+      close (t->sleep_pipe[0]);
+      close (t->sleep_pipe[1]);
+      err = pipe2 (t->sleep_pipe, O_CLOEXEC);
+      if (err != 0)
+        abort ();
+    }
+
+  * (pid_t *) ret = pid;
+  return NULL;
+}
+
 SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
             (),
 	    "Creates a new \"child\" process by duplicating the current \"parent\" process.\n"
@@ -1244,7 +1269,9 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
         "         further behavior unspecified.  See \"Processes\" in the\n"
         "         manual, for more information.\n"),
        scm_current_warning_port ());
-  pid = fork ();
+
+  scm_without_guile (do_fork, &pid);
+
   if (pid == -1)
     SCM_SYSERROR;
   return scm_from_int (pid);

test-suite/standalone/Makefile.am

@@ -96,6 +96,9 @@ EXTRA_DIST += test-language.el test-language.js
 check_SCRIPTS += test-guild-compile
 TESTS += test-guild-compile
 
+check_SCRIPTS += test-signal-fork
+TESTS += test-signal-fork
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}

test-suite/standalone/test-signal-fork

@@ -0,0 +1,63 @@
+#!/bin/sh
+guild compile "$0"
+exec guile -q -s "$0" "$@"
+!#
+;;; test-signal-fork --- Signal thread vs. fork.     -*- Scheme -*-
+;;;
+;;; Copyright (C) 2021 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 for one of the bugs described at <https://bugs.gnu.org/41948>:
+;; when forking a Guile process that has its signal thread up and
+;; running, the 'sleep_pipe' of the main thread would end up being
+;; shared between the child and parent processes, leading to a race
+;; condition.  This test checks for the presence of that race condition.
+
+(use-modules (ice-9 match))
+
+(setvbuf (current-output-port) 'none)
+(sigaction SIGCHLD pk)                            ;start signal thread
+
+(match (primitive-fork)
+  (0
+   (format #t "child: ~a~%" (getpid))
+   (unless (zero? (sleep 5))
+     ;; If this happens, it means the select(2) call in 'scm_std_select'
+     ;; returned because one of our file descriptors had input data
+     ;; available (which shouldn't happen).
+     (format #t "child woken up!~%")
+
+     ;; Terminate the parent so the test fails.
+     (kill (getppid) SIGKILL)
+     (primitive-exit 1)))
+  (pid
+   (format #t "parent: ~a~%" (getpid))
+   (sigaction SIGALRM (lambda _
+                        (display ".")))
+
+   ;; Repeatedly send signals to self.  Previously, the thread's
+   ;; 'sleep_pipe' would wrongfully be shared between the parent and the
+   ;; child, leading to a race condition: the child could end up reading
+   ;; from the pipe in lieu of the parent.
+   (let loop ((i 50))
+     (kill (getpid) SIGALRM)
+     (usleep 50000)
+     (unless (zero? i)
+       (loop (1- i))))
+
+   ;; Terminate the child.
+   (false-if-exception (kill pid SIGKILL))
+   (format #t "~%completed~%")))