diff --git a/libguile/posix.c b/libguile/posix.c index eaf12de32..31c4ab192 100644 --- a/libguile/posix.c +++ b/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); 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 : +;; 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~%")))