From: Matt Birkholz Date: Thu, 12 Mar 2015 18:37:05 +0000 (-0700) Subject: smp: Use process-status-sync-all only while threads are locked. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d1a7915188944a495e72513b6a9dcecdeb71b9e3;p=mit-scheme.git smp: Use process-status-sync-all only while threads are locked. Subprocess-global-status-tick now just returns (runtime subprocess)'s global-status-tick. Thus process-status-sync-all is used in single-threaded fashion in handle-subprocess-status-change, which is used by the test-select- procedures to clear the condition that causes the test-select- primitives to always return 'process-status-change. Handle-subprocess-status-change is now only called in test-select- descriptor. The non-locking version, %handle-subprocess-status- change, is only called in io-waiter's wait-for-io loop (the only place where test-select-registry is used). Punted the block? parameter to test-select-descriptor. This procedure should never be used to block Scheme. Only the call to test-select- registry in the wait-for-io loop should block. --- diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 84481bcaa..1c0cff227 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -177,11 +177,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) @@ -208,11 +206,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) @@ -542,36 +538,33 @@ USA. (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))))) @@ -633,9 +626,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 a08a5bdb2..c2ad76fe8 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -224,11 +224,7 @@ USA. 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 @@ -249,17 +245,8 @@ USA. ((3) 'JOB-CONTROL) (else (error "Illegal process job-control status:" n))))) -(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)) @@ -267,7 +254,10 @@ USA. (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)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index cfb2169b5..80d6355a7 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3873,8 +3873,8 @@ USA. (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) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index ddf49817e..330141942 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -46,8 +46,8 @@ USA. (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))) @@ -729,10 +729,6 @@ USA. ((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)