gtk: Fixed spin in gtk-test after test-process.

Re-enabled the runtime/test-process tests.  Added maybe-signal-io-
thread-events to yield-thread, and made it unconditionally test-
select-registry, even if there are no io-registrations.  In gtk-test,
the main thread sleeps and the gtk-thread runs alone.  Neither
registers for io or process status change events, yet gtk-thread needs
subprocess-global-status-tick to happen anyway (else run_gtk
immediately returns PROCESS-STATUS-CHANGE and gtk-thread spins).

Assumed that maybe-signal-io-thread-events could be fixed by allowing
it to test-select-registry even when the registry is empty.

Moved all subprocess status change work into handle-subprocess-status-
change, which now calls subprocess-global-status-tick and compares the
latest tick to the tick saved last time.  When statuses have changed
since the last tick, it polls process statuses (and closes i/o) and
un-suspend waiters.  The former was only done for NT, but does not
hurt on Unix.  The latter is accomplished by the new signal-
subprocess-status-change procedure.  All other calls to subprocess-
global-status-tick were redundant, or were replaced by calls to
handle-subprocess-status-change.

diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm
index 538d4b327213feb31bf60d847174fec2fe2dfbd1..77138797b6064997ad54383187bf2ca89876afa1 100644 (file)
--- a/src/gtk/thread.scm
+++ b/src/gtk/thread.scm
@@ -78,8 +78,7 @@ USA.
                                     -1)))
                       (%trace ";run-gtk until "time"\n")
                       (run-gtk (select-registry-handle io-registry) time)
-                      (%trace ";run-gtk done at "(real-time-clock)"\n"))
-                    (maybe-signal-io-thread-events)))
+                      (%trace ";run-gtk done at "(real-time-clock)"\n"))))
                  (yield-current-thread)
                  (gtk-thread-loop))))))
   (detach-thread gtk-thread))

diff --git a/src/runtime/io.scm b/src/runtime/io.scm
index 5a8c60e5a59dde2326eb9a6c5db359d4498d3832..0376f3acb02667c889abeea63c7a60c43752ca22 100644 (file)
--- a/src/runtime/io.scm
+++ b/src/runtime/io.scm
@@ -576,9 +576,7 @@ USA.
          (encode-select-registry-mode mode))))
     (cond ((>= result 0) (decode-select-registry-mode result))
          ((= result -1) 'INTERRUPT)
-         ((= result -2)
-          (subprocess-global-status-tick)
-          'PROCESS-STATUS-CHANGE)
+         ((= result -2) 'PROCESS-STATUS-CHANGE)
          (else
           (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
 
@@ -639,9 +637,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 1d95b7419bbb3113f65d2f1ce540f19ab3003b0d..8d2b018dcad84cec8144f1faf6f14f73988f975a 100644 (file)
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -211,7 +211,6 @@ USA.
        (if (eqv? status 0)
           (begin
             (block-on-process-status-change)
-            (subprocess-global-status-tick)
             (handle-subprocess-status-change)))))))
 
 (define hook/subprocess-wait normal/subprocess-wait)
@@ -274,15 +273,18 @@ USA.
       ((3) 'JOB-CONTROL)
       (else (error "Illegal process job-control status:" n)))))
 \f
-(define (handle-subprocess-status-change)
-  (if hook/subprocess-status-change (hook/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 last-global-tick '())
 
-(define hook/subprocess-status-change #f)
+(define (handle-subprocess-status-change)
+  (let ((latest-tick (subprocess-global-status-tick)))
+    (if (not (eq? latest-tick last-global-tick))
+       (begin
+         (for-each (lambda (process)
+                     (if (memq (subprocess-status process) '(EXITED SIGNALLED))
+                         (close-subprocess-i/o process)))
+                   (subprocess-list))
+         (signal-subprocess-status-change)
+         (set! last-global-tick latest-tick)))))
 
 (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 141c3f47a3d49ad8a557ed6afbfc115976c7b28a..64b1568d2b817065d2370fb69fad8301c4546e49 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3813,8 +3813,11 @@ USA.
          handle-subprocess-status-change)
   (export (runtime socket)
          handle-subprocess-status-change)
+  (export (runtime thread)
+         handle-subprocess-status-change)
   (import (runtime thread)
-         block-on-process-status-change)
+         block-on-process-status-change
+         signal-subprocess-status-change)
   (initialization (initialize-package!)))
 
 (define-package (runtime synchronous-subprocess)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 69aee3ad5357682d09a3b1d950cc66ee11c528cf..4e41e456c978bb63c1bf8827b3231c7f83f30768 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -342,6 +342,7 @@ USA.
         (yield-thread thread))))))
 
 (define (yield-thread thread #!optional fp-env)
+  (maybe-signal-io-thread-events)
   (let ((next (thread/next thread)))
     (%trace ";yield-thread: "thread" yields to "next"\n")
     (if (not next)
@@ -510,17 +511,16 @@ 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 (signal-subprocess-status-change)
+  (signal-io-thread-events 1 '#(PROCESS-STATUS-CHANGE) '#(READ)))
 
 (define (maybe-signal-io-thread-events)
   (%trace ";maybe-signal-io-thread-events")
-  (if io-registrations
-      (let ((result (test-select-registry io-registry #f)))
-       (%trace " => "(and result (vector-ref result 0))"\n")
-       (signal-select-result result))
-      (%trace " => 0\n")))
+  (let ((result (test-select-registry io-registry #f)))
+    (%trace " => "(and result (vector-ref result 0))"\n")
+    (signal-select-result result)))
 
 (define (block-on-io-descriptor descriptor mode)
   (without-interrupts

diff --git a/tests/check.scm b/tests/check.scm
index 74c71cf23cdb12978145c4423efec632a11d1793..790d5ba142c75c99129ce175c0e345ca88cbeea7 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -47,7 +47,7 @@ USA.
     "runtime/test-floenv"
     "runtime/test-hash-table"
     "runtime/test-integer-bits"
-;    "runtime/test-process"
+    "runtime/test-process"
     "runtime/test-regsexp"
     ("runtime/test-wttree" (runtime wt-tree))
     "ffi/test-ffi.scm"