diff options
| -rw-r--r-- | scsh-process.scm | 59 | ||||
| -rw-r--r-- | tests/run.scm | 10 |
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" "") |