Change method by which port errors are signalled. Previously a

condition handler was bound for every I/O operation, which made I/O
painfully slow as each binding cost at least one hundred machine
instructions.  Now, an I/O channel can have an associated port, and
when a system-call error occurs, the file descriptor associated with
the error is mapped back to the associated port, if any, and a port
error is signalled instead.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 1790c20814f07015ddf5f92a1ef4031f09debef8..5ed9885a6d2dfffaa2804f2d7f6516579118e871 100644 (file)
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.20 1991/03/01 22:12:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.21 1991/03/10 22:42:23 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -52,7 +52,8 @@ MIT in each case. |#
   ;; object in order to determine when all references to it have been
   ;; dropped.  Second, the structure provides a type predicate.
   descriptor
-  (type false read-only true))
+  (type false read-only true)
+  port)
 
 (define (make-channel descriptor)
   ;; Make sure that interrupts are disabled before `descriptor' is
@@ -67,7 +68,8 @@ MIT in each case. |#
                       TCP-SERVER-SOCKET DIRECTORY CHARACTER-DEVICE
                       BLOCK-DEVICE)))
            (and (< type (vector-length types))
-                (vector-ref types type))))))
+                (vector-ref types type)))
+         false)))
     (with-absolutely-no-interrupts
      (lambda ()
        (set-cdr! open-channels-list
@@ -78,12 +80,11 @@ MIT in each case. |#
     channel))
 
 (define (descriptor->channel descriptor)
-  (or (let loop ((channels (cdr open-channels-list)))
-       (and (not (null? channels))
-            (if (= descriptor (system-pair-cdr (car channels)))
-                (system-pair-car (car channels))
-                (loop (cdr channels)))))
-      (make-channel descriptor)))
+  (let loop ((channels (cdr open-channels-list)))
+    (and (not (null? channels))
+        (if (fix:= descriptor (system-pair-cdr (car channels)))
+            (system-pair-car (car channels))
+            (loop (cdr channels))))))
 
 (define-integrable (channel-type=unknown? channel)
   (false? (channel-type channel)))
@@ -182,6 +183,47 @@ MIT in each case. |#
 \f
 ;;;; Channel Primitives
 
+(define (port-error-test operator operands)
+  ;; If the performance of this `memq' is a problem, change this to
+  ;; use a string hash table based on the primitive name.
+  (and (memq operator channel-primitives)
+       (not (null? operands))
+       (let ((descriptor (car operands)))
+        (and (exact-nonnegative-integer? descriptor)
+             (let ((channel (descriptor->channel descriptor)))
+               (and channel
+                    (channel-port channel)))))))
+
+(define channel-primitives
+  (list (ucode-primitive channel-blocking 1)
+       (ucode-primitive channel-blocking? 1)
+       (ucode-primitive channel-close 1)
+       (ucode-primitive channel-nonblocking 1)
+       (ucode-primitive channel-read 4)
+       (ucode-primitive channel-write 4)
+       (ucode-primitive file-length-new 1)
+       (ucode-primitive file-position 1)
+       (ucode-primitive file-set-position 2)
+       (ucode-primitive pty-master-continue 1)
+       (ucode-primitive pty-master-interrupt 1)
+       (ucode-primitive pty-master-kill 1)
+       (ucode-primitive pty-master-quit 1)
+       (ucode-primitive pty-master-send-signal 2)
+       (ucode-primitive pty-master-stop 1)
+       (ucode-primitive terminal-buffered 1)
+       (ucode-primitive terminal-buffered? 1)
+       (ucode-primitive terminal-cooked-output 1)
+       (ucode-primitive terminal-cooked-output? 1)
+       (ucode-primitive terminal-drain-output 1)
+       (ucode-primitive terminal-flush-input 1)
+       (ucode-primitive terminal-flush-output 1)
+       (ucode-primitive terminal-get-ispeed 1)
+       (ucode-primitive terminal-get-ospeed 1)
+       (ucode-primitive terminal-get-state 1)
+       (ucode-primitive terminal-nonbuffered 1)
+       (ucode-primitive terminal-raw-output 1)
+       (ucode-primitive terminal-set-state 2)))
+\f
 (define (channel-read channel buffer start end)
   ((ucode-primitive channel-read 4) (channel-descriptor channel)
                                    buffer start end))
@@ -243,12 +285,10 @@ MIT in each case. |#
      (lambda ()
        (let ((descriptors ((ucode-primitive channel-table 0))))
         (and descriptors
-             (vector-map descriptors descriptor->channel)))))))
-
-(define (bind-port-for-errors port thunk)
-  (bind-condition-handler (list condition-type:error)
-      (lambda (condition) (error:derived-port port condition))
-    thunk))
+             (vector-map descriptors
+               (lambda (descriptor)
+                 (or (descriptor->channel descriptor)
+                     (make-channel descriptor))))))))))
 \f
 ;;;; File Primitives
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cf1323ee153e13abbb1435766adda082bdd6be29..edf17dfde9d2f7e43edcb41d1975cf04fd31569b 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.96 1991/03/09 21:33:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.97 1991/03/10 22:42:32 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -1463,6 +1463,7 @@ MIT in each case. |#
          channel-blocking?
          channel-close
          channel-nonblocking
+         channel-port
          channel-read
          channel-read-block
          channel-table
@@ -1518,7 +1519,6 @@ MIT in each case. |#
   (export (runtime subprocess)
          channel-descriptor)
   (export (runtime generic-input)
-         bind-port-for-errors
          input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
@@ -1533,9 +1533,9 @@ MIT in each case. |#
          input-buffer/read-until-delimiter
          input-buffer/set-size
          input-buffer/size
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime generic-output)
-         bind-port-for-errors
          make-output-buffer
          output-buffer/buffered-chars
          output-buffer/channel
