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.
|
;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.
|
||||||
|
|
||||||
;;; This is a GC'd abstraction for Unix process id's.
|
;;; This is a GC'd abstraction for Unix process id's.
|
||||||
|
@ -33,7 +33,7 @@
|
||||||
;; Maps pids to processes. Unexited processes are strong pointers, exited
|
;; Maps pids to processes. Unexited processes are strong pointers, exited
|
||||||
;; procs are weak pointers (to allow gc'ing).
|
;; procs are weak pointers (to allow gc'ing).
|
||||||
;;
|
;;
|
||||||
;; JMG: whyever unexited processes were strong pointer, this won't work
|
;; JMG: why ever unexited processes were strong pointer, this won't work
|
||||||
;; with (autoreap-policy 'late), since then gc waits for the strong pointer
|
;; with (autoreap-policy 'late), since then gc waits for the strong pointer
|
||||||
;; until it wait(2)s and the strong pointer waits for wait(2) which is
|
;; until it wait(2)s and the strong pointer waits for wait(2) which is
|
||||||
;; nothing but a deadlock
|
;; nothing but a deadlock
|
||||||
|
@ -60,6 +60,7 @@
|
||||||
(or (maybe-pid->proc pid)
|
(or (maybe-pid->proc pid)
|
||||||
(case probe?
|
(case probe?
|
||||||
((#f) (error "Pid has no corresponding process object" pid))
|
((#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.
|
((create) (let ((p (make-procobj pid))) ; Install a new one.
|
||||||
;; Weak because we don't know what's up with this thing.
|
;; Weak because we don't know what's up with this thing.
|
||||||
(weak-table-set! process-table pid p)
|
(weak-table-set! process-table pid p)
|
||||||
|
@ -145,7 +146,7 @@
|
||||||
|
|
||||||
|
|
||||||
;;; New (scsh 0.6)
|
;;; 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)
|
(define (install-autoreaping)
|
||||||
(let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler)))
|
(let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler)))
|
||||||
(set! *autoreap-policy* 'early)
|
(set! *autoreap-policy* 'early)
|
||||||
|
@ -157,21 +158,29 @@
|
||||||
;;; We try to reap them after every gc and maybe on every SIGCHLD
|
;;; We try to reap them after every gc and maybe on every SIGCHLD
|
||||||
(define need-reaping '())
|
(define need-reaping '())
|
||||||
|
|
||||||
|
(define need-reaping-lock (make-lock))
|
||||||
|
|
||||||
(define (need-reaping-add! pid)
|
(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)
|
(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)
|
(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
|
;;; reap this special pid
|
||||||
;;; return status or #f
|
;;; return status or #f
|
||||||
(define (reap-pid pid)
|
(define (reap-pid pid)
|
||||||
(let ((status (really-wait pid wait/poll)))
|
(let ((status (really-wait pid wait/poll)))
|
||||||
(if status
|
(if status
|
||||||
(dead_by_reap pid status))
|
(waited-by-reap pid status))
|
||||||
status))
|
status))
|
||||||
|
|
||||||
;;; Handler for SIGCHLD according policy
|
;;; Handler for SIGCHLD according policy
|
||||||
|
@ -189,10 +198,8 @@
|
||||||
;;; Finalizer for procobjs
|
;;; Finalizer for procobjs
|
||||||
;;;
|
;;;
|
||||||
(define (procobj-finalizer procobj)
|
(define (procobj-finalizer procobj)
|
||||||
(display "procobj finalizer called")
|
|
||||||
(if (not (proc:finished? procobj))
|
(if (not (proc:finished? procobj))
|
||||||
(need-reaping-add! (proc:pid procobj))
|
(need-reaping-add! (proc:pid procobj))))
|
||||||
(display "but was already finished")))
|
|
||||||
|
|
||||||
|
|
||||||
;;; (reap-zombies) => bool
|
;;; (reap-zombies) => bool
|
||||||
|
@ -206,7 +213,7 @@
|
||||||
(receive (pid status) (%wait-any (bitwise-ior wait/poll
|
(receive (pid status) (%wait-any (bitwise-ior wait/poll
|
||||||
wait/stopped-children))
|
wait/stopped-children))
|
||||||
(if pid
|
(if pid
|
||||||
(begin (dead_by_reap pid status)
|
(begin (waited-by-reap pid status)
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
"Reaping ~d[~d]~%" pid status)
|
"Reaping ~d[~d]~%" pid status)
|
||||||
(lp))
|
(lp))
|
||||||
|
@ -249,7 +256,7 @@
|
||||||
(let* ((flags (:optional maybe-flags 0))
|
(let* ((flags (:optional maybe-flags 0))
|
||||||
(proc (->proc pid/proc))
|
(proc (->proc pid/proc))
|
||||||
(win (lambda (status)
|
(win (lambda (status)
|
||||||
(dead_by_wait proc status)
|
(waited-by-wait proc status)
|
||||||
status)))
|
status)))
|
||||||
(cond ((proc:finished? proc)
|
(cond ((proc:finished? proc)
|
||||||
(win (placeholder-value (proc:status proc))))
|
(win (placeholder-value (proc:status proc))))
|
||||||
|
@ -282,29 +289,12 @@
|
||||||
(really-wait pid flags))
|
(really-wait pid flags))
|
||||||
(else (errno-error err %wait-pid 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 !!!
|
;;; TODO: These 2 have to be renamed !!!
|
||||||
|
|
||||||
;;; All you have to do, if pid was reaped
|
;;; All you have to do, if pid was reaped
|
||||||
;;; proc_obj is maybe no longer alive
|
;;; proc_obj is maybe no longer alive
|
||||||
(define (dead_by_reap pid status)
|
(define (waited-by-reap pid status)
|
||||||
(cond ((maybe-pid->proc pid) =>
|
(cond ((maybe-pid->proc pid) =>
|
||||||
(lambda (proc)
|
(lambda (proc)
|
||||||
(obituary proc status)
|
(obituary proc status)
|
||||||
|
@ -313,14 +303,14 @@
|
||||||
|
|
||||||
|
|
||||||
;;; All you have to do, if a wait on proc was successful
|
;;; 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)
|
(obituary proc status)
|
||||||
(mark-proc-waited! proc))
|
(mark-proc-waited! proc))
|
||||||
|
|
||||||
;;; we know from somewhere that proc is dead
|
;;; we know from somewhere that proc is dead
|
||||||
(define (obituary proc status)
|
(define (obituary proc status)
|
||||||
(if (not (proc? proc))
|
(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
|
(need-reaping-remove! (proc:pid proc)) ; in case it started during 'late
|
||||||
(placeholder-set! (proc:status proc) status)
|
(placeholder-set! (proc:status proc) status)
|
||||||
(set-proc:finished? proc #t))
|
(set-proc:finished? proc #t))
|
||||||
|
@ -370,7 +360,7 @@
|
||||||
(receive (pid status) (%wait-any flags)
|
(receive (pid status) (%wait-any flags)
|
||||||
(if pid
|
(if pid
|
||||||
(let ((proc (new-child-proc pid)))
|
(let ((proc (new-child-proc pid)))
|
||||||
(dead_by_wait proc status)
|
(waited-by-wait proc status)
|
||||||
(values proc status))
|
(values proc status))
|
||||||
(values #f #f))))
|
(values #f #f))))
|
||||||
|
|
||||||
|
@ -394,7 +384,7 @@
|
||||||
(receive (pid status) (%wait-process-group proc-group flags)
|
(receive (pid status) (%wait-process-group proc-group flags)
|
||||||
(if pid
|
(if pid
|
||||||
(let ((proc (pid->proc pid)))
|
(let ((proc (pid->proc pid)))
|
||||||
(dead_by_wait proc status)
|
(waited-by-wait proc status)
|
||||||
(values proc status))
|
(values proc status))
|
||||||
(values pid status)))))) ; pid = #f -- Empty poll.
|
(values pid status)))))) ; pid = #f -- Empty poll.
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue