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)))
(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)))
(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)))
(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
(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))
(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)))
(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!
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)
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".
(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)
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)
(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)
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)
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)))))
(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))))))))
\f
(define subprocess-finalizer)
(define scheme-subprocess-environment)
-(define global-status-tick)
(define (initialize-package!)
(set! subprocess-finalizer
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)
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)
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
((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)))
+ (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)))
+\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))
+ (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))
(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
subprocess-exit-reason
subprocess-filename
subprocess-get
- subprocess-global-status-tick
subprocess-hangup
subprocess-i/o-port
subprocess-id
subprocess-remove!
subprocess-signal
subprocess-status
- subprocess-status-tick
subprocess-stop
subprocess-wait
subprocess?)
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)
deregister-timer-event
detach-thread
exit-current-thread
+ guarantee-thread
join-thread
lock-thread-mutex
make-thread-mutex
(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
(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)))
(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))))
(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))
(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))
\f
(define (permanently-register-io-thread-event descriptor mode thread event)
(let ((stop? #f)
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
(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)
(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
(maybe-signal-io-thread-events))))
(%maybe-toggle-thread-timer))))
\f
+;;;; Subprocess Events
+
+(define subprocess-registrations)
+(define subprocess-support-loaded? #f)
+
+(define (%deregister-subprocess-events thread)
+ (if subprocess-support-loaded?
+ (deregister-subprocess-events thread)))
+\f
;;;; Timer Events
(define timer-records)
(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)))
((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)))))
projects / mit-scheme.git / commitdiff