summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2012-10-03 23:59:33 +0200
committerPeter Bex <peter@more-magic.net>2012-10-03 23:59:33 +0200
commit8483bd870ca83ab62f7733e141ca3b4101ea2dbe (patch)
treeeaae8a02e3008a22290e0ca856b135878c911c3b
parent0c5c27fd2d2a4f595ea57e32f6d0cf04376cf919 (diff)
downloadscsh-process-8483bd870ca83ab62f7733e141ca3b4101ea2dbe.tar.gz
Add bookkeeping code for processes so we can get rid of all zombie processes
-rw-r--r--scsh-process.scm116
-rw-r--r--tests/run.scm18
2 files changed, 110 insertions, 24 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
diff --git a/tests/run.scm b/tests/run.scm
index c37a241..ab023eb 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -8,10 +8,11 @@
(test-group "Procedural interface"
(test "Fork/pipe \"hello world\" example from SCSH reference manual"
"Hello, world."
- (begin (fork/pipe
- (lambda ()
- (with-output-to-port (open-output-file* 1)
- (lambda () (display "Hello, world.\n")))))
+ (begin (process-wait
+ (fork/pipe
+ (lambda ()
+ (with-output-to-port (open-output-file* 1)
+ (lambda () (display "Hello, world.\n"))))))
(read-line (open-input-file* 0))))
(test "run/string* returns a string output in a subprocess"
"This is a test"
@@ -119,9 +120,12 @@
#f
(|| (false) (epf (sh -c "echo hi && false") (- 1))))))
-;; TODO: Find a way to test that the input port didn't get replaced by
-;; one from a subshell. This happened before, but not sure how
-;; to detect this except running it manually from the REPL.
+(test-group "finalization"
+ ;; TODO: Find a way to test that the input port didn't get replaced by
+ ;; one from a subshell. This happened before, but not sure how
+ ;; to detect this except running it manually from the REPL.
+ (test-error "No more zombies lying around after we're done"
+ (process-wait)))
(test-end)