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.
This commit is contained in:
shivers
parent
8d6805a733
commit
417b6046f8
157
scsh/procobj.scm
157
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.
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue