mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
130463be2a
MinGW is missing fork. * test-suite/standalone/test-close-on-exec: modified * test-suite/standalone/test-signal-fork: modified
66 lines
2.4 KiB
Scheme
Executable file
66 lines
2.4 KiB
Scheme
Executable file
#!/bin/sh
|
|
guild compile "$0"
|
|
exec guile -q -s "$0" "$@"
|
|
!#
|
|
;;; test-signal-fork --- Signal thread vs. fork. -*- Scheme -*-
|
|
;;;
|
|
;;; Copyright (C) 2021, 2022 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))
|
|
|
|
(unless (provided? 'fork)
|
|
(exit 77))
|
|
|
|
(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~%")))
|