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))
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)));
}
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
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)));
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)));
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
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))));
}
\f
(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))
\f
(define (remove-all-from-gc-finalizer! finalizer)
(guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
(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))
\f
(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)
(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)
(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)))
;;;; 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)))
;;;; 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))
(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
(length #f))
(define (make-select-registry)
- (without-interrupts
+ (without-interruption
(lambda ()
(add-to-gc-finalizer! select-registry-finalizer
(%make-select-registry
(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)
(weak-set-cdr! p #f)))))))
\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))
(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
((nt)
(extend-package (runtime os-primitives)
(files "ntprm")
+ (import (runtime primitive-io)
+ channel-descriptor-for-select)
(export ()
console-channel-descriptor
delete-environment-variable!
(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?
channel-blocking?
channel-close
channel-closed?
- channel-descriptor-for-select
channel-file-length
channel-file-position
channel-file-set-position
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)
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!)))
(%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")
(%maybe-toggle-thread-timer)
(%maybe-wake-io-waiter))))
(lambda ()
- (%suspend-current-thread)
+ (suspend-current-thread)
result)
(lambda ()
(with-threads-locked
(%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)
(else
(dloop (dentry/next dentry)))))
(%maybe-toggle-thread-timer)
- (%maybe-wake-io-waiter)
- (%unlock))
+ (%maybe-wake-io-waiter))
\f
(define (%register-io-thread-event descriptor mode tentry front?)
(assert-locked '%register-io-thread-event)
projects / mit-scheme.git / commitdiff