From 70104f4c78d9e780e15f74dd7b16e1f2b2d3d3f5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 10 Mar 1991 22:43:02 +0000 Subject: [PATCH] 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. --- v7/src/runtime/io.scm | 70 ++++++++++++++++++++++++++++++-------- v7/src/runtime/runtime.pkg | 30 +++++++++------- v7/src/runtime/uerror.scm | 34 +++++++++++------- v7/src/runtime/version.scm | 4 +-- v8/src/runtime/runtime.pkg | 30 +++++++++------- 5 files changed, 114 insertions(+), 54 deletions(-) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 1790c2081..5ed9885a6 100644 --- 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. |# ;;;; 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))) + (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)))))))))) ;;;; File Primitives diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index cf1323ee1..edf17dfde 100644 --- 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 630bba320..333552fa6 100644 --- 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))))))))) ;;;; FASLOAD Errors diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index cbcef9adf..3cbd4eb15 100644 --- 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 db67c06d5..b5f7c5840 100644 --- 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) -- 2.25.1