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.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 216f4e4c81bf3f04a5caaae413b33e1dd7552e7b..bc5760444b37d03a63673d3950950441d80f2d24 100644 (file)
--- 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))
 \f
 (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))))
 \f
 (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))))))
 \f
 ;;;; 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)))))))))
 \f
 ;;;; 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 5a81bd4cf62f2f7a31496618087cf4db85bbc5a8..632fca3b22cd177bcbb60269b5e0b3af53690d5a 100644 (file)
--- 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 82b25f8eb196bc564dd6dbcb952fa09c6dc5b5ae..dab892f6a64d6c439ada89127af6bca8e3b6c08a 100644 (file)
--- 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 20546bb4a9245fcd5287a190972fc0238459514f..e4a213e68999d207cbe7a64d4e8d3f1c12c092cb 100644 (file)
--- 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 5fb29bf6742994f07112bdcd3dc5cb1d900d3581..4126faab6d4db83e6890b2a972427b06b99794fe 100644 (file)
--- 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)