From c47b72d837c8be46a982fe90bba06197d553c28b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 18 May 1996 06:16:11 +0000 Subject: [PATCH] Change mechanism used to open files and sockets, so that interrupts are enabled during the open. This is necessary, because any network-based operation could potentially hang for long periods of time, and it's desirable for the user to be able to interrupt out of the operation. This change requires microcode version 11.154 (or the corresponding version 13). In addition to this change, the low-level channel code was changed to eliminate the now-obsolete gc-daemon interlocking code. --- v7/src/runtime/io.scm | 186 +++++++++++++++++-------------------- v7/src/runtime/runtime.pkg | 4 +- v7/src/runtime/socket.scm | 56 ++++++----- v7/src/runtime/version.scm | 4 +- v8/src/runtime/runtime.pkg | 4 +- 5 files changed, 116 insertions(+), 138 deletions(-) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 216f4e4c8..bc5760444 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: io.scm,v 14.47 1996/05/15 18:47:19 cph Exp $ +$Id: io.scm,v 14.48 1996/05/18 06:15:16 cph Exp $ Copyright (c) 1988-96 Massachusetts Institute of Technology @@ -38,13 +38,11 @@ MIT in each case. |# (declare (usual-integrations)) (define open-channels-list) -(define traversing?) (define open-directories-list) (define have-select?) (define (initialize-package!) (set! open-channels-list (list 'OPEN-CHANNELS-LIST)) - (set! traversing? false) (add-gc-daemon! close-lost-open-files-daemon) (set! open-directories-list (make-protection-list)) (add-gc-daemon! close-lost-open-directories-daemon) @@ -60,18 +58,34 @@ MIT in each case. |# (type false read-only true) port) +(define (open-channel procedure) + ;; A bunch of hair to permit microcode descriptors be opened with + ;; interrupts turned on, yet not leave a dangling descriptor around + ;; if the open is interrupted before the runtime system's data + ;; structures are updated. + (let ((p (system-pair-cons (ucode-type weak-cons) #f #f))) + (dynamic-wind + (lambda () unspecific) + (lambda () + (and (procedure p) + (make-channel-1 p))) + (lambda () + (if (and (not (system-pair-car p)) (system-pair-cdr p)) + (begin + ((ucode-primitive channel-close 1) (system-pair-cdr p)) + (system-pair-set-cdr! p #f))))))) + (define (make-channel descriptor) - ;; Make sure that interrupts are disabled before `descriptor' is - ;; created until after this procedure returns. + (make-channel-1 (system-pair-cons (ucode-type weak-cons) #f descriptor))) + +(define (make-channel-1 p) (let ((channel - (%make-channel descriptor (descriptor-type-name descriptor) #f))) - (with-absolutely-no-interrupts + (let ((d (system-pair-cdr p))) + (%make-channel d (descriptor-type-name d) #f)))) + (without-interrupts (lambda () - (set-cdr! open-channels-list - (cons (system-pair-cons (ucode-type weak-cons) - channel - descriptor) - (cdr open-channels-list))))) + (system-pair-set-car! p channel) + (set-cdr! open-channels-list (cons p (cdr open-channels-list))))) channel)) (define (descriptor->channel descriptor) @@ -81,23 +95,10 @@ MIT in each case. |# (system-pair-car (car channels)) (loop (cdr channels)))))) -(define descriptor-type-name - (let ((channel-type-name (ucode-primitive channel-type-name 1)) - (channel-type (ucode-primitive channel-type 1))) - (lambda (descriptor) - (if (implemented-primitive-procedure? channel-type-name) - (let ((name (channel-type-name descriptor))) - (and name - (intern name))) - ;; For upwards compatibility with old microcodes: - (let ((index (channel-type descriptor)) - (types - '#(#F FILE UNIX-PIPE UNIX-FIFO TERMINAL - UNIX-PTY-MASTER UNIX-STREAM-SOCKET - TCP-STREAM-SOCKET TCP-SERVER-SOCKET DIRECTORY - UNIX-CHARACTER-DEVICE UNIX-BLOCK-DEVICE))) - (and (< index (vector-length types)) - (vector-ref types index))))))) +(define (descriptor-type-name descriptor) + (let ((name ((ucode-primitive channel-type-name 1) descriptor))) + (and name + (intern name)))) (define-integrable (channel-type=unknown? channel) (false? (channel-type channel))) @@ -115,27 +116,21 @@ MIT in each case. |# (eq? 'OS/2-CONSOLE type)))) (define (channel-close channel) - ;; This is locked from interrupts, but GC can occur since the - ;; procedure itself hangs on to the channel until the last moment, - ;; when it returns the channel's name. The list will not be spliced - ;; by the daemon behind its back because of the traversing? flag. - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (if (channel-descriptor channel) - (begin - ((ucode-primitive channel-close 1) (channel-descriptor channel)) - (set-channel-descriptor! channel false) - (let loop - ((l1 open-channels-list) - (l2 (cdr open-channels-list))) - (cond ((null? l2) - (set! traversing? false) - (error "CHANNEL-CLOSE: lost channel" channel)) - ((eq? channel (system-pair-car (car l2))) - (set-cdr! l1 (cdr l2))) - (else - (loop l2 (cdr l2))))))))))) + (without-interrupts + (lambda () + (if (channel-descriptor channel) + (begin + ((ucode-primitive channel-close 1) (channel-descriptor channel)) + (set-channel-descriptor! channel false) + (let loop + ((l1 open-channels-list) + (l2 (cdr open-channels-list))) + (cond ((null? l2) + (error "CHANNEL-CLOSE: lost channel" channel)) + ((eq? channel (system-pair-car (car l2))) + (set-cdr! l1 (cdr l2))) + (else + (loop l2 (cdr l2)))))))))) (define-integrable (channel-open? channel) (channel-descriptor channel)) @@ -147,49 +142,38 @@ MIT in each case. |# (close-all-open-files-internal (ucode-primitive channel-close 1))) (define (primitive-io/reset!) - ;; This is invoked after disk-restoring. It "cleans" the new runtime system. + ;; This is invoked after disk-restoring. + ;; It "cleans" the new runtime system. (close-all-open-files-internal (lambda (ignore) ignore)) (drop-all-protected-objects open-directories-list) (set! have-select? ((ucode-primitive have-select? 0))) unspecific) (define (close-all-open-files-internal action) - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (let loop ((l (cdr open-channels-list))) - (if (not (null? l)) - (begin - (let ((channel (system-pair-car (car l)))) - (if channel - (set-channel-descriptor! channel false))) - (action (system-pair-cdr (car l))) - (let ((l (cdr l))) - (set-cdr! open-channels-list l) - (loop l))))))))) - -;;; This is the daemon which closes files which no one points to. -;;; Runs with GC, and lower priority interrupts, disabled. -;;; It is unsafe because of the (unnecessary) consing by the -;;; interpreter while it executes the loop. - -;;; Replaced by a primitive installed below. -#| -(define (close-lost-open-files-daemon) - (if (not traversing?) - (let loop ((l1 open-channels-list) (l2 (cdr open-channels-list))) - (cond ((null? l2) - true) - ((system-pair-car (car l2)) - (loop l2 (cdr l2))) - (else - ((ucode-primitive channel-close 1) (system-pair-cdr (car l2))) - (set-cdr! l1 (cdr l2)) - (loop l1 (cdr l1))))))) -|# + (without-interrupts + (lambda () + (let loop ((l (cdr open-channels-list))) + (if (not (null? l)) + (begin + (let ((channel (system-pair-car (car l)))) + (if channel + (set-channel-descriptor! channel false))) + (action (system-pair-cdr (car l))) + (let ((l (cdr l))) + (set-cdr! open-channels-list l) + (loop l)))))))) + (define (close-lost-open-files-daemon) - (if (not traversing?) - ((ucode-primitive close-lost-open-files 1) open-channels-list))) + ;; This is the daemon that closes files that no one points to. + (let loop ((l1 open-channels-list) (l2 (cdr open-channels-list))) + (cond ((null? l2) + unspecific) + ((system-pair-car (car l2)) + (loop l2 (cdr l2))) + (else + ((ucode-primitive channel-close 1) (system-pair-cdr (car l2))) + (set-cdr! l1 (cdr l2)) + (loop l1 (cdr l1)))))) ;;;; Channel Primitives @@ -325,23 +309,19 @@ MIT in each case. |# (thunk))) (define (channel-table) - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (let ((descriptors ((ucode-primitive channel-table 0)))) - (and descriptors - (vector-map descriptors - (lambda (descriptor) - (or (descriptor->channel descriptor) - (make-channel descriptor)))))))))) + (without-interrupts + (lambda () + (let ((descriptors ((ucode-primitive channel-table 0)))) + (and descriptors + (vector-map descriptors + (lambda (descriptor) + (or (descriptor->channel descriptor) + (make-channel descriptor))))))))) ;;;; File Primitives (define (file-open primitive filename) - (let ((channel - (without-interrupts - (lambda () - (make-channel (primitive filename)))))) + (let ((channel (open-channel (lambda (p) (primitive filename p))))) (if (or (channel-type=directory? channel) (channel-type=unknown? channel)) (begin @@ -350,16 +330,16 @@ MIT in each case. |# channel)) (define (file-open-input-channel filename) - (file-open (ucode-primitive file-open-input-channel 1) filename)) + (file-open (ucode-primitive new-file-open-input-channel 2) filename)) (define (file-open-output-channel filename) - (file-open (ucode-primitive file-open-output-channel 1) filename)) + (file-open (ucode-primitive new-file-open-output-channel 2) filename)) (define (file-open-io-channel filename) - (file-open (ucode-primitive file-open-io-channel 1) filename)) + (file-open (ucode-primitive new-file-open-io-channel 2) filename)) (define (file-open-append-channel filename) - (file-open (ucode-primitive file-open-append-channel 1) filename)) + (file-open (ucode-primitive new-file-open-append-channel 2) filename)) (define (channel-file-length channel) ((ucode-primitive file-length-new 1) (channel-descriptor channel))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 5a81bd4cf..632fca3b2 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.270 1996/05/14 00:53:56 cph Exp $ +$Id: runtime.pkg,v 14.271 1996/05/18 06:16:11 cph Exp $ Copyright (c) 1988-96 Massachusetts Institute of Technology @@ -1725,7 +1725,7 @@ MIT in each case. |# channel-descriptor) (export (runtime socket) channel-descriptor - make-channel) + open-channel) (export (runtime subprocess) channel-descriptor) (export (runtime generic-i/o-port) diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm index 82b25f8eb..dab892f6a 100644 --- a/v7/src/runtime/socket.scm +++ b/v7/src/runtime/socket.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: socket.scm,v 1.7 1996/05/17 17:49:45 cph Exp $ +$Id: socket.scm,v 1.8 1996/05/18 06:15:24 cph Exp $ Copyright (c) 1990-96 Massachusetts Institute of Technology @@ -50,10 +50,11 @@ MIT in each case. |# (define (open-tcp-stream-socket-channel host-name service) (let ((host (vector-ref (get-host-by-name host-name) 0)) (port (tcp-service->port service))) - (without-background-interrupts - (lambda () - (make-channel - ((ucode-primitive open-tcp-stream-socket 2) host port)))))) + (open-channel + (lambda (p) + (with-thread-timer-stopped + (lambda () + ((ucode-primitive new-open-tcp-stream-socket 3) host port p))))))) (define (get-host-by-name host-name) (with-thread-timer-stopped @@ -61,16 +62,20 @@ MIT in each case. |# ((ucode-primitive get-host-by-name 1) host-name)))) (define (open-unix-stream-socket-channel filename) - (without-background-interrupts - (lambda () - (make-channel ((ucode-primitive open-unix-stream-socket 1) filename))))) + (open-channel + (lambda (p) + (with-thread-timer-stopped + (lambda () + ((ucode-primitive new-open-unix-stream-socket 2) filename p)))))) (define (open-tcp-server-socket service) - (without-background-interrupts - (lambda () - (make-channel - ((ucode-primitive open-tcp-server-socket 1) - (tcp-service->port service)))))) + (open-channel + (lambda (p) + (with-thread-timer-stopped + (lambda () + ((ucode-primitive new-open-tcp-server-socket 2) + (tcp-service->port service) + p)))))) (define (tcp-service->port service) (if (exact-nonnegative-integer? service) @@ -86,23 +91,16 @@ MIT in each case. |# (define (tcp-server-connection-accept server-socket block?) (let ((peer-address (allocate-host-address))) (let ((channel - (with-channel-blocking server-socket false + (with-channel-blocking server-socket block? (lambda () - (let loop () - (or (without-background-interrupts - (lambda () - (let ((descriptor - ((ucode-primitive tcp-server-connection-accept - 2) - (channel-descriptor server-socket) - peer-address))) - (and descriptor - (make-channel descriptor))))) - (and block? - (begin - (if (other-running-threads?) - (yield-current-thread)) - (loop))))))))) + (open-channel + (lambda (p) + (with-thread-timer-stopped + (lambda () + ((ucode-primitive new-tcp-server-connection-accept 3) + (channel-descriptor server-socket) + peer-address + p))))))))) (if channel (let ((port (make-generic-i/o-port channel channel 64 64))) (values port port peer-address)) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 20546bb4a..e4a213e68 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: version.scm,v 14.169 1996/04/24 04:37:20 cph Exp $ +$Id: version.scm,v 14.170 1996/05/18 06:15:47 cph Exp $ Copyright (c) 1988-96 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 169)) + (add-identification! "Runtime" 14 170)) (define microcode-system) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 5fb29bf67..4126faab6 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.271 1996/05/13 23:59:34 cph Exp $ +$Id: runtime.pkg,v 14.272 1996/05/18 06:15:59 cph Exp $ Copyright (c) 1988-96 Massachusetts Institute of Technology @@ -1724,7 +1724,7 @@ MIT in each case. |# channel-descriptor) (export (runtime socket) channel-descriptor - make-channel) + open-channel) (export (runtime subprocess) channel-descriptor) (export (runtime generic-i/o-port) -- 2.25.1