From 8aeb6e744abfe149dabfbde64486baa486ebe076 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 23 Jul 2012 22:02:48 -0700 Subject: [PATCH] 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. --- src/gtk/thread.scm | 3 +-- src/runtime/io.scm | 8 ++------ src/runtime/process.scm | 20 +++++++++++--------- src/runtime/runtime.pkg | 5 ++++- src/runtime/thread.scm | 16 ++++++++-------- tests/check.scm | 2 +- 6 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 538d4b327..77138797b 100644 --- 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 5a8c60e5a..0376f3acb 100644 --- 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 1d95b7419..8d2b018dc 100644 --- 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))))) -(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 141c3f47a..64b1568d2 100644 --- 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 69aee3ad5..4e41e456c 100644 --- 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 74c71cf23..790d5ba14 100644 --- 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" -- 2.25.1