From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 21 Jul 2015 01:11:42 +0000 (-0700)
Subject: Replace subprocess status ticks with thread events.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~17
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0c70df0a481a0ad313cda6412458636eacda998a;p=mit-scheme.git

Replace subprocess status ticks with thread events.

Without without-interrupts, ticks do not work.  It is possible to
block even though a subprocess has changed state between the last
observation of the global status tick and the suspend.  Passing the
observed tick to suspend-current-thread would allow it to check for
new ticks in the atomic section wherein it decides if the thread
should suspend, but replacing without-interrupts with with-thread-
events-blocked suggests a cleaner solution: subprocess thread events.

The new procedures register-subprocess-event and deregister-
subprocess-event are now used by Edwin.  ANY main loop managing
subprocesses AND IO should be using register-subprocess-event along
with with-thread-events-blocked and suspend-current-thread to reliably
block for either in an SMPing world.

Block-on-io-descriptor now uses with-thread-events-blocked instead of
without-interrupts but it does NOT use register-subprocess-event AND
WILL NOT UNBLOCK WHEN A SUBPROCESS CHANGES STATUS.

Unfortunately this breaks Edwin on OS2 and Win32 where it is now
possible for Edwin to block for keyboard input without noticing that a
subprocess has exited.  Edwin's main loop in these worlds needs to be
updated to use a "suspend loop" and register-subprocess-event even
though they do not actually multi-process.

Subprocess-wait now uses a suspend loop like the one in block-on-io-
descriptor rather than blocking for the rest of the thread's timeslice
in the process-wait primitive.  Synchronous subprocess management now
uses this procedure instead of the curious subprocess-wait*, the only
remaining procedure using ticks.

Thus SUBPROCESS-GLOBAL-STATUS-TICK and SUBPROCESS-STATUS-TICK are
eliminated.
---

