put process objects on top of event system

This commit is contained in:
mainzelm 2000-12-21 21:57:37 +00:00
parent 3a8546df55
commit 55d806358f
1 changed files with 56 additions and 38 deletions

View File

@ -108,6 +108,14 @@
;;; (autoreap-policy [new-policy]) ;;; (autoreap-policy [new-policy])
;;; Watch this area ;;; Watch this area
;;; 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 events wait-interrupt))
(define most-recent-event (structure-ref events most-recent-event))
(define *autoreap-policy* #f) ; Not exported from this module. (define *autoreap-policy* #f) ; Not exported from this module.
(define (autoreap-policy . maybe-policy) (define (autoreap-policy . maybe-policy)
@ -120,38 +128,54 @@
(error "Illegal autoreap policy." new-policy)) (error "Illegal autoreap policy." new-policy))
(else (set! *autoreap-policy* new-policy) (else (set! *autoreap-policy* new-policy)
(cond ((eq? new-policy 'early) (cond ((eq? new-policy 'early)
(sigchld-setter early-sigchld-handler) (set-sigchld-handler! early-sigchld-handler)
(post/gc-setter (lambda a (reap-need-reaping)))) (set-post/gc-handler! reap-need-reaping))
((eq? new-policy 'late) ((eq? new-policy 'late)
(sigchld-setter late-sigchld-handler) (set-sigchld-handler! late-sigchld-handler)
(post/gc-setter (lambda a (reap-need-reaping)))) (set-post/gc-handler! reap-need-reaping))
(else (else
(sigchld-setter noauto-sigchld-handler) (set-sigchld-handler! noauto-sigchld-handler)
(post/gc-setter (set-post/gc-handler!
(lambda (enabled-ints) (lambda ()
(display "won't reap on gc since #f"))))))))) #f))))))))
old-policy)) old-policy))
(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 don't register the post/gc-handler until the first police change ;;; we don't register the post/gc-handler until the first police change
(define (install-autoreaping) ;;; --- this made sense, but why?
(let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler))) (define *post/gc-handler*
(set! *autoreap-policy* 'early) (lambda () (error "*post/gc-handler* was not defined")))
(set! sigchld-setter setter)))
(define (really-set-post/gc-handler! handler)
(set! *post/gc-handler* handler))
(define (start-set-post/gc-handler! handler)
(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)))
(*post/gc-handler*)
(lp next-event))))
'*post/gc-handler*-thread))
(define set-post/gc-handler! start-set-post/gc-handler!)
(define (*sigchld-handler*) (early-sigchld-handler))
(define (set-sigchld-handler! handler)
(set! *sigchld-handler* handler))
(define (install-autoreaping)
(set! *autoreap-policy* 'early)
(spawn (lambda ()
(let lp ((event (most-recent-event)))
(let ((next-event (wait-interrupt interrupt/chld event)))
(*sigchld-handler*)
(lp next-event))))
'*sigchld-handler*-thread))
;;; 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
@ -184,15 +208,12 @@
status)) status))
;;; Handler for SIGCHLD according policy ;;; Handler for SIGCHLD according policy
(define (late-sigchld-handler enabled-ints) (define (late-sigchld-handler) #f)
(display "late sigchld handler"))
(define (early-sigchld-handler enabled-ints) (define (early-sigchld-handler)
(reap-zombies)) (reap-zombies))
(define (noauto-sigchld-handler enabled-ints) (define (noauto-sigchld-handler) #f)
(display "won't on chld reap since #f")
#f)
;;; Finalizer for procobjs ;;; Finalizer for procobjs
@ -248,9 +269,6 @@
;;; TODO: add a jetzt-wart-i lock ;;; TODO: add a jetzt-wart-i lock
(define (wait pid/proc . maybe-flags) (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)) (let* ((flags (:optional maybe-flags 0))
(proc (->proc pid/proc)) (proc (->proc pid/proc))
(win (lambda (status) (win (lambda (status)
@ -267,7 +285,7 @@
((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
@ -333,7 +351,7 @@
(values pid status)))) (values pid status))))
;The rest of this is quite crude and can be safely ignored. -df ;The rest of this is quite crude and can be safely ignored. -df
;;; JMG: wait-any is crude and so it's implementation ;;; JMG: wait-any is crude and so its implementation
;;; It got even worse, now that we have this fu*$#%g 'late ;;; It got even worse, now that we have this fu*$#%g 'late
(if (maybe-obtain-lock reaped-proc-pop-lock) (if (maybe-obtain-lock reaped-proc-pop-lock)
(if (eq? reaped-proc-head reaped-proc-tail) (if (eq? reaped-proc-head reaped-proc-tail)