From: Matt Birkholz Date: Fri, 6 Mar 2015 21:51:29 +0000 (-0700) Subject: smp: without-interrupts: io.scm X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dbb1583;p=mit-scheme.git smp: without-interrupts: io.scm --- diff --git a/README.txt b/README.txt index 62a486328..ff601a0e5 100644 --- a/README.txt +++ b/README.txt @@ -1248,23 +1248,99 @@ The hits with accompanying analysis: load. io.scm:96: (without-interrupts + Caller: channel-close io.scm:176: (let ((n (without-interrupts + Caller: channel-read io.scm:184: (without-interrupts + Caller: channel-read io.scm:214: (let ((n (without-interrupts + Caller: channel-write io.scm:222: (without-interrupts + Caller: channel-write io.scm:297: (without-interrupts + Caller: channel-table io.scm:380: (without-interrupts + Caller: tty-input-channel io.scm:385: (without-interrupts + Caller: tty-output-channel io.scm:443: (without-interrupts + Caller: open-pty-master io.scm:480: (without-interrupts + Caller: directory-channel-open io.scm:528: (without-interrupts + Caller: make-select-registry io.scm:665: (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + Caller: allocate-select-registry-result-vectors io.scm:675: (set-interrupt-enables! interrupt-mask) + Caller: allocate-select-registry-result-vectors io.scm:681: (set-interrupt-enables! interrupt-mask) + Caller: allocate-select-registry-result-vectors io.scm:686: (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + Caller: deallocate-select-registry-result-vectors io.scm:696: (set-interrupt-enables! interrupt-mask))) + Caller: deallocate-select-registry-result-vectors io.scm:734: (without-interrupts + Caller: dld-load-file io.scm:754: (without-interrupts + Caller: dld-unload-file + + OK. The channel-{close,read,write} procedures were using + without-interrupts with the explicit assumption that an atomic + section was produced. The aim was to avoid calling the lower + level routines (channel-blocking?, %channel-read) with a + closed channel. The resulting errors were unhelpful. The + desired result was for the reads and writes to "succeed" with + zero characters transferred. + + The ineffectual calls to without-interrupts were removed and + the primitives that might get a closed channel were fixed to + return a value rather than signal an error condition. + + Another problem was that closing a channel whose descriptor is + in io-registry could get the thread system wedged with + recursive errors from test-select-registry. Channel-close now + does the deed inside the open-channels gc-finalizer's atomic + section (via a new with-gc-finalizer-locked procedure) to + ensure that another channel-close (or -open) is not running + simultaneously. The deed is also done with the thread system + locked so that any woken threads cannot get access to the + channel before is marked closed. + + If a pthread closes a channel upon which a second pthread has + blocked in poll/select, the behavior (unblock the second + pthread or not) is unspecified, but %deregister-io-descriptor + takes care to signal the io-waiter -- the only processor that + should be blocked in test-select-registry. + + Channel-table may now return #f if it sees a descriptor + without a channel. + + The tty-{input,output}-channel procedures are only used in a + cold load initialize-package! procedure and an after-restore + reset-console procedure. They do not seem 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. Removed both from the exports to package () and + assumed they are used in single threaded fashion. + + Open-pty-master, directory-channel-open and make-select- + registry were just trying to avoid aborts that would leak a + channel or select registry descriptor. They now use + without-interruption. Add-to-gc-finalizer! and make-gc- + finalized-object explicitly serialize access to open-channels, + open-directories and select-registry-finalizer. + + {Allocate,Deallocate}-select-registry-result-vectors are used + by test-select-registry which is not exported to (), just to + (runtime thread) where it is already used only while the + thread system is locked. Punted the useless and unnecessary + without-interrupts which (no longer) ensure atomic access to + the select-registry-result-vectors cache. If select + registries are ever exported to (), the cache could simply be + eliminated. + + Dld-{load,unload}-file now serialize access to dld-handles via + dld-handles-mutex. make.scm:32:((ucode-primitive set-interrupt-enables!) 0) make.scm:96:(define-integrable with-interrupt-mask (ucode-primitive with-interrupt-mask)) diff --git a/src/microcode/prntio.c b/src/microcode/prntio.c index 652308fcd..1a753fe27 100644 --- a/src/microcode/prntio.c +++ b/src/microcode/prntio.c @@ -48,6 +48,8 @@ static long wait_for_multiple_objects_1 (unsigned long, Tchannel *, long, int); DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0) { PRIMITIVE_HEADER (1); + if ((ARG_REF (1)) == SHARP_F) + PRIMITIVE_RETURN (SHARP_F); /* Channel extraordinarily recently closed. */ PRIMITIVE_RETURN (ulong_to_integer (arg_channel (1))); } diff --git a/src/microcode/pros2io.c b/src/microcode/pros2io.c index a95bc2311..263778161 100644 --- a/src/microcode/pros2io.c +++ b/src/microcode/pros2io.c @@ -40,6 +40,8 @@ DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-LUB", Prim_OS2_select_registry_lub, 0, 0, DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0) { PRIMITIVE_HEADER (1); + if ((ARG_REF (1)) == SHARP_F) + PRIMITIVE_RETURN (SHARP_F); /* Channel extraordinarily recently closed. */ { Tchannel channel = (arg_channel (1)); PRIMITIVE_RETURN diff --git a/src/microcode/prosio.c b/src/microcode/prosio.c index ea14020f5..795aeeb82 100644 --- a/src/microcode/prosio.c +++ b/src/microcode/prosio.c @@ -159,6 +159,9 @@ Attempt to fill that substring unless end-of-file is reached.\n\ Return the number of characters actually read from CHANNEL.") { PRIMITIVE_HEADER (4); + if ((ARG_REF (1)) == SHARP_F) + /* Channel extraordinarily recently closed. */ + PRIMITIVE_RETURN (FIXNUM_ZERO); { unsigned long length; unsigned char * buffer = (arg_extended_string (2, (&length))); @@ -177,6 +180,9 @@ DEFINE_PRIMITIVE ("CHANNEL-WRITE", Prim_channel_write, 4, 4, Third and fourth args START and END specify the substring to use.") { PRIMITIVE_HEADER (4); + if ((ARG_REF (1)) == SHARP_F) + /* Channel extraordinarily recently closed. */ + PRIMITIVE_RETURN (FIXNUM_ZERO); { unsigned long length; const unsigned char * buffer = (arg_extended_string (2, (&length))); @@ -197,6 +203,8 @@ If CHANNEL can be put in non-blocking mode, #T is returned.\n\ If it cannot, 0 is returned.") { PRIMITIVE_HEADER (1); + if ((ARG_REF (1)) == SHARP_F) + PRIMITIVE_RETURN (SHARP_F); /* Channel extraordinarily recently closed. */ { int result = (OS_channel_nonblocking_p (arg_channel (1))); PRIMITIVE_RETURN diff --git a/src/microcode/pruxio.c b/src/microcode/pruxio.c index de3193bc2..7b90e5cda 100644 --- a/src/microcode/pruxio.c +++ b/src/microcode/pruxio.c @@ -42,6 +42,8 @@ static const char ** convert_string_vector (SCHEME_OBJECT vector); DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0) { PRIMITIVE_HEADER (1); + if ((ARG_REF (1)) == SHARP_F) + PRIMITIVE_RETURN (SHARP_F); /* Channel extraordinarily recently closed. */ PRIMITIVE_RETURN (long_to_integer (UX_channel_descriptor (arg_channel (1)))); } diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm index 18b0da65c..de36bc379 100644 --- a/src/runtime/gcfinal.scm +++ b/src/runtime/gcfinal.scm @@ -82,30 +82,39 @@ USA. (define (remove-from-gc-finalizer! finalizer object) (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-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-locked (gc-finalizer-mutex finalizer) + (lambda () + (remove-from-locked-gc-finalizer! finalizer object)))) + +(define (remove-from-locked-gc-finalizer! finalizer object) + ;;(assert-locked 'REMOVE-FROM-LOCKED-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))) - (if (not (object? object)) - (error:wrong-type-argument object - "finalized object" - 'REMOVE-FROM-GC-FINALIZER!)) - (with-thread-mutex-locked (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)))))))) + (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-locked finalizer thunk) + (guarantee-gc-finalizer finalizer 'WITH-GC-FINALIZER-LOCKED) + (with-thread-mutex-locked (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 70cca085f..84481bcaa 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -93,12 +93,14 @@ USA. (eq? 'OS/2-CONSOLE type)))) (define (channel-close channel) - (without-interrupts + (with-gc-finalizer-locked + open-channels (lambda () (if (channel-open? channel) - (begin - (%deregister-io-descriptor (channel-descriptor-for-select channel)) - (remove-from-gc-finalizer! open-channels channel)))))) + (%deregister-io-descriptor + (channel-descriptor-for-select channel) + (lambda () + (remove-from-locked-gc-finalizer! open-channels channel))))))) (define-integrable (channel-open? channel) (if (channel-descriptor channel) #t #f)) @@ -173,20 +175,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 +206,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 +282,9 @@ 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)))))) + (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 @@ -731,7 +710,7 @@ USA. (and pathname (->namestring pathname)) p) (let ((handle (make-dld-handle pathname (weak-cdr p)))) - (without-interrupts + (with-thread-mutex-locked dld-handles-mutex (lambda () (set! dld-handles (cons handle dld-handles)) (weak-set-car! p #t) @@ -744,14 +723,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-locked dld-handles-mutex (lambda () (%dld-unload-file handle) (set! dld-handles (delq! handle dld-handles)) @@ -777,7 +758,11 @@ USA. (pathname=? pathname* pathname)))))) (define (find-dld-handle predicate) - (find-matching-item dld-handles predicate)) + (with-thread-mutex-locked 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-locked 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 930127b99..0a924dc04 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -877,6 +877,8 @@ USA. ((nt) (extend-package (runtime os-primitives) (files "ntprm") + (import (runtime primitive-io) + channel-descriptor-for-select) (export () console-channel-descriptor delete-environment-variable! @@ -1383,6 +1385,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? @@ -3197,7 +3202,6 @@ USA. channel-blocking? channel-close channel-closed? - channel-descriptor-for-select channel-file-length channel-file-position channel-file-set-position @@ -3273,8 +3277,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) @@ -3299,6 +3301,9 @@ USA. test-select-registry) (import (runtime thread) %deregister-io-descriptor) + (import (runtime gc-finalizer) + with-gc-finalizer-locked + remove-from-locked-gc-finalizer!) (export (runtime directory) directory-channel/descriptor) (initialization (initialize-package!))) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index c987ee09b..70ad67128 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -343,14 +343,13 @@ USA. (%unlock)) (define (suspend-current-thread) - (without-interrupts %suspend-current-thread)) - -(define (%suspend-current-thread) - (let* ((id (%id)) - (thread (%current-thread id))) - (%trace ";"id" %suspend-current-thread "thread"\n") - (%lock) - (%suspend-thread thread))) + (without-interrupts + (lambda () + (let* ((id (%id)) + (thread (%current-thread id))) + (%trace ";"id" suspend-current-thread "thread"\n") + (%lock) + (%suspend-thread thread))))) (define (%suspend-thread thread) (%trace ";"(%%id)" %suspend-thread "thread"\n") @@ -761,7 +760,7 @@ USA. (%maybe-toggle-thread-timer) (%maybe-wake-io-waiter)))) (lambda () - (%suspend-current-thread) + (suspend-current-thread) result) (lambda () (with-threads-locked @@ -843,8 +842,25 @@ USA. (%maybe-toggle-thread-timer) (%maybe-wake-io-waiter)))) -(define (%deregister-io-descriptor descriptor) - (%lock) +(define (%deregister-io-descriptor descriptor-for-select close!) + ;; CLOSE! is applied while the thread system is locked, + ;; after any threads waiting on the descriptor are woken and the + ;; io-waiter signaled, but before they can examine the channel. + ;; CLOSE! is assumed to call the relevant OS primitive and mark the + ;; channel as closed. + (let ((error? + (with-threads-locked + (lambda () + (%%deregister-io-descriptor descriptor-for-select) + (ignore-errors + (lambda () + (close!) + #f)))))) + (if error? + (signal-condition error?)))) + +(define (%%deregister-io-descriptor descriptor) + (assert-locked '%%deregister-io-descriptor) (let dloop ((dentry io-registrations)) (cond ((not dentry) unspecific) @@ -871,8 +887,7 @@ USA. (else (dloop (dentry/next dentry))))) (%maybe-toggle-thread-timer) - (%maybe-wake-io-waiter) - (%unlock)) + (%maybe-wake-io-waiter)) (define (%register-io-thread-event descriptor mode tentry front?) (assert-locked '%register-io-thread-event)