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