diff options
Diffstat (limited to 'scsh-process.scm')
| -rw-r--r-- | scsh-process.scm | 348 |
1 files changed, 163 insertions, 185 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index af3586e..bcc6dbd 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -8,34 +8,31 @@ ;; ;; || wasn't changed, but it's really the zero-length symbol ;; -;; WARNING: Don't mix with threading unless you're using -;; Chicken 4.8.1 rev 47b5be71 or later. +;;; Copyright (c) 2012-2025, Peter Bex +;;; All rights reserved. ;; -;;; Copyright (c) 2012-2021, Peter Bex -;; All rights reserved. -; -; Redistribution and use in source and binary forms, with or without -; modification, are permitted provided that the following conditions -; are met: -; -; 1. Redistributions of source code must retain the above copyright -; notice, this list of conditions and the following disclaimer. -; 2. Redistributions in binary form must reproduce the above copyright -; notice, this list of conditions and the following disclaimer in the -; documentation and/or other materials provided with the distribution. -; -; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED -; OF THE POSSIBILITY OF SUCH DAMAGE. +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;; 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 @@ -50,20 +47,15 @@ run/collecting run/string run/strings run/port run/file run/sexp run/sexps || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string) - process? proc:pid proc? wait signal-process process-sleep) + proc:pid proc? wait signal-process process-sleep) (import scheme) -(cond-expand - (chicken-5 (import (chicken base) (chicken condition) (chicken io) - (chicken port) (chicken file) (chicken file posix) - (chicken fixnum) (chicken string) (chicken process) - (chicken bitwise) (chicken process signal) - srfi-18 llrb-fixnum-table)) - (else (import chicken) - (use data-structures (rename extras (read-file read-list)) - utils files ports posix srfi-1 srfi-18) - (use llrb-fixnum-table))) +(import (chicken base) (chicken condition) (chicken io) + (chicken port) (chicken file) (chicken file posix) + (chicken fixnum) (chicken string) (chicken process) + (chicken bitwise) (chicken process signal) + srfi-18 srfi-69) ;;;;;;;;;;;;;;;;;;;;;;;;; ;; Process bookkeeping ;; @@ -73,15 +65,18 @@ ;; processes without having to wait for all of them in user code. We ;; need to keep a hash table around so that the user can still wait ;; for his own processes without the signal/chld handler interfering -;; with those. It's a bit of hack the way we overwrite the regular -;; 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? 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). +;; with those. +;; Now that process-wait from POSIX directly supports process objects, +;; we use those, but we still install a handler to allow waiting for +;; processes "in the background". This is because that will make this +;; egg (like scsh itself) easier to use as a shell replacement +;; without having to worry about zombie processes. To make that +;; work properly, we keep track of all processes started by this egg +;; in a global table. + +;; A 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). (define (install-deadlock-workaround!) (thread-start! (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) @@ -89,146 +84,135 @@ (install-deadlock-workaround!) ;; And again on fork -(define proc:pid scsh-process-pid) -(define proc? scsh-process?) - -;; Deprecated -(define process? scsh-process?) +(define proc:pid process-id) +(define proc? process?) -(define *scsh-pending-processes* (make-table)) +(define *scsh-pending-processes* (make-hash-table)) (define (clear-scsh-pending-processes!) - (set! *scsh-pending-processes* (make-table))) + (set! *scsh-pending-processes* (make-hash-table))) -(define (add-scsh-pending-process! pid) - (let* ((c (make-condition-variable pid)) - (process (make-scsh-process pid #f #f c))) - (table-update! *scsh-pending-processes* pid (lambda (x) process) (lambda () #f)) +(define (add-scsh-pending-process! process) + (let* ((pid (process-id process)) + (condition (make-condition-variable (conc "process(" pid ")")))) + (hash-table-update! *scsh-pending-processes* pid (lambda (x) (cons process condition)) (lambda () #f)) process)) (define (scsh-pending-process-ref/default pid default) - (table-ref/default *scsh-pending-processes* pid default)) + (hash-table-ref/default *scsh-pending-processes* pid default)) (define (remove-scsh-pending-process! pid) - (table-delete! *scsh-pending-processes* pid)) + (hash-table-delete! *scsh-pending-processes* pid)) (define (scsh-pending-process-fold proc nil) - (table-fold *scsh-pending-processes* proc nil)) + (hash-table-fold *scsh-pending-processes* proc nil)) (define (snapshot-scsh-pending-process) - (let ((copy (table-copy *scsh-pending-processes*))) - (lambda (pid) (table-ref/default copy pid #f)))) + (let ((copy (hash-table-copy *scsh-pending-processes*))) + (lambda (pid) (hash-table-ref/default copy pid #f)))) (define wait #f) -(let ((posix-process-wait process-wait)) - (set! process-wait - (lambda (#!optional pid nohang) - (receive (status ok? pid) (wait pid nohang) (values pid ok? status)))) - - (set! wait - (lambda (#!optional pid-or-process nohang) - (unless (or (not pid-or-process) - (scsh-process? pid-or-process) - (number? pid-or-process)) - (error 'process-wait - "Not a scsh-type process object or pid" - pid-or-process)) - ;; We need to make a copy when waiting for #f, because we - ;; can't predict which pid we'll receive, and the SIGCHLD - ;; handler will drop the pid from the pending list. - (let ((pending-before - (if pid-or-process - #f - (snapshot-scsh-pending-process))) - (p (if (and pid-or-process (number? pid-or-process)) - (scsh-pending-process-ref/default pid-or-process #f) - pid-or-process))) - (if (and p (scsh-process-exit-status 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)) - (let lp () - (receive (pid ok? status) - (posix-process-wait - (if p (scsh-process-pid p) pid-or-process) - ;; When we have p, "nohang" is ignored because - ;; the thread will hang on the condition var - ;; rather than letting the entire process hang. - (if p #t nohang)) - (cond - ((zero? pid) - (if nohang - (values #f #f #f) - (let ((m (make-mutex))) - (mutex-unlock! m (scsh-process-child-condition p)) - (if (not (scsh-process-exit-status p)) - (lp) ; could be forcibly unblocked - (values (scsh-process-exit-status p) - (scsh-process-ok? p) - (scsh-process-pid p)))))) - (else - (and-let* ((p (or p (pending-before pid)))) - (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 - ;; This workaround fixes the "signal-hander" type in the types.db of 4.8.0 - (let-syntax ((workaround - (cond-expand - (chicken-4.8 - (syntax-rules () - ((_ val) (the (or boolean (procedure (fixnum) . *)) val)))) - (else (syntax-rules () ((_ val) val)))))) - (let* ((old-handler (workaround (signal-handler signal/chld))) - (rst #f) ;; restart scan if true - (handler - ;; Run the signal handler in another thread. This is needed - ;; because the current thread may be waiting on a condition - ;; variable, and we can't wake ourselves up. - (thread-start! - (lambda () - (do () (#f) - (set! rst #f) - (scsh-pending-process-fold - (lambda (pid p i) - (and - p - (not (scsh-process-exit-status p)) - (receive (pid ok? status) - (posix-process-wait pid #t) - (if (and (not (zero? pid)) p) - (begin - (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)))))) - #f) - (unless rst (thread-suspend! (current-thread)))))) - )) - (lambda (signal) - (set! rst #t) - (thread-resume! handler) - (when old-handler (old-handler signal))))))) - -(define (signal-process proc sig) - (process-signal (scsh-process-pid proc) sig)) - -(define process-sleep sleep) +(define (wait #!optional pid-or-process nohang) + (unless (or (not pid-or-process) + (process? pid-or-process) + (number? pid-or-process)) + (error 'process-wait + "Not a process object or pid" + pid-or-process)) + ;; We need to make a copy when waiting for #f, because we + ;; can't predict which pid we'll receive, and the SIGCHLD + ;; handler will drop the pid from the pending list. + (let ((pending-before + (if pid-or-process + #f + (snapshot-scsh-pending-process)))) + (handle-exceptions exn + ;; Signal might've occurred, our sigchld handler may have waited already + ;; which would cause an error here. Assume that this means the process + ;; exit information has been populated and that if that is the case, + ;; that is the only error that can occur. + (if (and (process? pid-or-process) + (process-exit-status pid-or-process)) + (values (process-exit-status pid-or-process) + (process-returned-normally? pid-or-process) + (process-id pid-or-process)) + (abort exn)) + (let lp () + (receive (pid ok? status) + (process-wait + pid-or-process + ;; When we have pid-or-process, "nohang" is ignored + ;; because the thread will hang on the condition var + ;; rather than letting the entire process hang. + (if pid-or-process #t nohang)) + (cond + ((zero? pid) + (if nohang + (values #f #f #f) + (let* ((m (make-mutex)) + (proc+condition (and pending-before + (pending-before (if (number? pid-or-process) + pid-or-process + (process-id pid-or-process))))) + (proc (if (process? pid-or-process) + pid-or-process + (car proc+condition)))) + (when proc+condition + (mutex-unlock! m (cdr proc+condition))) + (if (or (number? pid-or-process) + (not (process-exit-status proc))) + (lp) ; could be forcibly unblocked + (begin + (remove-scsh-pending-process! pid) + (values (process-exit-status proc) + (process-returned-normally? proc) + (process-id proc))))))) + (else + (and-let* (pending-before + pid-or-process + (proc+condition (pending-before (if (number? pid-or-process) + pid-or-process + (process-id pid-or-process))))) + (condition-variable-broadcast! + (cdr proc+condition))) + + (remove-scsh-pending-process! pid) + (values status ok? pid)))))))) + +(set-signal-handler! + signal/chld + (let* ((old-handler (signal-handler signal/chld)) + (rst #f) ;; restart scan if true + (handler + ;; Run the signal handler in another thread. This is needed + ;; because the current thread may be waiting on a condition + ;; variable, and we can't wake ourselves up. + (thread-start! + (lambda () + (do () (#f) + (set! rst #f) + (scsh-pending-process-fold + (lambda (pid proc+condition i) + (and + proc+condition + (not (process-exit-status (car proc+condition))) + (not (zero? pid)) + (receive (pid ok? status) + (process-wait (car proc+condition) #t) + (unless (zero? pid) + (condition-variable-broadcast! + (cdr proc+condition)) + (remove-scsh-pending-process! pid))))) + #f) + (unless rst (thread-suspend! (current-thread)))))) + )) + (lambda (signal) + (set! rst #t) + (thread-resume! handler) + (when old-handler (old-handler signal))))) + +(define signal-process process-signal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Execution and forking helpers ;; @@ -271,26 +255,20 @@ (lambda () (let* ((maybe-reinstall-deadlock-workaround! (lambda () - (cond-expand - (has-thread-killer - (unless continue-threads? (install-deadlock-workaround!))) - (else (void))))) + (unless continue-threads? (install-deadlock-workaround!)))) (thunk (and thunk (lambda () (clear-scsh-pending-processes!) (maybe-reinstall-deadlock-workaround!) (unless sigchld-was-masked? (signal-unmask! signal/chld)) (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))))) + (process (process-fork thunk (not continue-threads?)))) + (if process + (add-scsh-pending-process! process) + (begin + (clear-scsh-pending-processes!) + (maybe-reinstall-deadlock-workaround!) + #f)))) (lambda () (unless sigchld-was-masked? (signal-unmask! signal/chld)))))) |