From: Matt Birkholz Date: Mon, 13 Jul 2015 22:57:03 +0000 (-0700) Subject: Remove without-interrupts from runtime/io.scm. X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~37 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dd3b544129badacf4e08a49d5d2e72790a676256;p=mit-scheme.git Remove without-interrupts from runtime/io.scm. Channel-read and channel-write used without-interrupts for atomicity, to avoid calling primitives with a channel another thread has closed. The resulting errors may have been expensive to handle, but the cheap technique of calling without-interrupts is ineffective in SMPing worlds. Assuming most channels are used by one thread and will not encounter these errors, just punt the calls to without-interrupts. Serialize modifications to the channel table (esp. channel-close) via the open-channels gc finalizer's atomic section and the new with-gc-finalizer-lock procedure. Remove tty-input-channel and tty-output-channel from general use. They are only used in a cold load initialize-package! procedure and an after-restore reset-console procedure. They are not fit for general use, creating a new channel object each time they are called, only the newest one of which is returned by descriptor->channel. Assume these procedures are only used in single threaded fashion. In open-pty-master, directory-channel-open and make-select-registry, replace without-interrupts with without-interruption to avoid dropping a channel or registry because of an inopportune abort. GC finalizers like open-channels and open-directories (and select-registry- finalizer) are already serializing. Do NOT export channel-descriptor-for-select to the () package. Assume select registries and their result vectors are used ONLY internally, in single threaded fashion, by the thread system. Punt the unnecessary and now useless calls to without-interrupts. In dld-load-file and dld-unload-file, serialize access to the dld-handles via dld-handles-mutex. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 21e5d3e0c..51a1da853 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -916,6 +916,8 @@ USA. (define-package (edwin process) (parent (edwin)) + (import (runtime primitive-io) + channel-descriptor-for-select) (export (edwin) accept-process-output add-process-filter diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm index af8c39a18..e51673148 100644 --- a/src/runtime/gcfinal.scm +++ b/src/runtime/gcfinal.scm @@ -82,30 +82,37 @@ USA. (define (remove-from-gc-finalizer! finalizer object) (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!) - (let ((procedure (gc-finalizer-procedure finalizer)) - (object? (gc-finalizer-object? finalizer)) - (object-context (gc-finalizer-object-context finalizer)) - (set-object-context! (gc-finalizer-set-object-context! finalizer))) + (let ((object? (gc-finalizer-object? finalizer))) (if (not (object? object)) (error:wrong-type-argument object "finalized object" - 'REMOVE-FROM-GC-FINALIZER!)) - (with-thread-mutex-lock (gc-finalizer-mutex finalizer) - (lambda () - (let ((context (object-context object))) - (if (not context) - (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) - (let loop ((items (gc-finalizer-items finalizer)) (prev #f)) - (if (not (pair? items)) - (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) - (if (eq? object (weak-car (car items))) - (let ((next (cdr items))) - (if prev - (set-cdr! prev next) - (set-gc-finalizer-items! finalizer next)) - (set-object-context! object #f) - (procedure context)) - (loop (cdr items) items)))))))) + 'REMOVE-FROM-GC-FINALIZER!))) + (with-thread-mutex-lock (gc-finalizer-mutex finalizer) + (lambda () + (remove-from-locked-gc-finalizer! finalizer object)))) + +(define (remove-from-locked-gc-finalizer! finalizer object) + (let ((procedure (gc-finalizer-procedure finalizer)) + (object-context (gc-finalizer-object-context finalizer)) + (set-object-context! (gc-finalizer-set-object-context! finalizer))) + (let ((context (object-context object))) + (if (not context) + (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) + (let loop ((items (gc-finalizer-items finalizer)) (prev #f)) + (if (not (pair? items)) + (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) + (if (eq? object (weak-car (car items))) + (let ((next (cdr items))) + (if prev + (set-cdr! prev next) + (set-gc-finalizer-items! finalizer next)) + (set-object-context! object #f) + (procedure context)) + (loop (cdr items) items)))))) + +(define (with-gc-finalizer-lock finalizer thunk) + (guarantee-gc-finalizer finalizer 'WITH-GC-FINALIZER-LOCK) + (with-thread-mutex-lock (gc-finalizer-mutex finalizer) thunk)) (define (remove-all-from-gc-finalizer! finalizer) (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!) diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 93f23e891..a73e8c5b2 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -93,12 +93,12 @@ USA. (eq? 'OS/2-CONSOLE type)))) (define (channel-close channel) - (without-interrupts - (lambda () - (if (channel-open? channel) - (begin - (%deregister-io-descriptor (channel-descriptor-for-select channel)) - (remove-from-gc-finalizer! open-channels channel)))))) + (with-gc-finalizer-lock open-channels + (lambda () + (if (channel-open? channel) + (begin + (%deregister-io-descriptor (channel-descriptor-for-select channel)) + (remove-from-locked-gc-finalizer! open-channels channel)))))) (define-integrable (channel-open? channel) (if (channel-descriptor channel) #t #f)) @@ -173,20 +173,13 @@ USA. (define (channel-read channel buffer start end) (let loop () - (let ((n (without-interrupts - (lambda () - (if (channel-closed? channel) - 0 - (%channel-read channel buffer start end)))))) + (let ((n (%channel-read channel buffer start end))) (if (eq? n #t) (begin (handle-subprocess-status-change) - (without-interrupts - (lambda () - (if (and (channel-open? channel) - (channel-blocking? channel)) - (loop) - #f)))) + (if (channel-blocking? channel) + (loop) + #f)) n)))) (define (%channel-read channel buffer start end) @@ -211,20 +204,13 @@ USA. (define (channel-write channel buffer start end) (let loop () - (let ((n (without-interrupts - (lambda () - (if (channel-closed? channel) - 0 - (%channel-write channel buffer start end)))))) + (let ((n (%channel-write channel buffer start end))) (if (eq? n #t) (begin (handle-subprocess-status-change) - (without-interrupts - (lambda () - (if (and (channel-open? channel) - (channel-blocking? channel)) - (loop) - #f)))) + (if (channel-blocking? channel) + (loop) + #f)) n)))) (define (%channel-write channel buffer start end) @@ -294,14 +280,11 @@ USA. (thunk))) (define (channel-table) - (without-interrupts - (lambda () - (let ((descriptors ((ucode-primitive channel-table 0)))) - (and descriptors - (vector-map (lambda (descriptor) - (or (descriptor->channel descriptor) - (make-channel descriptor))) - descriptors)))))) + (with-gc-finalizer-lock open-channels + (lambda () + (let ((descriptors ((ucode-primitive channel-table 0)))) + (and descriptors + (vector-map descriptor->channel descriptors)))))) (define (channel-synchronize channel) ((ucode-primitive channel-synchronize 1) (channel-descriptor channel))) @@ -377,14 +360,10 @@ USA. ;;;; Terminal Primitives (define (tty-input-channel) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive tty-input-channel 0)))))) + (make-channel ((ucode-primitive tty-input-channel 0)))) (define (tty-output-channel) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive tty-output-channel 0)))))) + (make-channel ((ucode-primitive tty-output-channel 0)))) (define (terminal-get-state channel) ((ucode-primitive terminal-get-state 1) (channel-descriptor channel))) @@ -440,7 +419,7 @@ USA. ;;;; PTY Master Primitives (define (open-pty-master) - (without-interrupts + (without-interruption (lambda () (let ((result ((ucode-primitive open-pty-master 0)))) (values (make-channel (vector-ref result 0)) @@ -477,7 +456,7 @@ USA. (define-guarantee directory-channel "directory channel") (define (directory-channel-open name) - (without-interrupts + (without-interruption (lambda () (add-to-gc-finalizer! open-directories (make-directory-channel @@ -525,7 +504,7 @@ USA. (length #f)) (define (make-select-registry) - (without-interrupts + (without-interruption (lambda () (add-to-gc-finalizer! select-registry-finalizer (%make-select-registry @@ -723,7 +702,7 @@ USA. (and pathname (->namestring pathname)) p) (let ((handle (make-dld-handle pathname (weak-cdr p)))) - (without-interrupts + (with-thread-mutex-lock dld-handles-mutex (lambda () (set! dld-handles (cons handle dld-handles)) (weak-set-car! p #t) @@ -736,14 +715,16 @@ USA. (weak-set-cdr! p #f))))))) (define dld-handles) +(define dld-handles-mutex) (define (reset-dld-handles!) (set! dld-handles '()) + (set! dld-handles-mutex (make-thread-mutex)) unspecific) (define (dld-unload-file handle) (guarantee-dld-handle handle 'DLD-UNLOAD-FILE) - (without-interrupts + (with-thread-mutex-lock dld-handles-mutex (lambda () (%dld-unload-file handle) (set! dld-handles (delq! handle dld-handles)) @@ -769,7 +750,11 @@ USA. (pathname=? pathname* pathname)))))) (define (find-dld-handle predicate) - (find-matching-item dld-handles predicate)) + (with-thread-mutex-lock dld-handles-mutex + (lambda () + (find-matching-item dld-handles predicate)))) (define (all-dld-handles) - (list-copy dld-handles)) \ No newline at end of file + (with-thread-mutex-lock dld-handles-mutex + (lambda () + (list-copy dld-handles)))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 1ac349dd5..e8263956d 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -896,6 +896,9 @@ USA. ((nt) (extend-package (runtime os-primitives) (files "ntprm") + (import (runtime primitive-io) + channel-descriptor-for-select + tty-input-channel) (export () console-channel-descriptor delete-environment-variable! @@ -1402,6 +1405,9 @@ USA. (define-package (runtime console-i/o-port) (files "ttyio") (parent (runtime)) + (import (runtime primitive-io) + tty-input-channel + tty-output-channel) (export () console-i/o-port console-i/o-port? @@ -3221,7 +3227,6 @@ USA. channel-blocking? channel-close channel-closed? - channel-descriptor-for-select channel-file-length channel-file-position channel-file-set-position @@ -3297,8 +3302,6 @@ USA. terminal-set-state test-for-io-on-channel test-for-io-on-descriptor - tty-input-channel - tty-output-channel with-channel-blocking) (export (runtime emacs-interface) channel-descriptor) @@ -3321,6 +3324,9 @@ USA. test-select-registry) (import (runtime thread) %deregister-io-descriptor) + (import (runtime gc-finalizer) + with-gc-finalizer-lock + remove-from-locked-gc-finalizer!) (export (runtime directory) directory-channel/descriptor) (initialization (initialize-package!)))