0.9.0.34

Eliminate unnecessary seeks on socket streams
  ... Introduce dual-channel-p flag in fd-streams to discriminate
      between files and socket/pipe-streams

diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index 4a5249f..06ca1e3 100644 (file)
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -268,6 +268,7 @@ SB-SYS:MAKE-FD-STREAM."))
       (setf stream (apply #'sb-sys:make-fd-stream
                          (socket-file-descriptor socket)
                          :name "a constant string"
+                         :dual-channel-p t
                          args))
       (setf (slot-value socket 'stream) stream)
       (sb-ext:cancel-finalization socket))

diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp
index a74aabb..659f2db 100644 (file)
--- a/contrib/sb-simple-streams/internal.lisp
+++ b/contrib/sb-simple-streams/internal.lisp
@@ -638,6 +638,7 @@
                                   :original original
                                   :delete-original delete-original
                                   :pathname pathname
+                                 :dual-channel-p nil
                                   :input-buffer-p t
                                   :auto-close t))
           (:probe

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index caa363d..1d8b567 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -57,6 +57,11 @@
   (fd -1 :type fixnum)       
   ;; controls when the output buffer is flushed
   (buffering :full :type (member :full :line :none))
+  ;; controls whether the input buffer must be cleared before output
+  ;; (must be done for files, not for sockets, pipes and other data
+  ;; sources where input and output aren't related).  non-NIL means
+  ;; don't clear input buffer.
+  (dual-channel-p nil)
   ;; character position (if known)
   (char-pos nil :type (or index null))
   ;; T if input is waiting on FD. :EOF if we hit EOF.
@@ -244,8 +249,9 @@
                       size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)
-        `(when (> (fd-stream-ibuf-tail ,stream-var)
-                  (fd-stream-ibuf-head ,stream-var))
+        `(when (and (not (fd-stream-dual-channel-p ,stream-var))
+                    (> (fd-stream-ibuf-tail ,stream-var)
+                       (fd-stream-ibuf-head ,stream-var)))
             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart
            `(catch 'output-nothing
@@ -272,8 +278,9 @@
                       ,size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)
-        `(when (> (fd-stream-ibuf-tail ,stream-var)
-                  (fd-stream-ibuf-head ,stream-var))
+        `(when (and (not (fd-stream-dual-channel-p ,stream-var))
+                    (> (fd-stream-ibuf-tail ,stream-var)
+                       (fd-stream-ibuf-head ,stream-var)))
             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart
           `(catch 'output-nothing
@@ -419,8 +426,9 @@
   (let ((start (or start 0))
        (end (or end (length (the (simple-array * (*)) thing)))))
     (declare (type index start end))
-    (when (> (fd-stream-ibuf-tail fd-stream)
-            (fd-stream-ibuf-head fd-stream))
+    (when (and (not (fd-stream-dual-channel-p fd-stream))
+              (> (fd-stream-ibuf-tail fd-stream)
+                 (fd-stream-ibuf-head fd-stream)))
       (file-position fd-stream (file-position fd-stream)))
     (let* ((len (fd-stream-obuf-length fd-stream))
           (tail (fd-stream-obuf-tail fd-stream))
@@ -963,8 +971,9 @@
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
-         (when (> (fd-stream-ibuf-tail stream)
-                  (fd-stream-ibuf-head stream))
+         (when (and (not (fd-stream-dual-channel-p stream))
+                    (> (fd-stream-ibuf-tail stream)
+                       (fd-stream-ibuf-head stream)))
            (file-position stream (file-position stream)))
          (when (< end start)
            (error ":END before :START!"))
@@ -1065,8 +1074,9 @@
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
-         (when (> (fd-stream-ibuf-tail fd-stream)
-                  (fd-stream-ibuf-head fd-stream))
+         (when (and (not (fd-stream-dual-channel-p fd-stream))
+                    (> (fd-stream-ibuf-tail fd-stream)
+                       (fd-stream-ibuf-head fd-stream)))
            (file-position fd-stream (file-position fd-stream)))
          (when (< end start)
            (error ":END before :START!"))
@@ -1726,6 +1736,7 @@
                       delete-original
                       pathname
                       input-buffer-p
+                      dual-channel-p
                       (name (if file
                                 (format nil "file ~S" file)
                                 (format nil "descriptor ~W" fd)))
@@ -1743,6 +1754,7 @@
                                 :delete-original delete-original
                                 :pathname pathname
                                 :buffering buffering
+                                :dual-channel-p dual-channel-p
                                 :external-format external-format
                                 :timeout timeout)))
     (set-fd-stream-routines stream element-type input output input-buffer-p)
@@ -1936,6 +1948,7 @@
                                      :original original
                                      :delete-original delete-original
                                      :pathname pathname
+                                     :dual-channel-p nil
                                      :input-buffer-p t
                                      :auto-close t))
                     (:probe

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 25c31c2..ab9ebf7 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -320,7 +320,8 @@
          (push new-fd *close-on-error*)
          (copy-descriptor-to-stream new-fd pty cookie)))
       (values name
-             (sb-sys:make-fd-stream master :input t :output t)))))
+             (sb-sys:make-fd-stream master :input t :output t 
+                                    :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)
   `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index fe34aac..b3285a9 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -392,13 +392,13 @@ interactive."
     (labels ((thread-repl () 
               (sb!unix::unix-setsid)
               (let* ((sb!impl::*stdin* 
-                      (sb!sys:make-fd-stream in :input t :buffering :line))
+                      (sb!sys:make-fd-stream in :input t :buffering :line :dual-channel-p t))
                      (sb!impl::*stdout* 
-                      (sb!sys:make-fd-stream out :output t :buffering :line))
+                      (sb!sys:make-fd-stream out :output t :buffering :line :dual-channel-p t))
                      (sb!impl::*stderr* 
-                      (sb!sys:make-fd-stream err :output t :buffering :line))
+                      (sb!sys:make-fd-stream err :output t :buffering :line :dual-channel-p t))
                      (sb!impl::*tty* 
-                      (sb!sys:make-fd-stream err :input t :output t :buffering :line))
+                      (sb!sys:make-fd-stream err :input t :output t :buffering :line :dual-channel-p t))
                      (sb!impl::*descriptor-handlers* nil))
                 (with-new-session ()
                   (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)

diff --git a/version.lisp-expr b/version.lisp-expr
index 8847cfc..3fd4f02 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.0.33"
+"0.9.0.34"