Added with-autoreaping and with-scsh-sighandlers.

Added auto-init for process-objects to flush the process table on startup.
This commit is contained in:
mainzelm 2001-04-09 08:05:58 +00:00
parent 5500490a1d
commit a95c531327
4 changed files with 84 additions and 53 deletions

View File

@ -38,7 +38,25 @@
;; 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
(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) (define (weak-table-ref t n)
(let ((r (table-ref t n))) (let ((r (table-ref t n)))
@ -53,18 +71,14 @@
; (weak-table-set! t n (weak-table-ref t n))) ; (weak-table-set! t n (weak-table-ref t n)))
(define (maybe-pid->proc pid) (define (maybe-pid->proc pid)
(weak-table-ref process-table pid)) (process-table-ref pid))
(define (pid->proc pid . maybe-probe?) (define (pid->proc pid . maybe-probe?)
(let ((probe? (:optional maybe-probe? #f))) (let ((probe? (:optional maybe-probe? #f)))
(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) (new-child-proc pid))
((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))
(else #f))))) (else #f)))))
;;; Coerce pids and procs to procs. ;;; Coerce pids and procs to procs.
@ -112,8 +126,8 @@
;;; I'm really tired of opening everything (i.e. events) in scsh-level-0 ;;; 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 ;;; this is here until someone (Olin !!!) cleans up the scsh modules
(define wait-interrupt (structure-ref scsh-events wait-interrupt)) (define next-sigevent (structure-ref scsh-events next-sigevent))
(define most-recent-event (structure-ref scsh-events most-recent-event)) (define most-recent-sigevent (structure-ref scsh-events most-recent-sigevent))
(define *autoreap-policy* #f) ; Not exported from this module. (define *autoreap-policy* #f) ; Not exported from this module.
@ -155,8 +169,8 @@
(set! set-post/gc-handler! really-set-post/gc-handler!) (set! set-post/gc-handler! really-set-post/gc-handler!)
(set-post/gc-handler! handler) (set-post/gc-handler! handler)
(spawn (lambda () (spawn (lambda ()
(let lp ((event (most-recent-event))) (let lp ((event (most-recent-sigevent)))
(let ((next-event (wait-interrupt interrupt/post-gc event))) (let ((next-event (next-sigevent event interrupt/post-gc)))
(*post/gc-handler*) (*post/gc-handler*)
(lp next-event)))) (lp next-event))))
'*post/gc-handler*-thread)) '*post/gc-handler*-thread))
@ -168,14 +182,15 @@
(define (set-sigchld-handler! handler) (define (set-sigchld-handler! handler)
(set! *sigchld-handler* handler)) (set! *sigchld-handler* handler))
(define (install-autoreaping) (define (with-autoreaping thunk)
(set! *autoreap-policy* 'early) (set! *autoreap-policy* 'early)
(spawn (lambda () (spawn (lambda ()
(let lp ((event (most-recent-event))) (let lp ((event (most-recent-sigevent)))
(let ((next-event (wait-interrupt interrupt/chld event))) (let ((next-event (next-sigevent event interrupt/chld)))
(*sigchld-handler*) (*sigchld-handler*)
(lp next-event)))) (lp next-event))))
'*sigchld-handler*-thread)) '*sigchld-handler*-thread)
(thunk))
;;; This list contains pids whose proc-obj were gc'd before they died ;;; This list contains pids whose proc-obj were gc'd before they died
@ -242,7 +257,7 @@
(define (new-child-proc pid) (define (new-child-proc pid)
(let ((proc (make-procobj pid))) (let ((proc (make-procobj pid)))
(weak-table-set! process-table pid proc) (process-table-set! pid proc)
proc)) proc))
;;; (WAIT proc/pid [flags]) ;;; (WAIT proc/pid [flags])
@ -262,30 +277,40 @@
;;; (I'm working on the flags -df) ;;; (I'm working on the flags -df)
;;; JMG: We have to be careful about wait/poll and autoreap-policy: ;;; 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 ;;; 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) (define (wait pid/proc . maybe-flags)
(with-lock
wait-lock
(lambda ()
(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)
(waited-by-wait proc status) (waited-by-wait proc status)
status))) status)))
;;; save the event before we check for finished
(let ((pre-event (most-recent-sigevent)))
(cond ((proc:finished? proc) (cond ((proc:finished? proc)
(win (placeholder-value (proc:status proc)))) (win (placeholder-value (proc:status proc))))
((zero? (bitwise-and flags wait/poll)) ((zero? (bitwise-and flags wait/poll))
(let lp () ; we have to block and hence use the event system (release-lock wait-lock)
(wait-interrupt interrupt/chld (most-recent-event)) ; 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) (cond ((wait proc (bitwise-ior flags wait/poll)) => win)
(else (lp))))) (else (lp event))))))
((eq? wait/poll (bitwise-and flags wait/poll)) ((eq? wait/poll (bitwise-and flags wait/poll))
(cond ((really-wait (proc:pid proc) flags) => win) (cond ((really-wait (proc:pid proc) flags) => win)
(else #f)))))) (else #f)))))))))
;;; This one is used, to wait on a positive pid ;;; This one is used, to wait on a positive pid
@ -306,7 +331,6 @@
(else (errno-error err %wait-pid pid flags))))) (else (errno-error err %wait-pid pid flags)))))
;;; 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

View File

@ -166,7 +166,7 @@
(define (interrupt-handler int) (define (interrupt-handler int)
(interrupt-handler-ref int)) (interrupt-handler-ref int))
(define (%install-scsh-handlers interactive?) (define (with-scsh-sighandlers interactive? thunk)
(do ((int 0 (+ int 1))) (do ((int 0 (+ int 1)))
((= int number-of-interrupts)) ((= int number-of-interrupts))
(set-interrupt-handler (set-interrupt-handler
@ -197,13 +197,15 @@
(structure-ref threads-internal event-type) (structure-ref threads-internal event-type)
interrupt) interrupt)
(enum interrupt keyboard)))))) (enum interrupt keyboard))))))
(spawn deliver-interrupts 'deliver-interrupts)) (spawn deliver-interrupts
'deliver-interrupts)
(thunk))
(define (deliver-interrupts) (define (deliver-interrupts)
(let lp ((last ((structure-ref scsh-events most-recent-event)))) (let lp ((last ((structure-ref scsh-events most-recent-sigevent))))
(let ((event ((structure-ref scsh-events wait-interrupt-set) (let ((event ((structure-ref scsh-events next-sigevent-set)
full-interrupt-set last))) last full-interrupt-set)))
(call-interrupt-handler ((structure-ref scsh-events event-type) event)) (call-interrupt-handler ((structure-ref scsh-events sigevent-type) event))
(lp event)))) (lp event))))
;;; I am ashamed to say the 33 below is completely bogus. ;;; I am ashamed to say the 33 below is completely bogus.

