scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
scsh/procobj.scm
View File

@ -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

14
scsh/sighandlers.scm
View File

@ -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.

15
scsh/startup.scm
View File

@ -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)

12
scsh/top.scm
View File

@ -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)))))))))))))