From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 6 Jul 2015 06:26:34 +0000 (-0700)
Subject: Replace subprocess status ticks with thread events.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f560ab13586860ba9da1c7fa01314ec68709b4ac;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 using with-thread-events-blocked for without-
interrupts suggests a "cleaner" solution: subprocess thread events.

The new procedures register-subprocess-event and deregister-
subprocess-event are now used by Edwin in SMPable worlds.  ANY main
loop managing subprocesses AND IO should be using register-subprocess-
event along with with-thread-events-blocked and suspend-current-thread
for SMPability.

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.

Conflicts:
	src/runtime/thread.scm
---

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..bf8f2bfef 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
@@ -45,7 +44,6 @@ USA.
 
 (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 +65,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 +163,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
@@ -254,12 +251,23 @@ USA.
       (else (error "Illegal process job-control status:" n)))))
 
 (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))
+	(%signal-subprocess-status-change))))
+
 (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 a9c0b290b..f7841a185 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3837,7 +3837,6 @@ USA.
 	  subprocess-exit-reason
 	  subprocess-filename
 	  subprocess-get
-	  subprocess-global-status-tick
 	  subprocess-hangup
 	  subprocess-i/o-port
 	  subprocess-id
@@ -3857,7 +3856,6 @@ USA.
 	  subprocess-remove!
 	  subprocess-signal
 	  subprocess-status
-	  subprocess-status-tick
 	  subprocess-stop
 	  subprocess-wait
 	  subprocess?)
@@ -3865,6 +3863,13 @@ USA.
 	  handle-subprocess-status-change)
   (export (runtime socket)
 	  handle-subprocess-status-change)
+  (export (runtime thread)
+	  %handle-subprocess-status-change)
+  (import (runtime thread)
+	  deregister-subprocess
+	  %signal-subprocess-status-change)
+  (import (runtime gc-finalizer)
+	  gc-finalizer-items)
   (initialization (initialize-package!)))
 
 (define-package (runtime synchronous-subprocess)
@@ -5031,6 +5036,7 @@ USA.
 	  deregister-all-events
 	  deregister-io-descriptor-events
 	  deregister-io-thread-event
+	  deregister-subprocess-event
 	  deregister-timer-event
 	  detach-thread
 	  exit-current-thread
@@ -5040,6 +5046,7 @@ USA.
 	  other-running-threads?
 	  permanently-register-io-thread-event
 	  register-io-thread-event
+	  register-subprocess-event
 	  register-timer-event
 	  restart-thread
 	  set-thread-timer-interval!
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 64d9f9bc5..26b0d96b4 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -169,7 +169,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))))
@@ -417,6 +417,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))
@@ -533,53 +534,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
       (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)
+				       (lambda (mode)
+					 (set! result mode)
+					 unspecific))))
+     (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)
@@ -643,8 +627,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
@@ -701,8 +684,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)
@@ -793,11 +775,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
@@ -934,6 +914,82 @@ USA.
 	     (maybe-signal-io-thread-events))))
      (%maybe-toggle-thread-timer))))
 
+;;;; Subprocess Events
+
+(define subprocess-registrations)
+
+(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-IO-DESCRIPTOR-EVENTS)
+  (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 (%signal-subprocess-status-change)
+  (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))
+
 ;;;; Timer Events
 
 (define timer-records)
@@ -1011,6 +1067,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)))