Reintroduce run-as-long-as to ensure the threads exit on an error
while evaluating -c and -s flags.
This commit is contained in:
parent
bfc3c427f6
commit
71e3326079
|
@ -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
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue