added locks and renamed dead_by_ to waited-by-
This commit is contained in:
parent
c6860f767f
commit
582d032c53
|
@ -1,4 +1,4 @@
|
|||
;;; Unix wait & process objects for scsh
|
||||
;;; Unix waitt & process objects for scsh
|
||||
;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.
|
||||
|
||||
;;; This is a GC'd abstraction for Unix process id's.
|
||||
|
@ -60,6 +60,7 @@
|
|||
(or (maybe-pid->proc pid)
|
||||
(case probe?
|
||||
((#f) (error "Pid has no corresponding process object" pid))
|
||||
;;; TODO: call new-child-proc here
|
||||
((create) (let ((p (make-procobj pid))) ; Install a new one.
|
||||
;; Weak because we don't know what's up with this thing.
|
||||
(weak-table-set! process-table pid p)
|
||||
|
@ -145,7 +146,7 @@
|
|||
|
||||
|
||||
;;; New (scsh 0.6)
|
||||
;;; we register the post/gc-handler not until the first police change
|
||||
;;; we don't register the post/gc-handler until the first police change
|
||||
(define (install-autoreaping)
|
||||
(let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler)))
|
||||
(set! *autoreap-policy* 'early)
|
||||
|
@ -157,21 +158,29 @@
|
|||
;;; We try to reap them after every gc and maybe on every SIGCHLD
|
||||
(define need-reaping '())
|
||||
|
||||
(define need-reaping-lock (make-lock))
|
||||
|
||||
(define (need-reaping-add! pid)
|
||||
(set! need-reaping (cons pid need-reaping)))
|
||||
(obtain-lock need-reaping-lock)
|
||||
(set! need-reaping (cons pid need-reaping))
|
||||
(release-lock need-reaping-lock))
|
||||
|
||||
(define (need-reaping-remove! pid)
|
||||
(set! need-reaping (del pid need-reaping)))
|
||||
(obtain-lock need-reaping-lock)
|
||||
(set! need-reaping (del pid need-reaping))
|
||||
(release-lock need-reaping-lock))
|
||||
|
||||
(define (reap-need-reaping)
|
||||
(set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping)))
|
||||
(obtain-lock need-reaping-lock)
|
||||
(set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping))
|
||||
(release-lock need-reaping-lock))
|
||||
|
||||
;;; reap this special pid
|
||||
;;; return status or #f
|
||||
(define (reap-pid pid)
|
||||
(let ((status (really-wait pid wait/poll)))
|
||||
(if status
|
||||
(dead_by_reap pid status))
|
||||
(waited-by-reap pid status))
|
||||
status))
|
||||
|
||||
;;; Handler for SIGCHLD according policy
|
||||
|
@ -189,10 +198,8 @@
|
|||
;;; Finalizer for procobjs
|
||||
;;;
|
||||
(define (procobj-finalizer procobj)
|
||||
(display "procobj finalizer called")
|
||||
(if (not (proc:finished? procobj))
|
||||
(need-reaping-add! (proc:pid procobj))
|
||||
(display "but was already finished")))
|
||||
(need-reaping-add! (proc:pid procobj))))
|
||||
|
||||
|
||||
;;; (reap-zombies) => bool
|
||||
|
@ -206,7 +213,7 @@
|
|||
(receive (pid status) (%wait-any (bitwise-ior wait/poll
|
||||
wait/stopped-children))
|
||||
(if pid
|
||||
(begin (dead_by_reap pid status)
|
||||
(begin (waited-by-reap pid status)
|
||||
(format (current-error-port)
|
||||
"Reaping ~d[~d]~%" pid status)
|
||||
(lp))
|
||||
|
@ -249,7 +256,7 @@
|
|||
(let* ((flags (:optional maybe-flags 0))
|
||||
(proc (->proc pid/proc))
|
||||
(win (lambda (status)
|
||||
(dead_by_wait proc status)
|
||||
(waited-by-wait proc status)
|
||||
status)))
|
||||
(cond ((proc:finished? proc)
|
||||
(win (placeholder-value (proc:status proc))))
|
||||
|
@ -282,29 +289,12 @@
|
|||
(really-wait pid flags))
|
||||
(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)))))))
|
||||
|
||||
;The above seems to use Olin's event model. Even so, I'm not
|
||||
;sure that's the best way to do that.
|
||||
|
||||
;Generally correct idea, tho
|
||||
|
||||
|
||||
;;; TODO: These 2 have to be renamed !!!
|
||||
|
||||
;;; All you have to do, if pid was reaped
|
||||
;;; proc_obj is maybe no longer alive
|
||||
(define (dead_by_reap pid status)
|
||||
(define (waited-by-reap pid status)
|
||||
(cond ((maybe-pid->proc pid) =>
|
||||
(lambda (proc)
|
||||
(obituary proc status)
|
||||
|
@ -313,14 +303,14 @@
|
|||
|
||||
|
||||
;;; All you have to do, if a wait on proc was successful
|
||||
(define (dead_by_wait proc status)
|
||||
(define (waited-by-wait proc status)
|
||||
(obituary proc status)
|
||||
(mark-proc-waited! proc))
|
||||
|
||||
;;; we know from somewhere that proc is dead
|
||||
(define (obituary proc status)
|
||||
(if (not (proc? proc))
|
||||
(error "proc was not a proc" proc))
|
||||
(error "obituary: proc was not a procobj" proc))
|
||||
(need-reaping-remove! (proc:pid proc)) ; in case it started during 'late
|
||||
(placeholder-set! (proc:status proc) status)
|
||||
(set-proc:finished? proc #t))
|
||||
|
@ -370,7 +360,7 @@
|
|||
(receive (pid status) (%wait-any flags)
|
||||
(if pid
|
||||
(let ((proc (new-child-proc pid)))
|
||||
(dead_by_wait proc status)
|
||||
(waited-by-wait proc status)
|
||||
(values proc status))
|
||||
(values #f #f))))
|
||||
|
||||
|
@ -394,7 +384,7 @@
|
|||
(receive (pid status) (%wait-process-group proc-group flags)
|
||||
(if pid
|
||||
(let ((proc (pid->proc pid)))
|
||||
(dead_by_wait proc status)
|
||||
(waited-by-wait proc status)
|
||||
(values proc status))
|
||||
(values pid status)))))) ; pid = #f -- Empty poll.
|
||||
|
||||
|
|
Loading…
Reference in New Issue