diff --git a/scsh/procobj.scm b/scsh/procobj.scm index 880dc15..e4409f6 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -38,7 +38,25 @@ ;; 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)) +(define-record-type auto-init :auto-init + (really-make-auto-init value init-thunk) + (value auto-init-value set-auto-init-value!) + (init-thunk auto-init-init-thunk)) + +(define (make-auto-init init-thunk) + (really-make-auto-init (init-thunk) init-thunk)) + +(define-record-resumer :auto-init + (lambda (record) + (set-auto-init-value! record ((auto-init-init-thunk record))))) + +(define process-table (make-auto-init make-integer-table)) + +(define (process-table-ref n) + (weak-table-ref (auto-init-value process-table) n)) + +(define (process-table-set! n val) + (weak-table-set! (auto-init-value process-table) n val)) (define (weak-table-ref t n) (let ((r (table-ref t n))) @@ -53,18 +71,14 @@ ; (weak-table-set! t n (weak-table-ref t n))) (define (maybe-pid->proc pid) - (weak-table-ref process-table pid)) + (process-table-ref pid)) (define (pid->proc pid . maybe-probe?) (let ((probe? (:optional maybe-probe? #f))) (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) - p)) + ((create) (new-child-proc pid)) (else #f))))) ;;; Coerce pids and procs to procs. @@ -112,8 +126,8 @@ ;;; I'm really tired of opening everything (i.e. events) in scsh-level-0 ;;; this is here until someone (Olin !!!) cleans up the scsh modules -(define wait-interrupt (structure-ref scsh-events wait-interrupt)) -(define most-recent-event (structure-ref scsh-events most-recent-event)) +(define next-sigevent (structure-ref scsh-events next-sigevent)) +(define most-recent-sigevent (structure-ref scsh-events most-recent-sigevent)) (define *autoreap-policy* #f) ; Not exported from this module. @@ -155,8 +169,8 @@ (set! set-post/gc-handler! really-set-post/gc-handler!) (set-post/gc-handler! handler) (spawn (lambda () - (let lp ((event (most-recent-event))) - (let ((next-event (wait-interrupt interrupt/post-gc event))) + (let lp ((event (most-recent-sigevent))) + (let ((next-event (next-sigevent event interrupt/post-gc))) (*post/gc-handler*) (lp next-event)))) '*post/gc-handler*-thread)) @@ -168,14 +182,15 @@ (define (set-sigchld-handler! handler) (set! *sigchld-handler* handler)) -(define (install-autoreaping) +(define (with-autoreaping thunk) (set! *autoreap-policy* 'early) (spawn (lambda () - (let lp ((event (most-recent-event))) - (let ((next-event (wait-interrupt interrupt/chld event))) + (let lp ((event (most-recent-sigevent))) + (let ((next-event (next-sigevent event interrupt/chld))) (*sigchld-handler*) (lp next-event)))) - '*sigchld-handler*-thread)) + '*sigchld-handler*-thread) + (thunk)) ;;; This list contains pids whose proc-obj were gc'd before they died @@ -242,7 +257,7 @@ (define (new-child-proc pid) (let ((proc (make-procobj pid))) - (weak-table-set! process-table pid proc) + (process-table-set! pid proc) proc)) ;;; (WAIT proc/pid [flags]) @@ -262,30 +277,40 @@ ;;; (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 +;;; If it was 'late at 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 +;;; With this lock, we ensure that only one thread may call +;;; really-wait for a given pid + +(define wait-lock (make-lock)) (define (wait pid/proc . maybe-flags) - (let* ((flags (:optional maybe-flags 0)) - (proc (->proc pid/proc)) - (win (lambda (status) - (waited-by-wait proc status) - status))) - (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)))))) + (with-lock + wait-lock + (lambda () + (let* ((flags (:optional maybe-flags 0)) + (proc (->proc pid/proc)) + (win (lambda (status) + (waited-by-wait proc status) + status))) + ;;; save the event before we check for finished + (let ((pre-event (most-recent-sigevent))) + (cond ((proc:finished? proc) + (win (placeholder-value (proc:status proc)))) + + ((zero? (bitwise-and flags wait/poll)) + (release-lock wait-lock) + ; we have to block and hence use the event system + (let lp ((pre-event pre-event)) + (let ((event (next-sigevent pre-event interrupt/chld))) + (cond ((wait proc (bitwise-ior flags wait/poll)) => win) + (else (lp event)))))) + + ((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 @@ -306,7 +331,6 @@ (else (errno-error err %wait-pid pid flags))))) -;;; TODO: These 2 have to be renamed !!! ;;; All you have to do, if pid was reaped ;;; proc_obj is maybe no longer alive diff --git a/scsh/sighandlers.scm b/scsh/sighandlers.scm index 5d2879d..391c0dd 100644 --- a/scsh/sighandlers.scm +++ b/scsh/sighandlers.scm @@ -166,7 +166,7 @@ (define (interrupt-handler int) (interrupt-handler-ref int)) -(define (%install-scsh-handlers interactive?) +(define (with-scsh-sighandlers interactive? thunk) (do ((int 0 (+ int 1))) ((= int number-of-interrupts)) (set-interrupt-handler @@ -197,13 +197,15 @@ (structure-ref threads-internal event-type) interrupt) (enum interrupt keyboard)))))) - (spawn deliver-interrupts 'deliver-interrupts)) + (spawn deliver-interrupts + 'deliver-interrupts) + (thunk)) (define (deliver-interrupts) - (let lp ((last ((structure-ref scsh-events most-recent-event)))) - (let ((event ((structure-ref scsh-events wait-interrupt-set) - full-interrupt-set last))) - (call-interrupt-handler ((structure-ref scsh-events event-type) event)) + (let lp ((last ((structure-ref scsh-events most-recent-sigevent)))) + (let ((event ((structure-ref scsh-events next-sigevent-set) + last full-interrupt-set))) + (call-interrupt-handler ((structure-ref scsh-events sigevent-type) event)) (lp event)))) ;;; I am ashamed to say the 33 below is completely bogus. diff --git a/scsh/startup.scm b/scsh/startup.scm index 3223e65..d770af7 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -44,12 +44,15 @@ (define (dump-scsh-program start filename) (really-dump-scsh-program (lambda (args) - (install-env) - (%install-scsh-handlers #f) - (install-autoreaping) - (init-scsh-vars #f) ; Do it quietly. - (start args)) - filename)) + (with-scsh-sighandlers + #f + (lambda () + (with-autoreaping + (lambda () + (install-env) + (init-scsh-vars #f) ; Do it quietly. + (start args)))))) + filename)) (define (scsh-stand-alone-resumer start) diff --git a/scsh/top.scm b/scsh/top.scm index 053963f..cc41171 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -234,10 +234,12 @@ (with-interaction-environment (user-environment) (lambda () - (begin - (%install-scsh-handlers (not term-switch)) - (install-autoreaping) - (install-env) + (with-scsh-sighandlers + (not term-switch) + (lambda () + (with-autoreaping + (lambda () + (install-env) ;; Have to do these before calling DO-SWITCHES, because actions ;; performed while processing the switches may use these guys. @@ -281,7 +283,7 @@ ;; Otherwise, the script executed as it loaded, ;; so we're done. - (else (exit 0)))))))))) + (else (exit 0)))))))))))))