(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)
(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)
(define (channel-has-input? channel)
(let ((descriptor (channel-descriptor-for-select channel)))
(let loop ()
- (let ((mode (test-select-descriptor descriptor #f 'READ)))
+ (let ((mode (test-select-descriptor descriptor '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)))))))
+ (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))))))))
tick)))
(define (subprocess-global-status-tick)
- (if ((ucode-primitive process-status-sync-all 0))
- (let ((tick (cons #f #f)))
- (set! global-status-tick tick)
- tick)
- global-status-tick))
+ global-status-tick)
(define (convert-subprocess-status status)
(case status
((3) 'JOB-CONTROL)
(else (error "Illegal process job-control status:" n)))))
\f
-(define last-global-tick '())
-
-(define (handle-status-change signaler)
- (let ((latest-tick (subprocess-global-status-tick)))
- (if (not (eq? latest-tick last-global-tick))
- (begin
- (signaler)
- (set! last-global-tick latest-tick)))))
-
(define (handle-subprocess-status-change)
- (handle-status-change signal-subprocess-status-change)
+ (with-threads-locked %handle-subprocess-status-change)
(if (eq? 'NT microcode-id/operating-system)
(for-each (lambda (process)
(if (memq (subprocess-status process) '(EXITED SIGNALLED))
(subprocess-list))))
(define (%handle-subprocess-status-change)
- (handle-status-change %signal-subprocess-status-change))
+ (if ((ucode-primitive process-status-sync-all 0))
+ (begin
+ (set! global-status-tick (cons #f #f))
+ (%signal-subprocess-status-change))))
(define-integrable subprocess-job-control-available?
(ucode-primitive os-job-control? 0))
(export (runtime thread)
%handle-subprocess-status-change)
(import (runtime thread)
- %signal-subprocess-status-change
- signal-subprocess-status-change)
+ with-threads-locked
+ %signal-subprocess-status-change)
(initialization (initialize-package!)))
(define-package (runtime synchronous-subprocess)
(define locked? #f)
-(define-integrable (get-interrupt-enables)
- ((ucode-primitive get-interrupt-enables 0)))
+(define-integrable get-interrupt-enables
+ (ucode-primitive get-interrupt-enables 0))
(define-integrable (only-gc-ok?)
(fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok)))
((eq? 'PROCESS-STATUS-CHANGE result)
(%handle-subprocess-status-change))))
-(define (signal-subprocess-status-change)
- (%%trace ";"(%%id)" signal-subprocess-status-change\n")
- (with-threads-locked %signal-subprocess-status-change))
-
(define (%signal-subprocess-status-change)
(%%trace ";"(%%id)" %signal-subprocess-status-change\n")
(assert-locked '%signal-subprocess-status-change)