wait-any should run now. no tests about race-conditions and the code is very ugly at the moment. I wonder if this ever will change
This commit is contained in:
marting
parent
30b32c7ff6
commit
55b3db0c72
246
scsh/procobj.scm
246
scsh/procobj.scm
|
|
@ -19,11 +19,24 @@
|
|||
(zombie #t) ; Misnomer. Whether or not the process has
|
||||
; (not) been waited on.
|
||||
;; Make proc objects print like #{proc 2318}.
|
||||
((disclose p) (list "proc" (proc:pid p))))
|
||||
((disclose p) (list "proc" (proc:pid p) (proc:finished? p))))
|
||||
|
||||
;; Unfortunately there is no way to specify the name of the constructor-
|
||||
;; function in Olins define-record macro, so I had to do this...
|
||||
(define (make-procobj pid)
|
||||
(let ((procobj (make-proc pid)))
|
||||
(add-finalizer! procobj procobj-finalizer)
|
||||
procobj))
|
||||
|
||||
|
||||
;; Weak pointer tables. Much more efficient than populations.
|
||||
;; Maps pids to processes. Unexited processes are strong pointers, exited
|
||||
;; procs are weak pointers (to allow gc'ing).
|
||||
;;
|
||||
;; JMG: whyever unexited processes were strong pointer, this won't work
|
||||
;; 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
|
||||
;; nothing but a deadlock
|
||||
|
||||
(define process-table (make-integer-table))
|
||||
|
||||
|
|
@ -31,13 +44,13 @@
|
|||
(let ((r (table-ref t n)))
|
||||
(if (weak-pointer? r)
|
||||
(weak-pointer-ref r)
|
||||
r)))
|
||||
(error "there was a non-weak-pointer" r))))
|
||||
|
||||
(define (weak-table-set! t n s)
|
||||
(table-set! t n (make-weak-pointer s)))
|
||||
|
||||
(define (weaken-table-ref! t n)
|
||||
(weak-table-set! t n (weak-table-ref t n)))
|
||||
;(define (weaken-table-ref! t n)
|
||||
; (weak-table-set! t n (weak-table-ref t n)))
|
||||
|
||||
(define (maybe-pid->proc pid)
|
||||
(weak-table-ref process-table pid))
|
||||
|
|
@ -47,7 +60,7 @@
|
|||
(or (maybe-pid->proc pid)
|
||||
(case probe?
|
||||
((#f) (error "Pid has no corresponding process object" pid))
|
||||
((create) (let ((p (make-proc 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-table-set! process-table pid p)
|
||||
p))
|
||||
|
|
@ -102,20 +115,85 @@
|
|||
(let ((new-policy (car maybe-policy)))
|
||||
(cond ((pair? (cdr maybe-policy))
|
||||
(error "Too many args to autoreap-policy" maybe-policy))
|
||||
((not (memq new-policy '(early #f)))
|
||||
((not (memq new-policy '(early late #f)))
|
||||
(error "Illegal autoreap policy." new-policy))
|
||||
(else (set! *autoreap-policy* new-policy)
|
||||
(if (eq? new-policy 'early)
|
||||
(set! procobj-handler
|
||||
(lambda (enabled-ints) (reap-zombies))))))))
|
||||
(cond ((eq? new-policy 'early)
|
||||
(sigchld-setter early-sigchld-handler)
|
||||
(post/gc-setter (lambda a (reap-need-reaping))))
|
||||
|
||||
((eq? new-policy 'late)
|
||||
(sigchld-setter late-sigchld-handler)
|
||||
(post/gc-setter (lambda a (reap-need-reaping))))
|
||||
|
||||
(else
|
||||
(sigchld-setter noauto-sigchld-handler)
|
||||
(post/gc-setter
|
||||
(lambda (enabled-ints)
|
||||
(display "won't reap on gc since #f")))))))))
|
||||
old-policy))
|
||||
|
||||
;;; New (scsh 0.6)
|
||||
|
||||
(define sigchld-setter
|
||||
(lambda a (error "procobj setter was not defined")))
|
||||
|
||||
(define (post/gc-setter handler)
|
||||
(set! post/gc-setter
|
||||
(low-interrupt-register interrupt/post-gc
|
||||
handler)))
|
||||
|
||||
|
||||
|
||||
;;; New (scsh 0.6)
|
||||
;;; we register the post/gc-handler not until the first police change
|
||||
(define (install-autoreaping)
|
||||
(set! procobj-handler
|
||||
(lambda (enabled-ints)
|
||||
(reap-zombies))))
|
||||
(let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler)))
|
||||
(set! *autoreap-policy* 'early)
|
||||
(set! sigchld-setter setter)))
|
||||
|
||||
|
||||
|
||||
;;; This list contains pids whose proc-obj were gc'd before they died
|
||||
;;; We try to reap them after every gc and maybe on every SIGCHLD
|
||||
(define need-reaping '())
|
||||
|
||||
(define (need-reaping-add! pid)
|
||||
(set! need-reaping (cons pid need-reaping)))
|
||||
|
||||
(define (need-reaping-remove! pid)
|
||||
(set! need-reaping (del pid need-reaping)))
|
||||
|
||||
(define (reap-need-reaping)
|
||||
(set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping)))
|
||||
|
||||
;;; 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))
|
||||
status))
|
||||
|
||||
;;; Handler for SIGCHLD according policy
|
||||
(define (late-sigchld-handler enabled-ints)
|
||||
(display "late sigchld handler"))
|
||||
|
||||
(define (early-sigchld-handler enabled-ints)
|
||||
(reap-zombies))
|
||||
|
||||
(define (noauto-sigchld-handler enabled-ints)
|
||||
(display "won't on chld reap since #f")
|
||||
#f)
|
||||
|
||||
|
||||
;;; 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")))
|
||||
|
||||
|
||||
;;; (reap-zombies) => bool
|
||||
;;; Move any zombies from the kernel process table into scsh.
|
||||
|
|
@ -125,21 +203,21 @@
|
|||
(display "reap-zombies was called" (current-error-port))
|
||||
(newline)
|
||||
(let lp ()
|
||||
(receive (pid status) (%wait-any (bitwise-ior wait/poll wait/stopped-children))
|
||||
(receive (pid status) (%wait-any (bitwise-ior wait/poll
|
||||
wait/stopped-children))
|
||||
(if pid
|
||||
(begin (add-reaped-proc! pid status)
|
||||
; (format (current-error-port)
|
||||
; "Reaping ~d[~d]~%" pid status)
|
||||
(begin (dead_by_reap pid status)
|
||||
(format (current-error-port)
|
||||
"Reaping ~d[~d]~%" pid status)
|
||||
(lp))
|
||||
status))))
|
||||
|
||||
(define (new-child-proc pid)
|
||||
(let ((proc (make-proc pid)))
|
||||
(table-set! process-table pid proc)
|
||||
proc))
|
||||
|
||||
(define (mark-proc-exited proc)
|
||||
(weaken-table-ref! process-table (proc:pid proc)))
|
||||
|
||||
(define (new-child-proc pid)
|
||||
(let ((proc (make-procobj pid)))
|
||||
(weak-table-set! process-table pid proc)
|
||||
proc))
|
||||
|
||||
;;; (WAIT proc/pid [flags])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -157,17 +235,53 @@
|
|||
;;; is set) and wait/poll is set, return #f.
|
||||
;;; (I'm working on the flags -df)
|
||||
|
||||
;;; JMG: We have to be careful about wait/poll and autoreap-policy:
|
||||
;;; If it was 'late to anytime, we may missed the exit of pid/proc
|
||||
;;; So we cannot just block and hope reap-zombies will give us the status
|
||||
|
||||
|
||||
;;; TODO: add a jetzt-wart-i lock
|
||||
|
||||
(define (wait pid/proc . maybe-flags)
|
||||
;;; I'm really tired of opening everything in scsh-level-0
|
||||
(let ((wait-interrupt (structure-ref events wait-interrupt))
|
||||
(most-recent-event (structure-ref events most-recent-event)))
|
||||
(let* ((flags (:optional maybe-flags 0))
|
||||
(proc (->proc pid/proc))
|
||||
(win (lambda (status)
|
||||
(mark-proc-waited! proc) ; Not eligible for a WAIT-ANY
|
||||
(dead_by_wait proc status)
|
||||
status)))
|
||||
(if (or (zero? (bitwise-and flags wait/poll))
|
||||
(proc:finished? proc))
|
||||
(win (placeholder-value (proc:status proc)))
|
||||
(proc:finished? proc))))
|
||||
(cond ((proc:finished? proc)
|
||||
(win (placeholder-value (proc:status proc))))
|
||||
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
(let lp () ; we have to block and hence use the event system
|
||||
(wait-interrupt interrupt/chld (most-recent-event))
|
||||
(cond ((wait proc (bitwise-ior flags wait/poll)) => win)
|
||||
(else (lp)))))
|
||||
|
||||
((eq? wait/poll (bitwise-and flags wait/poll))
|
||||
(cond ((really-wait (proc:pid proc) flags) => win)
|
||||
(else #f)))))))
|
||||
|
||||
|
||||
;;; This one is used, to wait on a positive pid
|
||||
;;; We NEVER do a blocking wait syscall
|
||||
(define (really-wait pid flags)
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(error "really-wait without wait/poll"))
|
||||
(if (< pid 1)
|
||||
(error "really-wait on nonpos pid" pid))
|
||||
(receive (err return_pid status) (%wait-pid/errno pid flags)
|
||||
(cond ((not err)
|
||||
(cond ((zero? return_pid) #f) ; failed wait/poll
|
||||
((= pid return_pid) status) ; made it
|
||||
(else (error "mismatch in really-wait"
|
||||
return_pid pid))))
|
||||
((= err errno/intr)
|
||||
(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
|
||||
|
|
@ -185,12 +299,32 @@
|
|||
|
||||
;Generally correct idea, tho
|
||||
|
||||
(define (cache-wait-status proc status)
|
||||
(cond ((and (integer? status)
|
||||
(not (status:stop-sig status))) ; He's dead, Jim.
|
||||
(placeholder-set! (proc:status proc) status) ; Cache exit status.
|
||||
(mark-proc-exited proc))) ; We're now gc'able.
|
||||
status)
|
||||
|
||||
;;; 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)
|
||||
(cond ((maybe-pid->proc pid) =>
|
||||
(lambda (proc)
|
||||
(obituary proc status)
|
||||
(push-reaped-proc proc)))
|
||||
(else (warn "reaped pid had no procobj" pid))))
|
||||
|
||||
|
||||
;;; All you have to do, if a wait on proc was successful
|
||||
(define (dead_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))
|
||||
(need-reaping-remove! (proc:pid proc)) ; in case it started during 'late
|
||||
(placeholder-set! (proc:status proc) status)
|
||||
(set-proc:finished? proc #t))
|
||||
|
||||
|
||||
|
||||
;;; (wait-any [flags]) => [proc status]
|
||||
|
|
@ -201,25 +335,46 @@
|
|||
(define (wait-any . maybe-flags)
|
||||
(let ((flags (:optional maybe-flags 0)))
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(let ((win (get-reaped-proc!)))
|
||||
(values win (placeholder-value (proc:status win))))
|
||||
(begin
|
||||
(receive (pid status)
|
||||
;;; before we maybe block via placeholder-value
|
||||
;;; do a really-wait-any for the ones, missed by 'late
|
||||
(really-wait-any (bitwise-ior flags wait/poll))
|
||||
(if (not pid)
|
||||
(let ((win (get-reaped-proc!)))
|
||||
(values win (placeholder-value (proc:status win))))
|
||||
(values pid status))))
|
||||
|
||||
;The rest of this is quite crude and can be safely ignored. -df
|
||||
|
||||
;;; JMG: wait-any is crude and so it's implementation
|
||||
;;; It got even worse, now that we have this fu*$#%g 'late
|
||||
(if (maybe-obtain-lock reaped-proc-pop-lock)
|
||||
(if (eq? reaped-proc-head reaped-proc-tail)
|
||||
;;; due to 'late we cannot be sure, that they all have been
|
||||
;;; reaped
|
||||
(begin
|
||||
(release-lock reaped-proc-pop-lock)
|
||||
(values #f #f))
|
||||
(really-wait-any flags))
|
||||
(let* ((retnode (placeholder-value reaped-proc-head))
|
||||
(retval (weak-pointer-ref (reaped-proc:proc retnode))))
|
||||
(set! reaped-proc-head (reaped-proc:next retnode))
|
||||
(release-lock reaped-proc-pop-lock)
|
||||
(if retval
|
||||
(values retval (placeholder-value (proc:status retval)))
|
||||
(values #f #f))
|
||||
(values #f #f)))))))
|
||||
(values #f #f))))
|
||||
(values #f #f)))))
|
||||
|
||||
(define (really-wait-any flags)
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(error "real-wait-any without wait/poll" flags))
|
||||
(receive (pid status) (%wait-any flags)
|
||||
(if pid
|
||||
(let ((proc (new-child-proc pid)))
|
||||
(dead_by_wait proc status)
|
||||
(values proc status))
|
||||
(values #f #f))))
|
||||
|
||||
|
||||
;;; (wait-process-group [proc-group flags]) => [proc status]
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; [#f #f] => non-blocking, none ready.
|
||||
|
|
@ -239,7 +394,7 @@
|
|||
(receive (pid status) (%wait-process-group proc-group flags)
|
||||
(if pid
|
||||
(let ((proc (pid->proc pid)))
|
||||
(cache-wait-status proc status)
|
||||
(dead_by_wait proc status)
|
||||
(values proc status))
|
||||
(values pid status)))))) ; pid = #f -- Empty poll.
|
||||
|
||||
|
|
@ -336,14 +491,7 @@
|
|||
(release-lock reaped-proc-pop-lock)
|
||||
(weak-pointer-ref (reaped-proc:proc pop-me))))
|
||||
|
||||
(define (add-reaped-proc! pid status)
|
||||
(cond ((maybe-pid->proc pid) =>
|
||||
(lambda (proc)
|
||||
(placeholder-set! (proc:status proc) status)
|
||||
(set-proc:finished? proc #t)
|
||||
(push-reaped-proc proc)
|
||||
(mark-proc-exited proc))
|
||||
(else (warn "Exiting child pid has no proc object." pid status)))))
|
||||
|
||||
|
||||
;;; Pop one off the list.
|
||||
(define (get-reaped-proc!)
|
||||
|
|
|
|||
Loading…
Reference in New Issue