From: Matt Birkholz Date: Sun, 12 Jul 2015 00:20:57 +0000 (-0700) Subject: Move subprocess event support to runtime/process.scm. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=51f76890829aaabfeade28d8ecfd8e4d8ae74338;p=mit-scheme.git Move subprocess event support to runtime/process.scm. --- diff --git a/src/runtime/process.scm b/src/runtime/process.scm index 549cb2812..54b4408ba 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -38,6 +38,7 @@ 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)) @@ -260,6 +261,73 @@ 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))) + (with-thread-lock + (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) + (with-thread-lock + (lambda () + (set! subprocess-registrations + (delq! registration subprocess-registrations))))) + +(define (deregister-subprocess subprocess delete-subprocess!) + (let ((error? + (with-thread-lock + (lambda () + (set! subprocess-registrations + (filter! + (lambda (registration) + (not (eq? subprocess (subprocess-registration/subprocess + registration)))) + subprocess-registrations)) + (ignore-errors + (lambda () + (delete-subprocess!) + #f)))))) + (if error? + (signal-condition error?)))) + +(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) (with-thread-lock %handle-subprocess-status-change) (if (eq? 'NT microcode-id/operating-system) @@ -276,7 +344,26 @@ USA. (if subprocess (%poll-subprocess-status subprocess)))) (gc-finalizer-items subprocess-finalizer)) - (%signal-subprocess-status-change)))) + (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 653eae3e9..32fa8af5e 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3835,8 +3835,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 @@ -3877,11 +3879,13 @@ USA. (export (runtime socket) handle-subprocess-status-change) (export (runtime thread) + deregister-subprocess-events %handle-subprocess-status-change) (import (runtime thread) - with-thread-lock - deregister-subprocess - %signal-subprocess-status-change) + %signal-thread-event + subprocess-registrations + subprocess-support-loaded? + with-thread-lock) (import (runtime gc-finalizer) gc-finalizer-items remove-from-locked-gc-finalizer! @@ -5056,10 +5060,10 @@ USA. deregister-gc-event deregister-io-descriptor-events deregister-io-thread-event - deregister-subprocess-event deregister-timer-event detach-thread exit-current-thread + guarantee-thread join-thread lock-thread-mutex make-thread-mutex @@ -5067,7 +5071,6 @@ USA. permanently-register-io-thread-event register-gc-event register-io-thread-event - register-subprocess-event register-timer-event registered-gc-event restart-thread diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 4e549489b..f0d76ac79 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -1059,6 +1059,16 @@ USA. (set-thread/block-events?! thread block-events?)) (%maybe-toggle-thread-timer)))) +;;;; Subprocess Events + +(define subprocess-registrations) +(define subprocess-support-loaded? #f) + +(define (%deregister-subprocess-events thread) + (%assert-locked '%deregister-subprocess-events) + (if subprocess-support-loaded? + (deregister-subprocess-events thread))) + ;;;; GC Events (define gc-events '()) ;Weak alist of threads X events. @@ -1118,97 +1128,6 @@ USA. (loop (cdr alist)))) #f))) -;;;; Subprocess Events - -(define subprocess-registrations) - -(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))) - (with-thread-lock - (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) - (with-thread-lock - (lambda () - (set! subprocess-registrations - (delq! registration subprocess-registrations))))) - -(define (deregister-subprocess subprocess delete-subprocess!) - (let ((error? - (with-thread-lock - (lambda () - (set! subprocess-registrations - (filter! - (lambda (registration) - (not (eq? subprocess (subprocess-registration/subprocess - registration)))) - subprocess-registrations)) - (ignore-errors - (lambda () - (delete-subprocess!) - #f)))))) - (if error? - (signal-condition error?)))) - -(define (%deregister-subprocess-events thread) - (%assert-locked '%deregister-subprocess-events) - (set! subprocess-registrations - (filter! - (lambda (registration) - (not (eq? thread (subprocess-registration/thread registration)))) - subprocess-registrations))) - -(define (%signal-subprocess-status-change) - (%assert-locked '%signal-subprocess-status-change) - (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))) - ;;;; Timer Events (define timer-records)