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 21e5d3e0c7efd2971a20729a9de11ecb04bc812b..51a1da8538a1d0dc2ad2f93fe8ad8b8a71247f55 100644 (file)
--- 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 af8c39a18d8c7e35cceb391727a697f5d3c29f71..e5167314848464d1c0eba07211f40cabc85263c8 100644 (file)
--- 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))
 \f
 (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 93f23e891ca1737ce913567c652301754793a52f..a73e8c5b2b431964c43a2bf09b11598a3227087a 100644 (file)
--- 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.
 \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)
@@ -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)))))))
 \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 1ac349dd50d4fa2cf4b289840d004bef51df1c40..e8263956decea38316919cde7850a10acd847797 100644 (file)
--- 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!)))