From 55b3db0c721d7f2bcee6241d024d74a06ce8ddc6 Mon Sep 17 00:00:00 2001 From: marting Date: Mon, 18 Oct 1999 23:32:01 +0000 Subject: [PATCH] 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 --- scsh/procobj.scm | 246 +++++++++++++++++++++++++++++++++++++---------- 1 file changed, 197 insertions(+), 49 deletions(-) diff --git a/scsh/procobj.scm b/scsh/procobj.scm index 46eadb2..7afc9b1 100644 --- a/scsh/procobj.scm +++ b/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!)