'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.

2 files changed, 66 insertions, 0 deletions

diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 0676d2691..e87100c96 100644
--- a/test-suite/standalone/Makefile.am
+++ b/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}
diff --git a/test-suite/standalone/test-signal-fork b/test-suite/standalone/test-signal-fork
new file mode 100755
index 000000000..815118176
--- /dev/null
+++ b/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~%")))