From: Matt Birkholz Date: Sun, 8 Mar 2015 20:25:16 +0000 (-0700) Subject: smp: without-interrupts: process.scm X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a29494f2e1f1e446b6843ec626a9a0caad6f9c0;p=mit-scheme.git smp: without-interrupts: process.scm --- diff --git a/README.txt b/README.txt index 3e7a5750c..6e68e604f 100644 --- a/README.txt +++ b/README.txt @@ -1392,11 +1392,68 @@ The hits with accompanying analysis: a bit of a misnomer. process.scm:85: (without-interrupts + Caller: subprocess-i/o-port process.scm:107: (without-interrupts (lambda () (%close-subprocess-i/o process)))) + Caller: close-subprocess-i/o process.scm:162: (without-interrupts + Caller: make-subprocess process.scm:186: (without-interrupts + Caller: subprocess-delete process.scm:214: (without-interrupts + Caller: %subprocess-status process.scm:235: (without-interrupts + Caller: subprocess-global-status-tick + handle-status-change + handle-subprocess-status-change + %handle-subprocess-status-change + test-select-descriptor + test-select-registry + anyone -- exported to ()! + + Subprocess-i/o-port and close-subprocess-i/o may be trying to + avoid other threads (who might try to cons or close the %i/o- + port too), but e.g. Edwin already ensures single-threaded use + of its subprocesses. I presumed all subprocess owners can + ensure single-threaded use, so I punted the without-interrupts + in both and moved calls to close-port before clearing the + slots. A port can safely be closed multiple times. + + These procedures may also be trying to avoid inopportune + aborts. An abort during subprocess-i/o-port may drop a port, + if rarely, but a subsequent attempt should still be possible, + opening a second i/o channel and eventually closing the first + without using it. An abort during close-subprocess-i/o is OK; + its constituents, channel-close and port-close, are OK with + aborts and multiple closes. Channel-close is atomic. Port- + close can abort after its call to channel-close; the channel + will still yield EOFs until closed again without error. + + Make-subprocess is just avoiding an abort that would drop a + new subprocess. Subprocess-finalizer serialization is enough. + Changed it to use without-interruption. + + Subprocess-delete may be trying to avoid deleting a delete + subprocess, but I presumed single-threaded use. It may also + be avoiding aborts after subprocess i/o is closed and before + the subprocess is killed, but this is not unsafe. Punted the + without-interrupts but kept the check for a previously deleted + (in the single-threaded sense) process. Subprocess-delete can + still be applied to a subprocess multiple times without error + (barring concurrent deletes). Again moved abort-savy close- + subprocess-i/o before the kill. + + %Subprocess-status must avoid an abort after updating %status + and before exit-reason. It also attempts to avoid passing the + index #f to the subprocess primitives, but the presumption of + single-threaded access guarantees this, and if the guarantee + is broken the primitive simply signals an error. Changed + without-interrupts into without-interruption. + + Subprocess-global-status-tick uses the process-status-sync-all + primitive, which is safe for concurrent use. It will only + tell one of two concurrent threads to update the global- + status-tick variable. How soon other threads observe the new + tick actually makes little difference. queue.scm:73: (without-interrupts (lambda () (queued?/unsafe queue item)))) queue.scm:76: (without-interrupts (lambda () (enqueue!/unsafe queue object)))) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index f3f38f811..a08a5bdb2 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -82,16 +82,14 @@ USA. (1d-table/remove! (subprocess-properties process) key)) (define (subprocess-i/o-port process) - (without-interrupts - (lambda () - (or (subprocess-%i/o-port process) - (let ((port - (let ((input-channel (subprocess-input-channel process)) - (output-channel (subprocess-output-channel process))) - (and (or input-channel output-channel) - (make-generic-i/o-port input-channel output-channel))))) - (set-subprocess-%i/o-port! process port) - port))))) + (or (subprocess-%i/o-port process) + (let ((port + (let ((input-channel (subprocess-input-channel process)) + (output-channel (subprocess-output-channel process))) + (and (or input-channel output-channel) + (make-generic-i/o-port input-channel output-channel))))) + (set-subprocess-%i/o-port! process port) + port))) (define (subprocess-input-port process) (let ((port (subprocess-i/o-port process))) @@ -104,28 +102,24 @@ USA. port))) (define (close-subprocess-i/o process) - (without-interrupts (lambda () (%close-subprocess-i/o process)))) - -(define (%close-subprocess-i/o process) - ;; Assumes that interrupts are locked. (cond ((subprocess-%i/o-port process) => (lambda (port) + (close-port port) (set-subprocess-%i/o-port! process #f) (set-subprocess-input-channel! process #f) - (set-subprocess-output-channel! process #f) - (close-port port)))) + (set-subprocess-output-channel! process #f)))) (cond ((subprocess-input-channel process) => (lambda (input-channel) - (set-subprocess-input-channel! process #f) - (channel-close input-channel)))) + (channel-close input-channel) + (set-subprocess-input-channel! process #f)))) (cond ((subprocess-output-channel process) => (lambda (output-channel) - (set-subprocess-output-channel! process #f) - (channel-close output-channel)))) + (channel-close output-channel) + (set-subprocess-output-channel! process #f)))) (cond ((subprocess-pty-master process) => (lambda (pty-master) - (set-subprocess-pty-master! process #f) - (channel-close pty-master))))) + (channel-close pty-master) + (set-subprocess-pty-master! process #f))))) (define (make-subprocess filename arguments environment ctty stdin stdout stderr @@ -159,7 +153,7 @@ USA. (and (cdr environment) (->namestring (cdr environment)))) (set! environment (car environment)))) - (without-interrupts + (without-interruption (lambda () (let ((index (os/make-subprocess filename arguments environment @@ -183,12 +177,10 @@ USA. process)) (define (subprocess-delete process) - (without-interrupts - (lambda () - (if (subprocess-index process) - (begin - (remove-from-gc-finalizer! subprocess-finalizer process) - (%close-subprocess-i/o process)))))) + (if (subprocess-index process) + (begin + (close-subprocess-i/o process) + (remove-from-gc-finalizer! subprocess-finalizer process)))) (define (subprocess-status process) (convert-subprocess-status (%subprocess-status process))) @@ -211,7 +203,7 @@ USA. (convert-subprocess-status status))))) (define (%subprocess-status process) - (without-interrupts + (without-interruption (lambda () (let ((index (subprocess-index process))) (if (and index ((ucode-primitive process-status-sync 1) index)) @@ -232,13 +224,11 @@ USA. tick))) (define (subprocess-global-status-tick) - (without-interrupts - (lambda () - (if ((ucode-primitive process-status-sync-all 0)) - (let ((tick (cons #f #f))) - (set! global-status-tick tick) - tick) - 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)) (define (convert-subprocess-status status) (case status