Reintroduce run-as-long-as to ensure the threads exit on an error

while evaluating -c and -s flags.
This commit is contained in:
mainzelm 2002-06-26 10:02:10 +00:00
parent bfc3c427f6
commit 71e3326079
3 changed files with 21 additions and 14 deletions

View File

@ -174,14 +174,15 @@
(define (with-autoreaping thunk)
(set! *autoreap-policy* 'early)
((structure-ref threads-internal spawn-on-root)
(run-as-long-as
(lambda ()
(let lp ((event (most-recent-sigevent)))
(let ((next-event (next-sigevent event interrupt/chld)))
(*sigchld-handler*)
(lp next-event))))
'auto-reaping)
(thunk))
thunk
(structure-ref threads-internal spawn-on-root)
'auto-reaping))
;;; This list contains pids whose proc-obj were gc'd before they died
;;; We try to reap them after every gc and maybe on every SIGCHLD

View File

@ -188,10 +188,11 @@
(structure-ref threads-internal event-type)
interrupt)
(enum interrupt keyboard))))))
((structure-ref threads-internal spawn-on-root)
deliver-interrupts
'deliver-interrupts)
(thunk))
(run-as-long-as
deliver-interrupts
thunk
(structure-ref threads-internal spawn-on-root)
'deliver-interrupts))
(define (deliver-interrupts)
(let lp ((last ((structure-ref sigevents most-recent-sigevent))))

View File

@ -273,19 +273,24 @@
; This is *extremly* low level
; Don't use unless you know what you are doing
(define (run-as-long-as thunk1 thunk2 . name)
(define (run-as-long-as thunk1 thunk2 spawn-thread . name)
(let ((thread (make-placeholder)))
(apply spawn (lambda ()
(placeholder-set! thread (current-thread))
(thunk1))
(apply spawn-thread
(lambda ()
(placeholder-set! thread (current-thread))
(thunk1))
name)
(dynamic-wind
(lambda () #t)
thunk2
(lambda ()
(remove-thread-from-queues! (placeholder-value thread))
(kill-thread! (placeholder-value thread))
(make-ready (placeholder-value thread))))))
(savely-kill-thread! (placeholder-value thread))))))
(define (savely-kill-thread! thread)
(remove-thread-from-queues! thread)
(kill-thread! thread)
(make-ready thread))