From 417b6046f8b4f8e847a659ab724ff36e21d73ee1 Mon Sep 17 00:00:00 2001 From: shivers Date: Sun, 9 Mar 1997 07:28:20 +0000 Subject: [PATCH] Early autoreaping now done via SIGCHLD signal handler. Ignored signals were done by putting a noop handler on the signal. This could screw up passing ignores across execs. Now, when you set an S48 interrupt handler to #f, we pass this through to Unix. --- scsh/procobj.scm | 157 ++++++++++++++++++++++++++++--------------- scsh/sighandlers.scm | 20 ++++++ 2 files changed, 123 insertions(+), 54 deletions(-) diff --git a/scsh/procobj.scm b/scsh/procobj.scm index d5b3e8e..1aaa130 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -82,7 +82,7 @@ ;;; (autoreap-policy [new-policy]) -(define *autoreap-policy* 'early) ; Not exported from this module. +(define *autoreap-policy* #f) ; Not exported from this module. (define (autoreap-policy . maybe-policy) (let ((old-policy *autoreap-policy*)) @@ -92,10 +92,12 @@ (error "Too many args to autoreap-policy" maybe-policy)) ((not (memq new-policy '(early #f))) (error "Illegal autoreap policy." new-policy)) - (else (set! *autoreap-policy* new-policy))))) + (else (set! *autoreap-policy* new-policy) + (if (eq? new-policy 'early) + (set-interrupt-handler interrupt/chld + (lambda (enabled-ints) (reap-zombies)))))))) old-policy)) - ;;; (reap-zombies) => bool ;;; Move any zombies from the kernel process table into scsh. ;;; Return true if no more outstanding children; #f if some still live. @@ -105,6 +107,8 @@ (receive (pid status) (%wait-any wait/poll) (if pid (begin (add-reaped-proc! pid status) +; (format (error-output-port) +; "Reaping ~d[~d]~%" pid status) (lp)) status)))) @@ -139,31 +143,47 @@ ;;; If the process hasn't terminated (or suspended, if wait/stopped ;;; is set) and wait/poll is set, return #f. -;;; WAIT waits for a specific process. Currently, if the autoreap policy is -;;; 'early, it also does a (reap-zombies) Before performing a waitpid(2) -;;; systcall, wait first consults the proc object to see if a/the process has +;;; WAIT waits for a specific process. Before performing a waitpid(2) +;;; systcall, wait first consults the proc object to see if the process has ;;; been reaped already. If so, its saved status is returned immediately. ;;; -;;; (wait-any [flags]) => [proc status] -;;; [#f #f] => non-blocking, none ready. -;;; [#f #t] => no more. - -;;; (wait-process-group [pid/proc flags]) => [proc status] -;;; [#f #f] => non-blocking, none ready. -;;; [#f #t] => no more. - (define (wait pid/proc . maybe-flags) - (if (not *autoreap-policy*) (reap-zombies)) - (let ((flags (:optional maybe-flags 0)) - (proc (->proc pid/proc))) - (cond ((proc:%status proc) => ; Already reaped. - (lambda (status) - (mark-proc-waited! proc) ; Not eligible for a WAIT-ANY. - status)) - (else ; Really wait. - (cache-wait-status proc (%wait-pid (proc:pid proc) - flags)))))) + (let* ((flags (:optional maybe-flags 0)) + (proc (->proc pid/proc)) + (win (lambda (status) + (mark-proc-waited! proc) ; Not eligible for a WAIT-ANY + status))) + (let lp () + ;; First, see if we've already waited or reaped the process. + (cond ((proc:%status proc) => win) + + (else ; Really wait. + (receive (err pid status) (%wait-pid/errno (proc:pid proc) flags) + (cond ((not err) + (and (not (zero? pid)) ; pid=0 => none ready. + (win (cache-wait-status proc status)))) + + ((= err errno/intr) (lp)) + + ;; We got an error -- before reporting it, check + ;; the proc record one last time. + ((proc:%status proc) => win) + + (else (errno-error err %wait-pid pid flags))))))))) + +;;; Another way to do it: +;;; Every time we reap a process, we pop out of our SIGCHLD +;;; block so that we can service an interrupt if the system +;;; so wishes. +;(define (wait/pid pid) +; ((let lp () +; (blocking signal/chld +; (or (waited pid) ; Previously waited or reaped +; (receive (next-dead status) (reap-a-pid) +; (if (= pid next-dead) (lambda () status) +; lp))))))) + (define (cache-wait-status proc status) (cond ((and (integer? status) @@ -173,29 +193,51 @@ status) -;;; (wait-any [flags]) -> [proc status] +;;; (wait-any [flags]) => [proc status] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; [#f #f] => non-blocking, none ready. +;;; [#f #t] => no more. (define (wait-any . maybe-flags) - (if (not *autoreap-policy*) (reap-zombies)) - (cond ((get-reaped-proc!) => ; Check internal table. - (lambda (proc) (values proc (proc:%status proc)))) ; Hit. - (else - (receive (pid status) (%wait-any (:optional maybe-flags 0)) ; Wait. - (if pid - (let ((proc (pid->proc pid))) - (cache-wait-status proc status) - (values proc status)) - (values pid status)))))) ; pid = #f -- Empty poll. + (let ((table-hit (lambda (proc) (values proc (proc:%status proc)))) ; Hit. + (flags (:optional maybe-flags 0))) + (cond ((get-reaped-proc!) => table-hit) ; Check internal table. + + (else ; Really wait. + (let lp () + (receive (err pid status) + (%wait-pid/errno -1 flags) + + ;; We got an error of some sort. Check the reaped table + ;; one last time before really deciding there was an error. + (cond (err (cond ((get-reaped-proc!) => table-hit) + ((= err errno/child) (values #f #t)) ; No more. + ((= err errno/intr) (lp)) + (else (errno-error err %wait-any flags)))) + + ;; None ready. Check the reaped-proc table once more + ;; before reporting this. + ((zero? pid) + (cond ((get-reaped-proc!) => table-hit) + (else (values #f #f)))) ; None ready. + + ;; Win. + (else (let ((proc (pid->proc pid))) + (cache-wait-status proc status) + (values proc status)))))))))) -;;; (wait-process-group [proc-group flags]) +;;; (wait-process-group [proc-group flags]) => [proc status] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; [#f #f] => non-blocking, none ready. +;;; [#f #t] => no more. +;;; ;;; ;;; If you are doing process-group waits, you do *not* want to use ;;; early autoreaping, since the reaper loses process-group information. (define (wait-process-group . args) (let-optionals args ((proc-group 0) (flags 0)) - (if (not *autoreap-policy*) (reap-zombies)) (let ((proc-group (cond ((integer? proc-group) proc-group) ((proc? proc-group) (proc:pid proc-group)) (else (error "Illegal argument" wait-process-group @@ -254,34 +296,41 @@ (define reaped-procs '()) ; Reaped, but not yet waited. (define (filter-weak-ptr-list pred lis) - (reverse (reduce (lambda (wptr result) - (let ((val (weak-pointer-ref wptr))) - (if (and val (pred val)) - (cons wptr result) - result))) + (reverse (reduce (lambda (result wptr) + (let ((val (weak-pointer-ref wptr))) + (if (and val (pred val)) + (cons wptr result) + result))) '() lis))) ;;; Add a newly-reaped proc to the list. (define (add-reaped-proc! pid status) - (cond ((maybe-pid->proc pid) => - (lambda (proc) - (set-proc:%status proc status) - (set! reaped-procs (cons (make-weak-pointer proc) - reaped-procs)))) - (else (error "Child pid mysteriously missing proc object." pid)))) + ((with-enabled-interrupts 0 + (cond ((maybe-pid->proc pid) => + (lambda (proc) + (set-proc:%status proc status) + (set! reaped-procs (cons (make-weak-pointer proc) + reaped-procs)) + (lambda () #f))) + (else (lambda () ; Do this w/interrupts enabled. + (error "Child pid mysteriously missing proc object." pid))))))) ;;; Pop one off the list. (define (get-reaped-proc!) - (and (pair? reaped-procs) - (let ((proc (weak-pointer-ref (car reaped-procs)))) - (set! reaped-procs (cdr reaped-procs)) - (or proc (get-reaped-proc!))))) + (with-enabled-interrupts 0 + (let grp! () + (and (pair? reaped-procs) + (let ((proc (weak-pointer-ref (car reaped-procs)))) + (set! reaped-procs (cdr reaped-procs)) + (or proc (grp!))))))) ;;; PROC no longer eligible to be in the list. Delete it. (define (mark-proc-waited! proc) - (set! reaped-procs (filter-weak-ptr-list (lambda (elt) (not (eq? proc elt))) - reaped-procs))) + (with-enabled-interrupts 0 + (set! reaped-procs + (filter-weak-ptr-list (lambda (elt) (not (eq? proc elt))) + reaped-procs)))) ;;; The mark-proc-waited! machinery above is a crock. It is inefficient -- ;;; we should have a flag in the proc saying if it's eligible for a WAIT-ANY. diff --git a/scsh/sighandlers.scm b/scsh/sighandlers.scm index 6dfbb71..8877866 100644 --- a/scsh/sighandlers.scm +++ b/scsh/sighandlers.scm @@ -137,6 +137,16 @@ ((#t) (vector-ref default-int-handler-vec int)) ((#f) noop-sig-handler) (else handler))) + + (cond ((and (not handler) ohandler ; Toggling from something + (int->signal int)) => ; to ignored. + (lambda (sig) + (%set-unix-signal-handler sig 0))) + ((and handler (not ohandler) ; Toggling from ignored + (int->signal int)) => ; to something. + (lambda (sig) + (%set-unix-signal-handler sig 2)))) + ohandler)) (define (interrupt-handler int) @@ -199,3 +209,13 @@ (= sig signal/alrm))) ; alarm handlers alone. (vector-set! interrupt-handlers i (vector-ref default-int-handler-vec i)))))) + +(define int->sig-vec + (let ((v (make-vector 32 #f))) + (do ((sig 32 (- sig 1))) + ((< sig 0)) + (let ((i (%signal->interrupt sig))) + (if (not (= i -1)) (vector-set! v sig i)))) + v)) + +(define (int->signal i) (and (<= 0 i 32) (vector-ref int->sig-vec i)))