diff options
Diffstat (limited to 'scsh-process.scm')
| -rw-r--r-- | scsh-process.scm | 58 |
1 files changed, 40 insertions, 18 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index ffff74d..2810baf 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -37,6 +37,10 @@ ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ; OF THE POSSIBILITY OF SUCH DAMAGE. +(declare + ;; Avoid FD leaks due to context switch between create-pipe and fork + (disable-interrupts)) + (module scsh-process (;; procedures exec-path exec-path* fork %fork fork/pipe %fork/pipe fork/pipe+ %fork/pipe+ @@ -50,7 +54,7 @@ (import chicken scheme data-structures) -(use extras utils files ports posix srfi-1 srfi-69) +(use extras utils files ports posix srfi-1 srfi-18 srfi-69) ;;;;;;;;;;;;;;;;;;;;;;;;; ;; Process bookkeeping ;; @@ -64,7 +68,14 @@ ;; process-wait procedure from POSIX, but this allows us to ;; transparently mark off processes which were waited on by the user. -(define-record scsh-process pid exit-status ok?) +(define-record scsh-process pid exit-status ok? child-condition) + +;; 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 proc:pid scsh-process-pid) (define proc? scsh-process?) @@ -78,7 +89,8 @@ (set! *scsh-pending-processes* (make-hash-table))) (define (add-scsh-pending-process! pid) - (let ((process (make-scsh-process pid #f #f))) + (let* ((c (make-condition-variable pid)) + (process (make-scsh-process pid #f #f c))) (hash-table-set! *scsh-pending-processes* pid process) process)) @@ -108,21 +120,29 @@ (values (scsh-process-exit-status p) (scsh-process-ok? p) (scsh-process-pid p)) - (handle-exceptions exn - (if (and p (scsh-process-exit-status p)) ; Signal might've occurred - (values (scsh-process-exit-status p) - (scsh-process-ok? p) - (scsh-process-pid p)) - (abort exn)) - (receive (pid ok? status) - (posix-process-wait (and p (scsh-process-pid p)) nohang) - (cond - ((zero? pid) (values #f #f #f)) - (else (when p - (scsh-process-exit-status-set! p status) - (scsh-process-ok?-set! p ok?)) - (remove-scsh-pending-process! pid) - (values status ok? pid))))))))) + (if (and p (not nohang)) + (let ((m (make-mutex))) + (mutex-unlock! m (scsh-process-child-condition p)) + (values (scsh-process-exit-status p) + (scsh-process-ok? p) + (scsh-process-pid p))) + (handle-exceptions exn + (if (and p (scsh-process-exit-status p)) ; Signal might've occurred + (values (scsh-process-exit-status p) + (scsh-process-ok? p) + (scsh-process-pid p)) + (abort exn)) + (receive (pid ok? status) + (posix-process-wait (and p (scsh-process-pid p)) nohang) + (cond + ((zero? pid) (values #f #f #f)) + (else (when p + (scsh-process-exit-status-set! p status) + (scsh-process-ok?-set! p ok?) + (condition-variable-broadcast! + (scsh-process-child-condition p))) + (remove-scsh-pending-process! pid) + (values status ok? pid)))))))))) (set-signal-handler! signal/chld @@ -145,6 +165,8 @@ (let ((p (hash-table-ref *scsh-pending-processes* pid))) (scsh-process-exit-status-set! p status) (scsh-process-ok?-set! p ok?) + (condition-variable-broadcast! + (scsh-process-child-condition p)) ;; The GC can clean it up (remove-scsh-pending-process! pid)))))) (hash-table-keys *scsh-pending-processes*)) |