summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--scsh-process.scm59
-rw-r--r--tests/run.scm10
2 files changed, 41 insertions, 28 deletions
diff --git a/scsh-process.scm b/scsh-process.scm
index 4e6708d..5bfd7e9 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -221,35 +221,38 @@
(exit 0)))
(define (fork #!optional thunk continue-threads?)
- (dynamic-wind
- ;; If we're really unlucky, sigchld might be delivered
- ;; immediately after forking, but before we added the child's
- ;; pid to the pending processes table. This means we'll lose
- ;; the event and won't mark the process as finished, resulting
- ;; in an endless loop in process-wait. So, mask it.
- (lambda () (signal-mask! signal/chld))
- (lambda ()
- (let* ((maybe-reinstall-deadlock-workaround!
- (lambda ()
- (cond-expand
- (has-thread-killer
- (unless continue-threads? (install-deadlock-workaround!)))
- (else (void)))))
- (thunk (and thunk (lambda ()
- (clear-scsh-pending-processes!)
- (maybe-reinstall-deadlock-workaround!)
- (thunk))))
- (pid (cond-expand
+ (let ((sigchld-was-masked? (signal-masked? signal/chld)))
+ (dynamic-wind
+ ;; If we're really unlucky, sigchld might be delivered
+ ;; immediately after forking, but before we added the child's
+ ;; pid to the pending processes table. This means we'll lose
+ ;; the event and won't mark the process as finished, resulting
+ ;; in an endless loop in process-wait. So, mask it.
+ (lambda ()
+ (unless sigchld-was-masked? (signal-mask! signal/chld)))
+ (lambda ()
+ (let* ((maybe-reinstall-deadlock-workaround!
+ (lambda ()
+ (cond-expand
(has-thread-killer
- (process-fork thunk (not continue-threads?)))
- (else ;; Ignore both args if thunk is #f, so #f won't be applied
- (if thunk (process-fork thunk) (process-fork))))))
- (cond ((zero? pid)
- (clear-scsh-pending-processes!)
- (maybe-reinstall-deadlock-workaround!)
- #f)
- (else (add-scsh-pending-process! pid)))))
- (lambda () (signal-unmask! signal/chld))))
+ (unless continue-threads? (install-deadlock-workaround!)))
+ (else (void)))))
+ (thunk (and thunk (lambda ()
+ (clear-scsh-pending-processes!)
+ (maybe-reinstall-deadlock-workaround!)
+ (thunk))))
+ (pid (cond-expand
+ (has-thread-killer
+ (process-fork thunk (not continue-threads?)))
+ (else ;; Ignore both args if thunk is #f, so #f won't be applied
+ (if thunk (process-fork thunk) (process-fork))))))
+ (cond ((zero? pid)
+ (clear-scsh-pending-processes!)
+ (maybe-reinstall-deadlock-workaround!)
+ #f)
+ (else (add-scsh-pending-process! pid)))))
+ (lambda ()
+ (unless sigchld-was-masked? (signal-unmask! signal/chld))))))
(define %fork fork)
diff --git a/tests/run.scm b/tests/run.scm
index 8e202ac..f4409fd 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -17,6 +17,12 @@
(test "run/string* returns a string output in a subprocess"
"This is a test"
(run/string* (lambda () (display "This is a test"))))
+
+ ;; We must mask sigchld, because otherwise our (wait #f) will fail
+ ;; due to scsh-process' signal handler possibly reaping the child
+ ;; before our wait is able to do so.
+ (signal-mask! signal/chld)
+
(test "wait for next process to exit"
'(#t #t #t)
(let ((p (& (sleep 1))))
@@ -24,6 +30,10 @@
(receive (status2 ok?2 pid2) (wait p)
(list (eq? status status2) (eq? ok? ok?2) (or (eq? pid pid2) (list pid pid2)))))))
+ (test-assert "signal wasn't unmasked" (signal-masked? signal/chld))
+
+ (signal-unmask! signal/chld)
+
;; Reported by Haochi Kiang
(test "run/string* does not redirect stderr"
'("This should go to stdout" "")