@@ -1543,16 +1543,18 @@ MIT in each case. |#
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
-         output-buffer/write-string-block)
+         output-buffer/write-char-block
+         output-buffer/write-string-block
+         set-channel-port!)
   (export (runtime file-input)
-         bind-port-for-errors
          input-buffer/chars-remaining
          input-buffer/read-substring
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime file-output)
-         make-output-buffer)
+         make-output-buffer
+         set-channel-port!)
   (export (runtime console-input)
-         bind-port-for-errors
          input-buffer/buffer-contents
          input-buffer/buffered-chars
          input-buffer/channel
@@ -1563,16 +1565,20 @@ MIT in each case. |#
          input-buffer/set-buffer-contents
          input-buffer/set-size
          input-buffer/size
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime console-output)
-         bind-port-for-errors
          make-output-buffer
          output-buffer/buffered-chars
          output-buffer/channel
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
-         output-buffer/write-string-block)
+         output-buffer/write-char-block
+         output-buffer/write-string-block
+         set-channel-port!)
+  (export (runtime microcode-errors)
+         port-error-test)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)

diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm
index 630bba3203acc8c008a02651be069bc74694909c..333552fa62b1b103b2bf5abf0e4114fde466b08d 100644 (file)
--- a/v7/src/runtime/uerror.scm
+++ b/v7/src/runtime/uerror.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.20 1991/02/22 21:15:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.21 1991/03/10 22:42:53 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -634,23 +634,31 @@ MIT in each case. |#
       (write-string "." port))))
 
 (define-low-level-handler 'SYSTEM-CALL
-  (let ((signal
-        (condition-signaller condition-type:system-call-error
-                             '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE))))
+  (let ((make-condition
+        (condition-constructor condition-type:system-call-error
+                               '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE))))
     (lambda (continuation error-code)
       (let ((frame (continuation/first-subproblem continuation)))
        (if (and (apply-frame? frame)
                 (vector? error-code)
                 (= 3 (vector-length error-code)))
-           (signal continuation
-                   (apply-frame/operator frame)
-                   (apply-frame/operands frame)
-                   (let ((system-call (vector-ref error-code 2)))
-                     (or (microcode-system-call/code->name system-call)
-                         system-call))
-                   (let ((error-type (vector-ref error-code 1)))
-                     (or (microcode-system-call-error/code->name error-type)
-                         error-type))))))))
+           (let ((operator (apply-frame/operator frame))
+                 (operands (apply-frame/operands frame)))
+             (let ((condition
+                    (make-condition
+                     continuation
+                     operator
+                     operands
+                     (let ((system-call (vector-ref error-code 2)))
+                       (or (microcode-system-call/code->name system-call)
+                           system-call))
+                     (let ((error-type (vector-ref error-code 1)))
+                       (or (microcode-system-call-error/code->name error-type)
+                           error-type))))
+                   (port (port-error-test operator operands)))
+               (if port
+                   (error:derived-port port condition)
+                   (error condition)))))))))
 \f
 ;;;; FASLOAD Errors
 

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index cbcef9adf73cdf28938622a98061a18d9ff587ee..3cbd4eb154ff3661a2afec07559da0de82f092d2 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.110 1991/03/09 21:33:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.111 1991/03/10 22:43:02 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 110))
+  (add-identification! "Runtime" 14 111))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index db67c06d5828d682ff714555dc151bd648543728..b5f7c58407e517b8b0cf46d9396794ddc8e10196 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.96 1991/03/09 21:33:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.97 1991/03/10 22:42:32 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -1463,6 +1463,7 @@ MIT in each case. |#
          channel-blocking?
          channel-close
          channel-nonblocking
+         channel-port
          channel-read
          channel-read-block
          channel-table
@@ -1518,7 +1519,6 @@ MIT in each case. |#
   (export (runtime subprocess)
          channel-descriptor)
   (export (runtime generic-input)
-         bind-port-for-errors
          input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
@@ -1533,9 +1533,9 @@ MIT in each case. |#
          input-buffer/read-until-delimiter
          input-buffer/set-size
          input-buffer/size
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime generic-output)
-         bind-port-for-errors
          make-output-buffer
          output-buffer/buffered-chars
          output-buffer/channel
@@ -1543,16 +1543,18 @@ MIT in each case. |#
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
-         output-buffer/write-string-block)
+         output-buffer/write-char-block
+         output-buffer/write-string-block
+         set-channel-port!)
   (export (runtime file-input)
-         bind-port-for-errors
          input-buffer/chars-remaining
          input-buffer/read-substring
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime file-output)
-         make-output-buffer)
+         make-output-buffer
+         set-channel-port!)
   (export (runtime console-input)
-         bind-port-for-errors
          input-buffer/buffer-contents
          input-buffer/buffered-chars
          input-buffer/channel
@@ -1563,16 +1565,20 @@ MIT in each case. |#
          input-buffer/set-buffer-contents
          input-buffer/set-size
          input-buffer/size
-         make-input-buffer)
+         make-input-buffer
+         set-channel-port!)
   (export (runtime console-output)
-         bind-port-for-errors
          make-output-buffer
          output-buffer/buffered-chars
          output-buffer/channel
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
-         output-buffer/write-string-block)
+         output-buffer/write-char-block
+         output-buffer/write-string-block
+         set-channel-port!)
+  (export (runtime microcode-errors)
+         port-error-test)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)