diff --git a/scsh/procobj.scm b/scsh/procobj.scm index 324c2e2..6725bf0 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -38,25 +38,15 @@ ;; until it wait(2)s and the strong pointer waits for wait(2) which is ;; nothing but a deadlock -(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 (make-integer-table)) +(make-reinitializer (lambda () + (set! process-table (make-integer-table)))) (define (process-table-ref n) - (weak-table-ref (auto-init-value process-table) n)) + (weak-table-ref process-table n)) (define (process-table-set! n val) - (weak-table-set! (auto-init-value process-table) n val)) + (weak-table-set! process-table n val)) (define (maybe-pid->proc pid) (process-table-ref pid)) @@ -74,7 +64,7 @@ (define (->proc proc/pid) (cond ((proc? proc/pid) proc/pid) ((and (integer? proc/pid) (>= proc/pid 0)) - (pid->proc proc/pid)) + (pid->proc proc/pid 'create)) (else (error "Illegal parameter" ->proc proc/pid)))) @@ -205,7 +195,7 @@ ;;; reap this special pid ;;; return status or #f (define (reap-pid pid) - (let ((status (really-wait pid wait/poll))) + (let ((status (atomic-wait pid wait/poll))) (if status (waited-by-reap pid status)) status)) @@ -232,8 +222,8 @@ (define (reap-zombies) (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 (waited-by-reap pid status) ; (format (current-error-port) @@ -275,32 +265,34 @@ (define wait-lock (make-lock)) (define (wait pid/proc . maybe-flags) - (with-lock + (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 ((atomic-wait proc (bitwise-ior flags wait/poll)) => win) + + ((zero? (bitwise-and flags wait/poll)) + ;; we have to block and hence use the event system + (let lp ((pre-event pre-event)) + (cond ((atomic-wait proc (bitwise-ior flags wait/poll)) + => win) + (else + (lp (next-sigevent pre-event interrupt/chld)))))) + (else #f))))) + + +;;; -> process-object proc status/#f +(define (atomic-wait proc flags) + (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)) - (cond ((wait proc (bitwise-ior flags wait/poll)) => win) - (else - (lp (next-sigevent pre-event interrupt/chld)))))) - - ((eq? wait/poll (bitwise-and flags wait/poll)) - (cond ((really-wait (proc:pid proc) flags) => win) - (else #f))))))))) - - + (cond ((proc:finished? proc) + (placeholder-value (proc:status proc))) + (else (really-wait (proc:pid proc) (bitwise-ior flags wait/poll))))))) + ;;; This one is used, to wait on a positive pid ;;; We NEVER do a blocking wait syscall (define (really-wait pid flags) @@ -351,17 +343,17 @@ (if (zero? (bitwise-and flags wait/poll)) (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)))) + ;; 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 its implementation - ;;; It got even worse, now that we have this fu*$#%g 'late + ;; The rest of this is quite crude and can be safely ignored. -df + ;; JMG: wait-any is crude and so its 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 @@ -381,12 +373,13 @@ (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))) - (waited-by-wait proc status) - (values proc status)) - (values #f #f)))) + (receive (pid status) + (%wait-any flags) + (if pid + (let ((proc (new-child-proc pid))) + (waited-by-wait proc status) + (values proc status)) + (values #f #f)))) ;;; (wait-process-group [proc-group flags]) => [proc status] @@ -404,13 +397,28 @@ (let ((proc-group (cond ((integer? proc-group) proc-group) ((proc? proc-group) (proc:pid proc-group)) (else (error "Illegal argument" wait-process-group - proc-group))))) - (receive (pid status) (%wait-process-group proc-group flags) - (if pid - (let ((proc (pid->proc pid))) - (waited-by-wait proc status) - (values proc status)) - (values pid status)))))) ; pid = #f -- Empty poll. + proc-group)))) + (win (lambda (pid status) + (let ((proc (pid->proc pid 'create))) + (if proc (waited-by-wait proc status)) + (values proc status))))) + ;; save the event before we check for finished + (let ((pre-event (most-recent-sigevent))) + (receive (pid status) + (%wait-process-group proc-group (bitwise-ior flags wait/poll)) + (cond (pid + (win pid status)) + ((zero? (bitwise-and flags wait/poll)) + ;; we have to block and hence use the event system + (let lp ((pre-event pre-event)) + (receive (pid status) + (%wait-process-group proc-group (bitwise-ior flags wait/poll)) + (if pid + (win pid status) + (lp (next-sigevent pre-event interrupt/chld)))))) + (else + (values #f status)))))))) + @@ -432,6 +440,8 @@ (values pid status))))) (define (%wait-process-group pgrp flags) + (if (zero? (bitwise-and flags wait/poll)) + (error "really-wait without wait/poll")) (with-errno-handler ((errno packet) ((errno/child)