From 0c70df0a481a0ad313cda6412458636eacda998a Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 20 Jul 2015 18:11:42 -0700 Subject: [PATCH] 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 replacing without-interrupts with with-thread- events-blocked suggests a cleaner solution: subprocess thread events. The new procedures register-subprocess-event and deregister- subprocess-event are now used by Edwin. ANY main loop managing subprocesses AND IO should be using register-subprocess-event along with with-thread-events-blocked and suspend-current-thread to reliably block for either in an SMPing world. 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. --- src/edwin/os2term.scm | 2 + src/edwin/process.scm | 70 +++++++-------- src/edwin/win32.scm | 2 + src/runtime/io.scm | 51 +++++------ src/runtime/process.scm | 188 ++++++++++++++++++++++++++++----------- src/runtime/runtime.pkg | 14 ++- src/runtime/syncproc.scm | 17 +--- src/runtime/thread.scm | 93 +++++++++---------- 8 files changed, 256 insertions(+), 181 deletions(-) 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..a793658e5 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 @@ -39,13 +38,13 @@ 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)) (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 +66,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 +164,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 @@ -253,13 +251,103 @@ USA. ((3) 'JOB-CONTROL) (else (error "Illegal process job-control status:" n))))) +;;;; 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))) + (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-SUBPROCESS-EVENT) + (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 (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)) + (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 4871f62b3..4f06036c8 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3844,8 +3844,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 @@ -3859,7 +3861,6 @@ USA. subprocess-exit-reason subprocess-filename subprocess-get - subprocess-global-status-tick subprocess-hangup subprocess-i/o-port subprocess-id @@ -3879,7 +3880,6 @@ USA. subprocess-remove! subprocess-signal subprocess-status - subprocess-status-tick subprocess-stop subprocess-wait subprocess?) @@ -3887,6 +3887,15 @@ USA. handle-subprocess-status-change) (export (runtime socket) handle-subprocess-status-change) + (export (runtime thread) + deregister-subprocess-events + %handle-subprocess-status-change) + (import (runtime thread) + %signal-thread-event + subprocess-registrations + subprocess-support-loaded?) + (import (runtime gc-finalizer) + gc-finalizer-items) (initialization (initialize-package!))) (define-package (runtime synchronous-subprocess) @@ -5059,6 +5068,7 @@ USA. deregister-timer-event detach-thread exit-current-thread + guarantee-thread join-thread lock-thread-mutex make-thread-mutex 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 a329ba2a6..1e01c3b01 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -155,7 +155,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)))) @@ -429,6 +429,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)) @@ -545,53 +546,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 + (if (or io-registrations + (not (null? subprocess-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) + (named-lambda (block-on-io-event mode) + (set! result mode))))) + (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) @@ -655,8 +639,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 @@ -713,8 +696,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) @@ -805,11 +787,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 @@ -946,6 +926,15 @@ USA. (maybe-signal-io-thread-events)))) (%maybe-toggle-thread-timer)))) +;;;; Subprocess Events + +(define subprocess-registrations) +(define subprocess-support-loaded? #f) + +(define (%deregister-subprocess-events thread) + (if subprocess-support-loaded? + (deregister-subprocess-events thread))) + ;;;; Timer Events (define timer-records) @@ -1023,6 +1012,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))) @@ -1081,6 +1071,7 @@ USA. ((and consider-non-timers? timer-interval (or io-registrations + (not (null? subprocess-registrations)) (let ((current-thread first-running-thread)) (and current-thread (thread/next current-thread))))) -- 2.25.1