diff --git a/src/edwin/os2term.scm b/src/edwin/os2term.scm
index a8f6aae8b..7dacc2a51 100644
--- a/src/edwin/os2term.scm
+++ b/src/edwin/os2term.scm
@@ -731,6 +731,8 @@ USA.
 		 event:process-status)
 		(else
 		 (let ((flag
+			;; Note that this procedure no longer unblocks
+			;; for subprocess status changes!!!
 			(test-for-io-on-descriptor event-descriptor
 						   block?
 						   'READ)))
diff --git a/src/edwin/process.scm b/src/edwin/process.scm
index c5a05bfe5..228f109e4 100644
--- a/src/edwin/process.scm
+++ b/src/edwin/process.scm
@@ -78,7 +78,9 @@ Initialized from the SHELL environment variable."
   (filter #f)
   (sentinel #f)
   (kill-without-query #f)
-  (notification-tick (cons #f #f)))
+  (status-registration #f)
+  (current-status #f)
+  (pending-status #f))
 
 (define-integrable (process-arguments process)
   (subprocess-arguments (process-subprocess process)))
@@ -86,9 +88,6 @@ Initialized from the SHELL environment variable."
 (define-integrable (process-output-port process)
   (subprocess-output-port (process-subprocess process)))
 
-(define-integrable (process-status-tick process)
-  (subprocess-status-tick (process-subprocess process)))
-
 (define-integrable (process-exit-reason process)
   (subprocess-exit-reason (process-subprocess process)))
 
@@ -125,6 +124,13 @@ Initialized from the SHELL environment variable."
    (let ((buffer (process-buffer process)))
      (and buffer
 	  (mark-right-inserting-copy (buffer-end buffer))))))
+
+(define (deregister-process-status process)
+  (let ((registration (process-status-registration process)))
+    (if registration
+	(begin
+	  (deregister-subprocess-event registration)
+	  (set-process-status-registration! process #f)))))
 
 (define (start-process name buffer environment program . arguments)
   (let ((make-subprocess
@@ -153,6 +159,12 @@ Initialized from the SHELL environment variable."
 	   (let ((channel (subprocess-input-channel subprocess)))
 	     (if channel
 		 (channel-nonblocking channel)))
+	   (set-process-status-registration!
+	    process
+	    (register-subprocess-event
+	     subprocess 'RUNNING (current-thread)
+	     (named-lambda (edwin-process-status-event status)
+	       (set-process-pending-status! process status))))
 	   (update-process-mark! process)
 	   (subprocess-put! subprocess 'EDWIN-PROCESS process)
 	   (set! edwin-processes (cons process edwin-processes))
@@ -174,6 +186,7 @@ Initialized from the SHELL environment variable."
 	   (begin
 	     (subprocess-kill subprocess)
 	     (%perform-status-notification process 'SIGNALLED #f)))
+       (deregister-process-status process)
        (let ((buffer (process-buffer process)))
 	 (if (buffer-alive? buffer)
 	     (buffer-modeline-event! buffer 'PROCESS-STATUS)))
@@ -265,39 +278,24 @@ Initialized from the SHELL environment variable."
     (output-port/flush-output port)))
 
 (define (process-status-changes?)
-  (without-interrupts
-   (lambda ()
-     (not (eq? (subprocess-global-status-tick) global-notification-tick)))))
+  (any (lambda (process)
+	 (not (eq? (process-current-status process)
+		   (process-pending-status process))))
+       edwin-processes))
 
 (define (handle-process-status-changes)
-  (without-interrupts
-   (lambda ()
-     (and (%update-global-notification-tick)
-	  (let loop ((processes edwin-processes) (output? #f))
-	    (if (null? processes)
-		output?
-		(loop (cdr processes)
-		      (if (poll-process-for-status-change (car processes))
-			  #t
-			  output?))))))))
-
-(define (%update-global-notification-tick)
-  (let ((tick (subprocess-global-status-tick)))
-    (and (not (eq? tick global-notification-tick))
-	 (begin
-	   (set! global-notification-tick tick)
-	   #t))))
-
-(define global-notification-tick
-  (cons #f #f))
-
-(define (poll-process-for-status-change process)
-  (let ((status (subprocess-status (process-subprocess process))))
-    (and (not (eq? (process-notification-tick process)
-		   (process-status-tick process)))
-	 (perform-status-notification process
-				      status
-				      (process-exit-reason process)))))
+  (let loop ((processes edwin-processes) (output? #f))
+    (if (pair? processes)
+	(loop (cdr processes)
+	      (or (let* ((process (car processes))
+			 (pending (process-pending-status process)))
+		    (and (not (eq? pending (process-current-status process)))
+			 (begin
+			   (perform-status-notification
+			    process pending (process-exit-reason process))
+			   #t)))
+		  output?))
+	output?)))
 
 (define (register-process-output-events thread event)
   (append-map!
@@ -325,7 +323,7 @@ Initialized from the SHELL environment variable."
     value))
 
 (define (%perform-status-notification process status reason)
-  (set-process-notification-tick! process (process-status-tick process))
+  (set-process-current-status! process status)
   (cond ((process-sentinel process)
 	 =>
 	 (lambda (sentinel)
diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm
index dab0ce567..f25a2d58b 100644
--- a/src/edwin/win32.scm
+++ b/src/edwin/win32.scm
@@ -461,6 +461,8 @@ USA.
 		 event:process-status)
 		(else
 		 (let ((flag
+			;; Note that this procedure no longer unblocks
+			;; for subprocess status changes!!!
 			(test-for-io-on-descriptor
 			 ;; console-channel-descriptor here
 			 ;; means "input from message queue".
diff --git a/src/runtime/io.scm b/src/runtime/io.scm
index a73e8c5b2..eabe2236c 100644
--- a/src/runtime/io.scm
+++ b/src/runtime/io.scm
@@ -175,11 +175,9 @@ USA.
   (let loop ()
     (let ((n (%channel-read channel buffer start end)))
       (if (eq? n #t)
-	  (begin
-	    (handle-subprocess-status-change)
-	    (if (channel-blocking? channel)
-		(loop)
-		#f))
+	  (if (channel-blocking? channel)
+	      (loop)
+	      #f)
 	  n))))
 
 (define (%channel-read channel buffer start end)
@@ -194,7 +192,8 @@ USA.
 	    end))))
     (declare (integrate-operator do-read))
     (if (and have-select? (not (channel-type=file? channel)))
-	(let ((result (test-for-io-on-channel channel 'READ)))
+	(let ((result (test-for-io-on-channel channel 'READ
+					      (channel-blocking? channel))))
 	  (case result
 	    ((READ HANGUP ERROR) (do-read))
 	    ((#F) #f)
@@ -206,11 +205,9 @@ USA.
   (let loop ()
     (let ((n (%channel-write channel buffer start end)))
       (if (eq? n #t)
-	  (begin
-	    (handle-subprocess-status-change)
-	    (if (channel-blocking? channel)
-		(loop)
-		#f))
+	  (if (channel-blocking? channel)
+	      (loop)
+	      #f)
 	  n))))
 
 (define (%channel-write channel buffer start end)
@@ -225,7 +222,8 @@ USA.
 	    end))))
     (declare (integrate-operator do-write))
     (if (and have-select? (not (channel-type=file? channel)))
-	(let ((result (test-for-io-on-channel channel 'WRITE)))
+	(let ((result (test-for-io-on-channel channel 'WRITE
+					      (channel-blocking? channel))))
 	  (case result
 	    ((WRITE HANGUP ERROR) (do-write))
 	    ((#F) 0)
@@ -532,38 +530,35 @@ USA.
 			     mode))
 
 (define (channel-has-input? channel)
-  (let ((descriptor (channel-descriptor-for-select channel)))
-    (let loop ()
-      (let ((mode (test-select-descriptor descriptor #f 'READ)))
-	(if (pair? mode)
-	    (or (eq? (car mode) 'READ)
-		(eq? (car mode) 'READ/WRITE))
-	    (begin
-	      (if (eq? mode 'PROCESS-STATUS-CHANGE)
-		  (handle-subprocess-status-change))
-	      (loop)))))))
+  (let loop ()
+    (let ((mode (test-select-descriptor (channel-descriptor-for-select channel)
+					'READ)))
+      (if (pair? mode)
+	  (or (eq? (car mode) 'READ)
+	      (eq? (car mode) 'READ/WRITE))
+	  (loop)))))
 
 (define-integrable (channel-descriptor-for-select channel)
   ((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
 
 (define (test-for-io-on-descriptor descriptor block? mode)
-  (or (let ((rmode (test-select-descriptor descriptor #f mode)))
+  (or (let ((rmode (test-select-descriptor descriptor mode)))
 	(if (pair? rmode)
 	    (simplify-select-registry-mode rmode)
 	    rmode))
       (and block?
 	   (block-on-io-descriptor descriptor mode))))
 
-(define (test-select-descriptor descriptor block? mode)
+(define (test-select-descriptor descriptor mode)
   (let ((result
 	 ((ucode-primitive test-select-descriptor 3)
 	  descriptor
-	  block?
+	  #f
 	  (encode-select-registry-mode mode))))
     (cond ((>= result 0) (decode-select-registry-mode result))
 	  ((= result -1) 'INTERRUPT)
 	  ((= result -2)
-	   (subprocess-global-status-tick)
+	   (handle-subprocess-status-change)
 	   'PROCESS-STATUS-CHANGE)
 	  (else
 	   (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
@@ -625,9 +620,7 @@ USA.
 	    (deallocate-select-registry-result-vectors vfd vmode)
 	    (cond ((= 0 result) #f)
 		  ((= -1 result) 'INTERRUPT)
-		  ((= -2 result)
-		   (subprocess-global-status-tick)
-		   'PROCESS-STATUS-CHANGE)
+		  ((= -2 result) 'PROCESS-STATUS-CHANGE)
 		  (else
 		   (error "Illegal result from TEST-SELECT-REGISTRY:"
 			  result))))))))
diff --git a/src/runtime/process.scm b/src/runtime/process.scm
index 2468b7996..a793658e5 100644
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -31,7 +31,6 @@ USA.
 
 (define subprocess-finalizer)
 (define scheme-subprocess-environment)
-(define global-status-tick)
 
 (define (initialize-package!)
   (set! subprocess-finalizer
@@ -39,13 +38,13 @@ USA.
 			   subprocess?
 			   subprocess-index
 			   set-subprocess-index!))
+  (set! subprocess-support-loaded? #t)
   (reset-package!)
   (add-event-receiver! event:after-restore reset-package!)
   (add-event-receiver! event:before-exit delete-all-processes))
 
 (define (reset-package!)
   (set! scheme-subprocess-environment ((ucode-primitive scheme-environment 0)))
-  (set! global-status-tick (cons #f #f))
   unspecific)
 
 (define (delete-all-processes)
@@ -67,9 +66,8 @@ USA.
   output-channel
   (id #f read-only #t)
   (%i/o-port #f)
-  (%status #f)
+  (status #f)
   (exit-reason #f)
-  (%status-tick #f)
   (properties (make-1d-table) read-only #t))
 
 (define (subprocess-get process key)
@@ -166,73 +164,73 @@ USA.
 			  filename arguments index pty-master
 			  input-channel output-channel
 			  ((ucode-primitive process-id 1) index))))
-		    (set-subprocess-%status!
+		    (set-subprocess-status!
 		     process
-		     ((ucode-primitive process-status 1) index))
+		     (convert-subprocess-status
+		      ((ucode-primitive process-status 1) index)))
 		    (set-subprocess-exit-reason!
 		     process
 		     ((ucode-primitive process-reason 1) index))
-		    (add-to-gc-finalizer! subprocess-finalizer process)))))))))
+		    (add-to-gc-finalizer! subprocess-finalizer process)
+		    (poll-subprocess-status process)
+		    process))))))))
     (if (and (eq? ctty 'FOREGROUND)
-	     (eqv? (%subprocess-status process) 0))
+	     (eq? (subprocess-status process) 'RUNNING))
 	(subprocess-continue-foreground process))
     process))
 
 (define (subprocess-delete process)
   (if (subprocess-index process)
       (begin
+	(poll-subprocess-status process)
 	(close-subprocess-i/o process)
+	(deregister-subprocess process)
 	(remove-from-gc-finalizer! subprocess-finalizer process))))
 
-(define (subprocess-status process)
-  (convert-subprocess-status (%subprocess-status process)))
-
 (define (subprocess-wait process)
-  (let loop ()
-    ((ucode-primitive process-wait 1) (subprocess-index process))
-    (let ((status (%subprocess-status process)))
-      (if (eqv? status 0)
-	  (loop)
-	  (convert-subprocess-status status)))))
+  (let ((result #f)
+	(registration))
+    (dynamic-wind
+     (lambda ()
+       (set! registration
+	     (register-subprocess-event
+	      process 'RUNNING (current-thread)
+	      (named-lambda (subprocess-wait-event status)
+		(set! result status)))))
+     (lambda ()
+       (let loop ()
+	 (with-thread-events-blocked
+	  (lambda ()
+	    (if (eq? result '#f)
+		(suspend-current-thread))
+	    (if (eq? result 'RUNNING)
+		(set! result #f))))
+	 (if (not result)
+	     (loop)
+	     result)))
+     (lambda ()
+       (deregister-subprocess-event registration)))))
 
 (define (subprocess-continue-foreground process)
   (let loop ()
     ((ucode-primitive process-continue-foreground 1)
      (subprocess-index process))
-    (let ((status (%subprocess-status process)))
-      (if (eqv? status 0)
+    (let ((status (subprocess-status process)))
+      (if (eq? status 'RUNNING)
 	  (loop)
-	  (convert-subprocess-status status)))))
-
-(define (%subprocess-status process)
-  (without-interruption
-   (lambda ()
-     (let ((index (subprocess-index process)))
-       (if (and index ((ucode-primitive process-status-sync 1) index))
-	   (begin
-	     (set-subprocess-%status!
-	      process
-	      ((ucode-primitive process-status 1) index))
-	     (set-subprocess-exit-reason!
-	      process
-	      ((ucode-primitive process-reason 1) index))
-	     (set-subprocess-%status-tick! process #f))))))
-  (subprocess-%status process))
-
-(define (subprocess-status-tick process)
-  (or (subprocess-%status-tick process)
-      (let ((tick (cons #f #f)))
-	(set-subprocess-%status-tick! process tick)
-	tick)))
-
-(define (subprocess-global-status-tick)
-  (without-interruption
-   (lambda ()
-     (if ((ucode-primitive process-status-sync-all 0))
-	 (let ((tick (cons #f #f)))
-	   (set! global-status-tick tick)
-	   tick)
-	 global-status-tick))))
+	  status))))
+
+(define (poll-subprocess-status process)
+  (let ((index (subprocess-index process)))
+    (if (and index ((ucode-primitive process-status-sync 1) index))
+	(begin
+	  (set-subprocess-status!
+	   process
+	   (convert-subprocess-status
+	    ((ucode-primitive process-status 1) index)))
+	  (set-subprocess-exit-reason!
+	   process
+	   ((ucode-primitive process-reason 1) index))))))
 
 (define (convert-subprocess-status status)
   (case status
@@ -253,13 +251,103 @@ USA.
       ((3) 'JOB-CONTROL)
       (else (error "Illegal process job-control status:" n)))))
 
+;;;; Subprocess Events
+
+(define-structure (subprocess-registration
+		   (conc-name subprocess-registration/))
+  (subprocess #f read-only #t)
+  (status #f)
+  (thread () read-only #t)
+  (event () read-only #t))
+
+(define (guarantee-subprocess-registration object procedure)
+  (if (not (subprocess-registration? object))
+      (error:wrong-type-argument object "subprocess-registration" procedure)))
+
+(define (guarantee-subprocess object procedure)
+  (if (not (subprocess? object))
+      (error:wrong-type-argument object "subprocess" procedure)))
+
+(define (register-subprocess-event subprocess status thread event)
+  (guarantee-subprocess subprocess 'register-subprocess-event)
+  (guarantee-thread thread 'register-subprocess-event)
+  (guarantee-procedure-of-arity event 1 'register-subprocess-event)
+  (let ((registration (make-subprocess-registration
+		       subprocess status thread event)))
+    (without-interrupts
+     (lambda ()
+       (set! subprocess-registrations
+	     (cons registration subprocess-registrations))
+       (let ((current (subprocess-status subprocess)))
+	 (if (not (eq? status current))
+	     (begin
+	       (%signal-thread-event
+		thread (and event (lambda () (event current))))
+	       (set-subprocess-registration/status! registration current))))))
+    registration))
+
+(define (deregister-subprocess-event registration)
+  (guarantee-subprocess-registration registration
+				     'DEREGISTER-SUBPROCESS-EVENT)
+  (without-interrupts
+   (lambda ()
+     (set! subprocess-registrations
+	   (delq! registration subprocess-registrations)))))
+
+(define (deregister-subprocess subprocess)
+  (without-interrupts
+   (lambda ()
+     (set! subprocess-registrations
+	   (filter!
+	    (lambda (registration)
+	      (not (eq? subprocess
+			(subprocess-registration/subprocess registration))))
+		    subprocess-registrations)))))
+
+(define (deregister-subprocess-events thread)
+  (set! subprocess-registrations
+	(filter!
+	 (lambda (registration)
+	   (not (eq? thread (subprocess-registration/thread registration))))
+	 subprocess-registrations)))
+
 (define (handle-subprocess-status-change)
+  (without-interrupts %handle-subprocess-status-change)
   (if (eq? 'NT microcode-id/operating-system)
       (for-each (lambda (process)
 		  (if (memq (subprocess-status process) '(EXITED SIGNALLED))
 		      (close-subprocess-i/o process)))
 		(subprocess-list))))
 
+(define (%handle-subprocess-status-change)
+  (if ((ucode-primitive process-status-sync-all 0))
+      (begin
+	(for-each (lambda (weak)
+		    (let ((subprocess (weak-car weak)))
+		      (if subprocess
+			  (poll-subprocess-status subprocess))))
+		  (gc-finalizer-items subprocess-finalizer))
+	(for-each
+	  (lambda (registration)
+	    (let ((status (subprocess-status
+			   (subprocess-registration/subprocess registration)))
+		  (old (subprocess-registration/status registration)))
+	      (if (not (eq? status old))
+		  (let ((event (subprocess-registration/event registration)))
+		    (%signal-thread-event
+		     (subprocess-registration/thread registration)
+		     (and event (lambda () (event status))))
+		    (set-subprocess-registration/status! registration
+							 status)))))
+	  subprocess-registrations)
+	(set! subprocess-registrations
+	      (filter! (lambda (registration)
+			 (let ((status
+				(subprocess-registration/status registration)))
+			   (not (or (eq? status 'EXITED)
+				    (eq? status 'SIGNALLED)))))
+		       subprocess-registrations)))))
+
 (define-integrable subprocess-job-control-available?
   (ucode-primitive os-job-control? 0))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4871f62b3..4f06036c8 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3844,8 +3844,10 @@ USA.
     (else))
   (parent (runtime))
   (export ()
+	  deregister-subprocess-event
 	  make-subprocess
 	  process-environment-bind
+	  register-subprocess-event
 	  run-subprocess-in-foreground
 	  scheme-subprocess-environment
 	  start-batch-subprocess
@@ -3859,7 +3861,6 @@ USA.
 	  subprocess-exit-reason
 	  subprocess-filename
 	  subprocess-get
-	  subprocess-global-status-tick
 	  subprocess-hangup
 	  subprocess-i/o-port
 	  subprocess-id
@@ -3879,7 +3880,6 @@ USA.
 	  subprocess-remove!
 	  subprocess-signal
 	  subprocess-status
-	  subprocess-status-tick
 	  subprocess-stop
 	  subprocess-wait
 	  subprocess?)
@@ -3887,6 +3887,15 @@ USA.
 	  handle-subprocess-status-change)
   (export (runtime socket)
 	  handle-subprocess-status-change)
+  (export (runtime thread)
+	  deregister-subprocess-events
+	  %handle-subprocess-status-change)
+  (import (runtime thread)
+	  %signal-thread-event
+	  subprocess-registrations
+	  subprocess-support-loaded?)
+  (import (runtime gc-finalizer)
+	  gc-finalizer-items)
   (initialization (initialize-package!)))
 
 (define-package (runtime synchronous-subprocess)
@@ -5059,6 +5068,7 @@ USA.
 	  deregister-timer-event
 	  detach-thread
 	  exit-current-thread
+	  guarantee-thread
 	  join-thread
 	  lock-thread-mutex
 	  make-thread-mutex
diff --git a/src/runtime/syncproc.scm b/src/runtime/syncproc.scm
index 63f04f4ef..42088bcd8 100644
--- a/src/runtime/syncproc.scm
+++ b/src/runtime/syncproc.scm
@@ -110,18 +110,6 @@ USA.
      (if directory
 	 (cons environment (->namestring directory))
 	 environment))))
-
-;++ Oops...
-
-(define (subprocess-wait* process)
-  (subprocess-wait process)
-  (let tick-loop ((tick (subprocess-status-tick process)))
-    (let ((status (subprocess-status process))
-	  (exit-reason (subprocess-exit-reason process)))
-      (let ((tick* (subprocess-status-tick process)))
-	(if (eq? tick* tick)
-	    (values status exit-reason)
-	    (tick-loop tick*))))))
 
 (define condition-type:subprocess-abnormal-termination
   (make-condition-type 'SUBPROCESS-ABNORMAL-TERMINATION condition-type:error
@@ -197,7 +185,10 @@ USA.
 		      (do ()
 			  ((= (or (copy-output) 0) 0))
 			(if redisplay-hook (redisplay-hook)))))))))))
-  (subprocess-wait* process))
+  (subprocess-wait process)
+  (subprocess-delete process)
+  (values (subprocess-status process)
+	  (subprocess-exit-reason process)))
 
 (define (call-with-input-copier process process-input nonblock? bsize receiver)
   (let ((port (subprocess-output-port process)))
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index a329ba2a6..1e01c3b01 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -155,7 +155,7 @@ USA.
 (define (reset-threads-high!)
   (set! io-registry (and have-select? (make-select-registry)))
   (set! io-registrations #f)
-  unspecific)
+  (set! subprocess-registrations '()))
 
 (define (make-thread continuation)
   (let ((thread (%make-thread (make-1d-table))))
@@ -429,6 +429,7 @@ USA.
     (translate-to-state-point (thread/root-state-point thread))
     (%deregister-io-thread-events thread)
     (%discard-thread-timer-records thread)
+    (%deregister-subprocess-events thread)
     (%disassociate-joined-threads thread)
     (%disassociate-thread-mutexes thread)
     (if (eq? no-exit-value-marker (thread/exit-value thread))
@@ -545,53 +546,36 @@ USA.
 				  (vector-ref result 1)
 				  (vector-ref result 2)))
 	((eq? 'PROCESS-STATUS-CHANGE result)
-	 (signal-io-thread-events 1
-				  '#(PROCESS-STATUS-CHANGE)
-				  '#(READ)))))
+	 (%handle-subprocess-status-change))))
 
 (define (maybe-signal-io-thread-events)
-  (if io-registrations
+  (if (or io-registrations
+	  (not (null? subprocess-registrations)))
       (signal-select-result (test-select-registry io-registry #f))))
 
 (define (block-on-io-descriptor descriptor mode)
-  (without-interrupts
-   (lambda ()
-     (let ((result 'INTERRUPT)
-	   (registration-1)
-	   (registration-2))
-       (dynamic-wind
-	(lambda ()
-	  (let ((thread (current-thread)))
-	    (set! registration-1
-		  (%register-io-thread-event
-		   descriptor
-		   mode
-		   thread
-		   (lambda (mode)
-		     (set! result mode)
-		     unspecific)))
-	    (set! registration-2
-		  (%register-io-thread-event
-		   'PROCESS-STATUS-CHANGE
-		   'READ
-		   thread
-		   (lambda (mode)
-		     mode
-		     (set! result 'PROCESS-STATUS-CHANGE)
-		     unspecific))))
-	  (%maybe-toggle-thread-timer))
-	(lambda ()
-	  (%suspend-current-thread)
-	  result)
+  (let ((result 'INTERRUPT)
+	(registration #f))
+    (dynamic-wind
+     (lambda ()
+       (if registration (error "Re-entered block-on-io-descrptor."))
+       (set! registration
+	     (register-io-thread-event descriptor mode (current-thread)
+				       (named-lambda (block-on-io-event mode)
+					 (set! result mode)))))
+     (lambda ()
+       (with-thread-events-blocked
 	(lambda ()
-	  (%maybe-deregister-io-thread-event registration-2)
-	  (%maybe-deregister-io-thread-event registration-1)
-	  (%maybe-toggle-thread-timer)))))))
-
-(define (%maybe-deregister-io-thread-event tentry)
-  ;; Ensure that another thread does not unwind our registration.
-  (if (eq? (current-thread) (tentry/thread tentry))
-      (delete-tentry! tentry)))
+	  (if (eq? result 'INTERRUPT)
+	      (suspend-current-thread)))))
+     (lambda ()
+       (if (and registration
+		;; Ensure another thread does not de-register our IO event.
+		(eq? (current-thread) (tentry/thread registration)))
+	   (begin
+	     (deregister-io-thread-event registration)
+	     (set! registration #f)))))
+    result))
 
 (define (permanently-register-io-thread-event descriptor mode thread event)
   (let ((stop? #f)
@@ -655,8 +639,7 @@ USA.
 	      unspecific)
 	     ((and (eqv? descriptor (dentry/descriptor dentry))
 		   (eq? mode (dentry/mode dentry)))
-	      (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-		  (remove-from-select-registry! io-registry descriptor mode))
+	      (remove-from-select-registry! io-registry descriptor mode)
 	      (let ((prev (dentry/prev dentry))
 		    (next (dentry/next dentry)))
 		(if prev
@@ -713,8 +696,7 @@ USA.
 	       (if io-registrations
 		   (set-dentry/prev! io-registrations dentry))
 	       (set! io-registrations dentry)
-	       (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-		   (add-to-select-registry! io-registry descriptor mode))))
+	       (add-to-select-registry! io-registry descriptor mode)))
 	    ((and (eqv? descriptor (dentry/descriptor dentry))
 		  (eq? mode (dentry/mode dentry)))
 	     (set-tentry/dentry! tentry dentry)
@@ -805,11 +787,9 @@ USA.
 	(set-dentry/last-tentry! dentry prev))
     (if (not (or prev next))
 	(begin
-	  (let ((descriptor (dentry/descriptor dentry)))
-	    (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-		(remove-from-select-registry! io-registry
-					      descriptor
-					      (dentry/mode dentry))))
+	  (remove-from-select-registry! io-registry
+					(dentry/descriptor dentry)
+					(dentry/mode dentry))
 	  (let ((prev (dentry/prev dentry))
 		(next (dentry/next dentry)))
 	    (if prev
@@ -946,6 +926,15 @@ USA.
 	     (maybe-signal-io-thread-events))))
      (%maybe-toggle-thread-timer))))
 
+;;;; Subprocess Events
+
+(define subprocess-registrations)
+(define subprocess-support-loaded? #f)
+
+(define (%deregister-subprocess-events thread)
+  (if subprocess-support-loaded?
+      (deregister-subprocess-events thread)))
+
 ;;;; Timer Events
 
 (define timer-records)
@@ -1023,6 +1012,7 @@ USA.
       (ring/discard-all (thread/pending-events thread))
       (%deregister-io-thread-events thread)
       (%discard-thread-timer-records thread)
+      (%deregister-subprocess-events thread)
       (set-thread/block-events?! thread block-events?))
     (%maybe-toggle-thread-timer)
     (set-interrupt-enables! interrupt-mask/all)))
@@ -1081,6 +1071,7 @@ USA.
 	    ((and consider-non-timers?
 		  timer-interval
 		  (or io-registrations
+		      (not (null? subprocess-registrations))
 		      (let ((current-thread first-running-thread))
 			(and current-thread
 			     (thread/next current-thread)))))