From 86310f955b1eb393a605a18ff9d734823c2b29df Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 3 Jun 2017 15:11:22 +0200 Subject: Reinstall deadlock workaround thread when forking with thread killing --- scsh-process.scm | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/scsh-process.scm b/scsh-process.scm index 0676681..a5d3df6 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -73,9 +73,12 @@ ;; Aaaand another hack to avoid getting "deadlock detected" when all ;; threads are waiting for a child condition. We can still get woken ;; up by the signal/chld handler (see below). -(thread-start! - (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) - 'work-around-broken-deadlock-detection)) +(define (install-deadlock-workaround!) + (thread-start! + (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) + 'work-around-broken-deadlock-detection))) + +(install-deadlock-workaround!) ;; And again on fork (define proc:pid scsh-process-pid) (define proc? scsh-process?) @@ -208,8 +211,15 @@ (exit 0))) (define (fork #!optional thunk continue-threads?) - (let* ((thunk (and thunk (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 (has-thread-killer @@ -218,6 +228,7 @@ (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))))) -- cgit v1.2.3