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 a8f6aae8bbecf7e817ff590ce9b7324e539b6637..7dacc2a51d7c45629e6ab144904fd11ea30ece38 100644 (file)
--- 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 c5a05bfe54e019094a587b2c10e4fccaffb95dcd..228f109e4711598f93159c4a1f5e923eb8f15c5d 100644 (file)
--- 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)))))
 \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?)))
 \f
 (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 dab0ce567b709bc67cb294c62126a41e579fb150..f25a2d58b272538a1fc0b473a4087cba06b9633c 100644 (file)
--- 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 a73e8c5b2b431964c43a2bf09b11598a3227087a..eabe2236cae1335b841641c7a2936f2af8655f5c 100644 (file)
--- 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 2468b79965963541609ebcef35d5b9dbd45d0f4c..bf8f2bfef06ac2f319cdb2f4af358ee5ade96377 100644 (file)
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -31,7 +31,6 @@ USA.
 \f
 (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))))
 \f
-(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)))))
 \f
 (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 a9c0b290badba575ec948271960277fe79534499..f7841a18509feec5d0d44d03e3972486e0fb2189 100644 (file)
--- 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 63f04f4ef88707f8137e2417c6a5e717aaffae26..42088bcd8145e18416e95fe05fe55c04fc457abc 100644 (file)
--- 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*))))))
 \f
 (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)))
 \f
 (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 64d9f9bc5a954c17d3e1f554ecbed5212c13b62e..26b0d96b48fcf5b8719d82ba6cfe52e809e9a59e 100644 (file)
--- 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))
 \f
 (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))))
 \f
+;;;; 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))
+\f
 ;;;; 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)))