View File

@ -44,11 +44,14 @@
(define (dump-scsh-program start filename) (define (dump-scsh-program start filename)
(really-dump-scsh-program (lambda (args) (really-dump-scsh-program (lambda (args)
(with-scsh-sighandlers
#f
(lambda ()
(with-autoreaping
(lambda ()
(install-env) (install-env)
(%install-scsh-handlers #f)
(install-autoreaping)
(init-scsh-vars #f) ; Do it quietly. (init-scsh-vars #f) ; Do it quietly.
(start args)) (start args))))))
filename)) filename))

View File

@ -234,9 +234,11 @@
(with-interaction-environment (with-interaction-environment
(user-environment) (user-environment)
(lambda () (lambda ()
(begin (with-scsh-sighandlers
(%install-scsh-handlers (not term-switch)) (not term-switch)
(install-autoreaping) (lambda ()
(with-autoreaping
(lambda ()
(install-env) (install-env)
;; Have to do these before calling DO-SWITCHES, because actions ;; Have to do these before calling DO-SWITCHES, because actions
@ -281,7 +283,7 @@
;; Otherwise, the script executed as it loaded, ;; Otherwise, the script executed as it loaded,
;; so we're done. ;; so we're done.
(else (exit 0)))))))))) (else (exit 0)))))))))))))