Add bookkeeping code for processes so we can get rid of all zombie processes

1 files changed, 99 insertions, 17 deletions

diff --git a/scsh-process.scm b/scsh-process.scm
index fde9186..d815e6c 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -38,16 +38,99 @@
 
 (module scsh-process
   (;; procedures
-   exec-path fork/pipe %fork/pipe fork/pipe+ %fork/pipe+
+   exec-path fork %fork fork/pipe %fork/pipe fork/pipe+ %fork/pipe+
    run/collecting* run/string* run/strings* run/port* run/file* run/sexp* run/sexps*
 
    ;; macros
    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))
+   || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string)
+
+   process?)
 
 (import chicken scheme data-structures)
 
-(use extras utils files ports posix srfi-1)
+(use extras utils files ports posix srfi-1 srfi-69)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Process bookkeeping ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This stuff is all required so we can more cleanly and simply run
+;; 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?)
+
+(define process? scsh-process?)
+
+(define *scsh-pending-processes* (make-hash-table))
+
+(define (add-scsh-pending-process! pid)
+  (let ((process (make-scsh-process pid #f #f)))
+    (hash-table-set! *scsh-pending-processes* pid process)
+    process))
+
+(define (remove-scsh-pending-process! pid)
+  (hash-table-delete! *scsh-pending-processes* pid))
+
+(let ((posix-process-wait process-wait))
+  (set! process-wait
+        (lambda (#!optional pid-or-process)
+          (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))
+          (let ((p (if (and pid-or-process (number? pid-or-process))
+                       (hash-table-ref/default *scsh-pending-processes*
+                                               pid-or-process #f)
+                       pid-or-process)))
+            (or (and p (scsh-process-exit-status 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)))
+                    (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)))))))))
+
+  (set-signal-handler!
+   signal/chld
+   (let ((old-handler (signal-handler signal/chld)))
+     (lambda (signal)
+       (for-each (lambda (pid)
+                   (handle-exceptions exn
+                     ;; User might have waited manually
+                     (begin (remove-scsh-pending-process! pid) (void))
+                     (receive (pid ok? status)
+                       (posix-process-wait pid #t)
+                       (unless (zero? pid)
+                         (let ((p (hash-table-ref *scsh-pending-processes* pid)))
+                           (scsh-process-exit-status-set! p status)
+                           (scsh-process-ok?-set! p ok?)
+                           ;; The GC can clean it up
+                           (remove-scsh-pending-process! pid))))))
+                 (hash-table-keys *scsh-pending-processes*))
+       (when old-handler (old-handler signal))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Execution and forking helpers ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; TODO: Perhaps expose environment, and mess around with the path so that
 ;; execve can be used in a sensible way?  Scsh has its own PATH, so we could
@@ -70,13 +153,19 @@
     (thunk)
     (exit 0)))
 
+(define (fork #!optional thunk)
+  (let ((pid (if thunk (process-fork thunk) (process-fork))))
+    (and (not (zero? pid)) (add-scsh-pending-process! pid))))
+
+(define %fork fork)
+
 (define (fork/pipe+ conns #!optional thunk)
   ;; Blergh, this is silly overhead we don't really need
   (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns))
          (to-fds (map last conns))
          (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds))
-         (pid (process-fork)))
-    (if (zero? pid)                     ; Child
+         (proc (fork)))
+    (if (not proc)                      ; Child
         (begin
           (for-each (lambda (p from-fds-for-this-p)
                       ;; Close receiving ends of pipes in child.
@@ -98,7 +187,7 @@
                       ;; No longer needed after duplication.
                       (file-close (car p)))
                     pipe-pairs to-fds)
-          pid))))
+          proc))))
 
 ;; TODO: Differentiate between fork and %fork
 (define %fork/pipe fork/pipe)
@@ -124,14 +213,14 @@
          (conns (map (lambda (from-fd temp-file)
                        (list from-fd (port->fileno temp-file)))
                      fds temp-files)))
-    (receive (p s code)
+    (receive (code ok? pid)
       (process-wait (fork/pipe+ conns thunk))
       (apply values code temp-files))))
 
 (define (run/port* thunk)
   (receive (in out)
     (create-pipe)
-    (process-fork
+    (fork
      (lambda ()
        (run-final-thunk
         (lambda ()
@@ -204,18 +293,11 @@
 (define-syntax &
   (syntax-rules ()
     ((_ ?epf ...)
-     (process-fork (lambda ()
-                     (run-final-thunk (lambda () (exec-epf ?epf ...))))))))
+     (fork (lambda () (run-final-thunk (lambda () (exec-epf ?epf ...))))))))
 
 (define-syntax run
   (syntax-rules ()
-    ((_ ?epf ...)
-     ;; We reorder the values as they make more sense this way for SCSH compat:
-     ;; scsh returns just the exit code, and conveniently we allow MV in single
-     ;; value continuations, which makes it compatible.
-     (receive (pid normal-exit? exit-status)
-       (process-wait (& ?epf ...))
-       (values exit-status normal-exit? pid)))))
+    ((_ ?epf ...) (process-wait (& ?epf ...)))))
 
 ;; Perhaps this should really be a procedure?
 (define-syntax setup-redirection