Move subprocess event support to runtime/process.scm.

diff --git a/src/runtime/process.scm b/src/runtime/process.scm
index 549cb2812ee3f14dd2012d89e656d6e79d8fee10..54b4408ba45669dcd223292f56c5da836a36380e 100644 (file)
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -38,6 +38,7 @@ 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))
@@ -260,6 +261,73 @@ USA.
       ((3) 'JOB-CONTROL)
       (else (error "Illegal process job-control status:" n)))))
 \f
+;;;; 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)))
+    (with-thread-lock
+     (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)
+  (with-thread-lock
+   (lambda ()
+     (set! subprocess-registrations
+          (delq! registration subprocess-registrations)))))
+
+(define (deregister-subprocess subprocess delete-subprocess!)
+  (let ((error?
+        (with-thread-lock
+         (lambda ()
+           (set! subprocess-registrations
+                 (filter!
+                  (lambda (registration)
+                    (not (eq? subprocess (subprocess-registration/subprocess
+                                          registration))))
+                  subprocess-registrations))
+           (ignore-errors
+            (lambda ()
+              (delete-subprocess!)
+              #f))))))
+    (if error?
+       (signal-condition error?))))
+
+(define (deregister-subprocess-events thread)
+  (set! subprocess-registrations
+       (filter!
+        (lambda (registration)
+          (not (eq? thread (subprocess-registration/thread registration))))
+        subprocess-registrations)))
+\f
 (define (handle-subprocess-status-change)
   (with-thread-lock %handle-subprocess-status-change)
   (if (eq? 'NT microcode-id/operating-system)
@@ -276,7 +344,26 @@ USA.
                      (if subprocess
                          (%poll-subprocess-status subprocess))))
                  (gc-finalizer-items subprocess-finalizer))
-       (%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)
+       (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 653eae3e93bc64e37a1b6b84e59e25e114a9333d..32fa8af5eae960acce14c62ee57e6de756e6a03d 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3835,8 +3835,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
@@ -3877,11 +3879,13 @@ USA.
   (export (runtime socket)
          handle-subprocess-status-change)
   (export (runtime thread)
+         deregister-subprocess-events
          %handle-subprocess-status-change)
   (import (runtime thread)
-         with-thread-lock
-         deregister-subprocess
-         %signal-subprocess-status-change)
+         %signal-thread-event
+         subprocess-registrations
+         subprocess-support-loaded?
+         with-thread-lock)
   (import (runtime gc-finalizer)
          gc-finalizer-items
          remove-from-locked-gc-finalizer!
@@ -5056,10 +5060,10 @@ USA.
          deregister-gc-event
          deregister-io-descriptor-events
          deregister-io-thread-event
-         deregister-subprocess-event
          deregister-timer-event
          detach-thread
          exit-current-thread
+         guarantee-thread
          join-thread
          lock-thread-mutex
          make-thread-mutex
@@ -5067,7 +5071,6 @@ USA.
          permanently-register-io-thread-event
          register-gc-event
          register-io-thread-event
-         register-subprocess-event
          register-timer-event
          registered-gc-event
          restart-thread

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 4e549489b02c04d1ae25c07f55967fd7359776a6..f0d76ac791ea4f66478702034b774ce1ffba33b4 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -1059,6 +1059,16 @@ USA.
        (set-thread/block-events?! thread block-events?))
      (%maybe-toggle-thread-timer))))
 \f
+;;;; Subprocess Events
+
+(define subprocess-registrations)
+(define subprocess-support-loaded? #f)
+
+(define (%deregister-subprocess-events thread)
+  (%assert-locked '%deregister-subprocess-events)
+  (if subprocess-support-loaded?
+      (deregister-subprocess-events thread)))
+\f
 ;;;; GC Events
 
 (define gc-events '())                 ;Weak alist of threads X events.
@@ -1118,97 +1128,6 @@ USA.
              (loop (cdr alist))))
        #f)))
 \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)))
-    (with-thread-lock
-     (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)
-  (with-thread-lock
-   (lambda ()
-     (set! subprocess-registrations
-          (delq! registration subprocess-registrations)))))
-
-(define (deregister-subprocess subprocess delete-subprocess!)
-  (let ((error?
-        (with-thread-lock
-         (lambda ()
-           (set! subprocess-registrations
-                 (filter!
-                  (lambda (registration)
-                    (not (eq? subprocess (subprocess-registration/subprocess
-                                          registration))))
-                  subprocess-registrations))
-           (ignore-errors
-            (lambda ()
-              (delete-subprocess!)
-              #f))))))
-    (if error?
-       (signal-condition error?))))
-
-(define (%deregister-subprocess-events thread)
-  (%assert-locked '%deregister-subprocess-events)
-  (set! subprocess-registrations
-       (filter!
-        (lambda (registration)
-          (not (eq? thread (subprocess-registration/thread registration))))
-        subprocess-registrations)))
-
-(define (%signal-subprocess-status-change)
-  (%assert-locked '%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)
-  (set! subprocess-registrations
-       (filter! (lambda (registration)
-                  (let ((status (subprocess-registration/status registration)))
-                    (not (or (eq? status 'EXITED)
-                             (eq? status 'SIGNALLED)))))
-                subprocess-registrations)))
-\f
 ;;;; Timer Events
 
 (define timer-records)