Use new I/O synchronization to avoid blocking the Scheme process when

an output channel blocks.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 78efbab76e3239d87679fb811d89fd406cfe83ad..c1ed87470488fab11de6284f2bf96492abdb429d 100644 (file)
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.69 2003/01/22 19:46:32 cph Exp $
+$Id: io.scm,v 14.70 2003/01/22 20:30:25 cph Exp $
 
 Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology
@@ -244,8 +244,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
                   (lambda (k)
                     (let ((result (test-for-io-on-channel channel 'READ)))
                       (case result
-                        ((READ ERROR) (do-read))
-                        ((HANGUP) 0)
+                        ((READ) (do-read))
+                        ((HANGUP ERROR) 0)
                         ((PROCESS-STATUS-CHANGE)
                          (handle-subprocess-status-change)
                          (if (channel-closed? channel) 0 (k)))
@@ -255,33 +255,40 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
                  (do-test (lambda () #f))))))
        (do-read))))
 
+(define (channel-write channel buffer start end)
+  (let ((do-write
+        (lambda ()
+          ((ucode-primitive channel-write 4)
+           (channel-descriptor channel)
+           (if (external-string? buffer)
+               (external-string-descriptor buffer)
+               buffer)
+           start
+           end))))
+    (declare (integrate-operator do-write))
+    (if (and have-select? (not (channel-type=file? channel)))
+       (with-thread-events-blocked
+         (lambda ()
+           (let ((do-test
+                  (lambda (k)
+                    (let ((result (test-for-io-on-channel channel 'WRITE)))
+                      (case result
+                        ((WRITE) (do-write))
+                        ((HANGUP ERROR) 0)
+                        ((PROCESS-STATUS-CHANGE)
+                         (handle-subprocess-status-change)
+                         (if (channel-closed? channel) 0 (k)))
+                        (else (k)))))))
+             (if (channel-blocking? channel)
+                 (let loop () (do-test loop))
+                 (do-test (lambda () #f))))))
+       (do-write))))
+\f
 (define (channel-read-block channel buffer start end)
   (let loop ()
     (or (channel-read channel buffer start end)
        (loop))))
 
-(define (test-for-io-on-channel channel mode)
-  (test-for-io-on-descriptor (channel-descriptor-for-select channel)
-                            (channel-blocking? channel)
-                            mode))
-
-(define (test-for-io-on-descriptor descriptor block? mode)
-  (if block?
-      (or (test-select-descriptor descriptor #f mode)
-         (block-on-io-descriptor descriptor mode))
-      (test-select-descriptor descriptor #f mode)))
-
-(define-integrable (channel-descriptor-for-select channel)
-  ((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
-\f
-(define (channel-write channel buffer start end)
-  ((ucode-primitive channel-write 4) (channel-descriptor channel)
-                                    (if (external-string? buffer)
-                                        (external-string-descriptor buffer)
-                                        buffer)
-                                    start
-                                    end))
-
 (define (channel-write-block channel buffer start end)
   (let loop ((start start) (n-left (- end start)))
     (let ((n (channel-write channel buffer start end)))
@@ -1324,4 +1331,18 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
                (set-cdr! (car rv) vmode)))
          (set! select-registry-result-vectors
                (cons (cons vfd vmode) select-registry-result-vectors))))
-    (set-interrupt-enables! interrupt-mask)))
\ No newline at end of file
+    (set-interrupt-enables! interrupt-mask)))
+
+(define (test-for-io-on-channel channel mode)
+  (test-for-io-on-descriptor (channel-descriptor-for-select channel)
+                            (channel-blocking? channel)
+                            mode))
+
+(define (test-for-io-on-descriptor descriptor block? mode)
+  (if block?
+      (or (test-select-descriptor descriptor #f mode)
+         (block-on-io-descriptor descriptor mode))
+      (test-select-descriptor descriptor #f mode)))
+
+(define-integrable (channel-descriptor-for-select channel)
+  ((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
\ No newline at end of file