1.0.8.15: making SBCL sources Git more friendly

[sbcl.git] / src / code / fd-stream.lisp

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 88b22af..37ae997 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -18,21 +18,19 @@
 (defvar *available-buffers* ()
   #!+sb-doc
   "List of available buffers. Each buffer is an sap pointing to
 (defvar *available-buffers* ()
   #!+sb-doc
   "List of available buffers. Each buffer is an sap pointing to

-  bytes-per-buffer of memory.")
+bytes-per-buffer of memory.")

 
 

-#!+sb-thread

 (defvar *available-buffers-mutex* (sb!thread:make-mutex
                                    :name "lock for *AVAILABLE-BUFFERS*")
   #!+sb-doc
   "Mutex for access to *AVAILABLE-BUFFERS*.")
 
 (defmacro with-available-buffers-lock ((&optional) &body body)
 (defvar *available-buffers-mutex* (sb!thread:make-mutex
                                    :name "lock for *AVAILABLE-BUFFERS*")
   #!+sb-doc
   "Mutex for access to *AVAILABLE-BUFFERS*.")
 
 (defmacro with-available-buffers-lock ((&optional) &body body)

-  ;; WITHOUT-INTERRUPTS because streams are low-level enough to be
+  ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be

   ;; async signal safe, and in particular a C-c that brings up the
   ;; debugger while holding the mutex would lose badly
   ;; async signal safe, and in particular a C-c that brings up the
   ;; debugger while holding the mutex would lose badly

-  `(without-interrupts
-    (sb!thread:with-mutex (*available-buffers-mutex*)
-      ,@body)))
+  `(sb!thread::call-with-system-mutex (lambda () ,@body)
+                                    *available-buffers-mutex*))

 
 (defconstant bytes-per-buffer (* 4 1024)
   #!+sb-doc
 
 (defconstant bytes-per-buffer (* 4 1024)
   #!+sb-doc

@@ -98,8 +96,8 @@
   ;; output flushed, but not written due to non-blocking io?
   (output-later nil)
   (handler nil)
   ;; output flushed, but not written due to non-blocking io?
   (output-later nil)
   (handler nil)

-  ;; timeout specified for this stream, or NIL if none
-  (timeout nil :type (or index null))
+  ;; timeout specified for this stream as seconds or NIL if none
+  (timeout nil :type (or single-float null))

   ;; pathname of the file this stream is opened to (returned by PATHNAME)
   (pathname nil :type (or pathname null))
   (external-format :default)
   ;; pathname of the file this stream is opened to (returned by PATHNAME)
   (pathname nil :type (or pathname null))
   (external-format :default)

@@ -221,7 +219,8 @@
             ((not (null count)) ; sorta worked..
              (push (list base
                          (the index (+ start count))
             ((not (null count)) ; sorta worked..
              (push (list base
                          (the index (+ start count))

-                         end)
+                         end
+                         reuse-sap)

                    (fd-stream-output-later stream))))))
   (unless (fd-stream-output-later stream)
     (remove-fd-handler (fd-stream-handler stream))
                    (fd-stream-output-later stream))))))
   (unless (fd-stream-output-later stream)
     (remove-fd-handler (fd-stream-handler stream))

@@ -538,59 +537,40 @@
 ;;; unbuffered, slam the string down the file descriptor, otherwise
 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 ;;; checking to see where the last newline was.
 ;;; unbuffered, slam the string down the file descriptor, otherwise
 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 ;;; checking to see where the last newline was.

-;;;
-;;; Note: some bozos (the FASL dumper) call write-string with things
-;;; other than strings. Therefore, we must make sure we have a string
-;;; before calling POSITION on it.
-;;; KLUDGE: It would be better to fix the bozos instead of trying to
-;;; cover for them here. -- WHN 20000203

 (defun fd-sout (stream thing start end)
 (defun fd-sout (stream thing start end)

+  (declare (type fd-stream stream) (type string thing))

   (let ((start (or start 0))
         (end (or end (length (the vector thing)))))
     (declare (fixnum start end))
   (let ((start (or start 0))
         (end (or end (length (the vector thing)))))
     (declare (fixnum start end))

-    (if (stringp thing)
-        (let ((last-newline
-               (string-dispatch (simple-base-string
-                                 #!+sb-unicode
-                                 (simple-array character)
-                                 string)
-                   thing
-                 (and (find #\newline thing :start start :end end)
-                      ;; FIXME why do we need both calls?
-                      ;; Is find faster forwards than
-                      ;; position is backwards?
-                      (position #\newline thing
-                                :from-end t
-                                :start start
-                                :end end)))))
-          (if (and (typep thing 'base-string)
-                   (eq (fd-stream-external-format stream) :latin-1))
-              (ecase (fd-stream-buffering stream)
-                (:full
-                 (output-raw-bytes stream thing start end))
-                (:line
-                 (output-raw-bytes stream thing start end)
-                 (when last-newline
-                   (flush-output-buffer stream)))
-                (:none
-                 (frob-output stream thing start end nil)))
-              (ecase (fd-stream-buffering stream)
-                (:full (funcall (fd-stream-output-bytes stream)
-                                stream thing nil start end))
-                (:line (funcall (fd-stream-output-bytes stream)
-                                stream thing last-newline start end))
-                (:none (funcall (fd-stream-output-bytes stream)
-                                stream thing t start end))))
-          (if last-newline
-              (setf (fd-stream-char-pos stream)
-                    (- end last-newline 1))
-              (incf (fd-stream-char-pos stream)
-                    (- end start))))
-        (ecase (fd-stream-buffering stream)
-          ((:line :full)
-           (output-raw-bytes stream thing start end))
-          (:none
-           (frob-output stream thing start end nil))))))
+    (let ((last-newline
+           (string-dispatch (simple-base-string
+                             #!+sb-unicode
+                             (simple-array character (*))
+                             string)
+               thing
+             (position #\newline thing :from-end t
+                       :start start :end end))))
+      (if (and (typep thing 'base-string)
+               (eq (fd-stream-external-format stream) :latin-1))
+          (ecase (fd-stream-buffering stream)
+            (:full
+             (output-raw-bytes stream thing start end))
+            (:line
+             (output-raw-bytes stream thing start end)
+             (when last-newline
+               (flush-output-buffer stream)))
+            (:none
+             (frob-output stream thing start end nil)))
+          (ecase (fd-stream-buffering stream)
+            (:full (funcall (fd-stream-output-bytes stream)
+                            stream thing nil start end))
+            (:line (funcall (fd-stream-output-bytes stream)
+                            stream thing last-newline start end))
+            (:none (funcall (fd-stream-output-bytes stream)
+                            stream thing t start end))))
+      (if last-newline
+          (setf (fd-stream-char-pos stream) (- end last-newline 1))
+          (incf (fd-stream-char-pos stream) (- end start))))))

 
 (defvar *external-formats* ()
   #!+sb-doc
 
 (defvar *external-formats* ()
   #!+sb-doc

@@ -718,56 +698,80 @@
                              stream
                              errno)))))
 
                              stream
                              errno)))))
 

-;;; Fill the input buffer, and return the number of bytes read. Throw
-;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into
-;;; SYSTEM:SERVER if necessary.
+;;; If the read would block wait (using SERVE-EVENT) till input is available,
+;;; then fill the input buffer, and return the number of bytes read. Throws
+;;; to EOF-INPUT-CATCHER if the eof was reached.

 (defun refill-buffer/fd (stream)
   (let ((fd (fd-stream-fd stream))
 (defun refill-buffer/fd (stream)
   (let ((fd (fd-stream-fd stream))

-        (ibuf-sap (fd-stream-ibuf-sap stream))
-        (buflen (fd-stream-ibuf-length stream))
-        (head (fd-stream-ibuf-head stream))
-        (tail (fd-stream-ibuf-tail stream)))
-    (declare (type index head tail))
-    (unless (zerop head)
-      (cond ((eql head tail)
-             (setf head 0)
-             (setf tail 0)
-             (setf (fd-stream-ibuf-head stream) 0)
-             (setf (fd-stream-ibuf-tail stream) 0))
-            (t
-             (decf tail head)
-             (system-area-ub8-copy ibuf-sap head
-                                   ibuf-sap 0 tail)
-             (setf head 0)
-             (setf (fd-stream-ibuf-head stream) 0)
-             (setf (fd-stream-ibuf-tail stream) tail))))
-    (setf (fd-stream-listen stream) nil)
-    ;;This isn't quite the same on win32.  Then again, neither was
-    ;;(not (sb!win32:fd-listen fd)), as was originally here.  See
-    ;;comment in `sysread-may-block-p'.
-    (when (sysread-may-block-p stream)
-      (unless (wait-until-fd-usable
-               fd :input (fd-stream-timeout stream))
-        (error 'io-timeout :stream stream :direction :read)))
-    (multiple-value-bind (count errno)
-        (sb!unix:unix-read fd
-                           (int-sap (+ (sap-int ibuf-sap) tail))
-                           (- buflen tail))
-      (cond ((null count)
-             (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
-                 (progn
-                   (unless (wait-until-fd-usable
-                            fd :input (fd-stream-timeout stream))
-                     (error 'io-timeout :stream stream :direction :read))
-                   (refill-buffer/fd stream))
-                 (simple-stream-perror "couldn't read from ~S" stream errno)))
-            ((zerop count)
-             (setf (fd-stream-listen stream) :eof)
-             (/show0 "THROWing EOF-INPUT-CATCHER")
-             (throw 'eof-input-catcher nil))
-            (t
-             (incf (fd-stream-ibuf-tail stream) count)
-             count)))))
+        (errno 0)
+        (count 0))
+    (tagbody
+       ;; Check for blocking input before touching the stream, as if
+       ;; we happen to wait we are liable to be interrupted, and the
+       ;; interrupt handler may use the same stream.
+       (if (sysread-may-block-p stream)
+           (go :wait-for-input)
+           (go :main))
+       ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
+       ;; we can signal errors outside the WITHOUT-INTERRUPTS.
+     :closed-flame
+       (closed-flame stream)
+     :read-error
+       (simple-stream-perror "couldn't read from ~S" stream errno)
+     :wait-for-input
+       ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
+       ;; to wait for input if read tells us EWOULDBLOCK.
+       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream))
+         (signal-timeout 'io-timeout :stream stream :direction :read
+                         :seconds (fd-stream-timeout stream)))
+     :main
+       ;; Since the read should not block, we'll disable the
+       ;; interrupts here, so that we don't accidentally unwind and
+       ;; leave the stream in an inconsistent state.
+       (without-interrupts
+         (let ((ibuf-sap (fd-stream-ibuf-sap stream))
+               (buflen (fd-stream-ibuf-length stream))
+               (head (fd-stream-ibuf-head stream))
+               (tail (fd-stream-ibuf-tail stream)))
+           (declare (type index head tail))
+           ;; Check the SAP: if it is null, then someone has closed
+           ;; the stream from underneath us. This is not ment to fix
+           ;; multithreaded races, but to deal with interrupt handlers
+           ;; closing the stream.
+           (unless ibuf-sap
+             (go :closed-flame))
+           (unless (zerop head)
+             (cond ((eql head tail)
+                    (setf head 0
+                          tail 0
+                          (fd-stream-ibuf-head stream) 0
+                          (fd-stream-ibuf-tail stream) 0))
+                   (t
+                    (decf tail head)
+                    (system-area-ub8-copy ibuf-sap head
+                                          ibuf-sap 0 tail)
+                    (setf head 0
+                          (fd-stream-ibuf-head stream) 0
+                          (fd-stream-ibuf-tail stream) tail))))
+           (setf (fd-stream-listen stream) nil)
+           (setf (values count errno)
+                 (sb!unix:unix-read fd (int-sap (+ (sap-int ibuf-sap) tail))
+                                    (- buflen tail)))
+           (cond ((null count)
+                  #!+win32
+                  (go :read-error)
+                  #!-win32
+                  (if (eql errno sb!unix:ewouldblock)
+                      (go :wait-for-input)
+                      (go :read-error)))
+                 ((zerop count)
+                  (setf (fd-stream-listen stream) :eof)
+                  (/show0 "THROWing EOF-INPUT-CATCHER")
+                  (throw 'eof-input-catcher nil))
+                 (t
+                  ;; Success!
+                  (incf (fd-stream-ibuf-tail stream) count))))))
+    count))

 
 ;;; Make sure there are at least BYTES number of bytes in the input
 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.
 
 ;;; Make sure there are at least BYTES number of bytes in the input
 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.

@@ -1106,7 +1110,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode

-                                    (simple-array character)
+                                    (simple-array character (*))

                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))

@@ -1224,26 +1228,22 @@
             (let* ((length (length string))
                    (,n-buffer (make-array (* (1+ length) ,size)
                                           :element-type '(unsigned-byte 8)))
             (let* ((length (length string))
                    (,n-buffer (make-array (* (1+ length) ,size)
                                           :element-type '(unsigned-byte 8)))

-                   ;; This SAP-taking may seem unsafe without pinning,
-                   ;; but since the variable name is a gensym OUT-EXPR
-                   ;; cannot close over it even if it tried, so the buffer
-                   ;; will always be either in a register or on stack.
-                   ;; FIXME: But ...this is true on x86oids only!
-                   (sap (vector-sap ,n-buffer))

                    (tail 0)
                    (stream ,name))
                    (tail 0)
                    (stream ,name))

-              (declare (type index length tail)
-                       (type system-area-pointer sap))
-              (dotimes (i length)
-                (let* ((byte (aref string i))
-                       (bits (char-code byte)))
-                  (declare (ignorable byte bits))
-                  ,out-expr)
-                (incf tail ,size))
-              (let* ((bits 0)
-                     (byte (code-char bits)))
-                (declare (ignorable bits byte))
-                ,out-expr)
+              (declare (type index length tail))
+              (with-pinned-objects (,n-buffer)
+                (let ((sap (vector-sap ,n-buffer)))
+                  (declare (system-area-pointer sap))
+                  (dotimes (i length)
+                    (let* ((byte (aref string i))
+                           (bits (char-code byte)))
+                      (declare (ignorable byte bits))
+                      ,out-expr)
+                    (incf tail ,size))
+                  (let* ((bits 0)
+                         (byte (code-char bits)))
+                    (declare (ignorable bits byte))
+                    ,out-expr)))

               ,n-buffer)))
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,n-buffer)))
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function

@@ -1286,7 +1286,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode

-                                    (simple-array character)
+                                    (simple-array character (*))

                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))

@@ -1476,29 +1476,25 @@
                  (tail 0)
                  (,n-buffer (make-array buffer-length
                                         :element-type '(unsigned-byte 8)))
                  (tail 0)
                  (,n-buffer (make-array buffer-length
                                         :element-type '(unsigned-byte 8)))

-                 ;; This SAP-taking may seem unsafe without pinning,
-                 ;; but since the variable name is a gensym OUT-EXPR
-                 ;; cannot close over it even if it tried, so the buffer
-                 ;; will always be either in a register or on stack.
-                 ;; FIXME: But ...this is true on x86oids only!
-                 (sap (vector-sap ,n-buffer))

                  stream)
             (declare (type index length buffer-length tail)
                  stream)
             (declare (type index length buffer-length tail)

-                     (type system-area-pointer sap)

                      (type null stream)
                      (ignorable stream))
                      (type null stream)
                      (ignorable stream))

-            (loop for i of-type index below length
-                  for byte of-type character = (aref string i)
-                  for bits = (char-code byte)
-                  for size of-type index = (aref char-length i)
-                  do (prog1
-                         ,out-expr
-                       (incf tail size)))
-            (let* ((bits 0)
-                   (byte (code-char bits))
-                   (size (aref char-length length)))
-              (declare (ignorable bits byte size))
-              ,out-expr)
+            (with-pinned-objects (,n-buffer)
+              (let ((sap (vector-sap ,n-buffer)))
+                (declare (system-area-pointer sap))
+                (loop for i of-type index below length
+                      for byte of-type character = (aref string i)
+                      for bits = (char-code byte)
+                      for size of-type index = (aref char-length i)
+                      do (prog1
+                             ,out-expr
+                           (incf tail size)))
+                (let* ((bits 0)
+                       (byte (code-char bits))
+                       (size (aref char-length length)))
+                  (declare (ignorable bits byte size))
+                  ,out-expr)))

             ,n-buffer)))
 
       (setf *external-formats*
             ,n-buffer)))
 
       (setf *external-formats*

@@ -1972,6 +1968,19 @@
          (fd-stream-set-file-position fd-stream arg1)
          (fd-stream-get-file-position fd-stream)))))
 
          (fd-stream-set-file-position fd-stream arg1)
          (fd-stream-get-file-position fd-stream)))))
 

+;; FIXME: Think about this.
+;;
+;; (defun finish-fd-stream-output (fd-stream)
+;;   (let ((timeout (fd-stream-timeout fd-stream)))
+;;     (loop while (fd-stream-output-later fd-stream)
+;;        ;; FIXME: SIGINT while waiting for a timeout will
+;;        ;; cause a timeout here.
+;;        do (when (and (not (serve-event timeout)) timeout)
+;;             (signal-timeout 'io-timeout
+;;                             :stream fd-stream
+;;                             :direction :write
+;;                             :seconds timeout)))))
+

 (defun finish-fd-stream-output (stream)
   (flush-output-buffer stream)
   (do ()
 (defun finish-fd-stream-output (stream)
   (flush-output-buffer stream)
   (do ()

@@ -2096,7 +2105,7 @@
                                  (format nil "file ~A" file)
                                  (format nil "descriptor ~W" fd)))
                        auto-close)
                                  (format nil "file ~A" file)
                                  (format nil "descriptor ~W" fd)))
                        auto-close)

-  (declare (type index fd) (type (or index null) timeout)
+  (declare (type index fd) (type (or real null) timeout)

            (type (member :none :line :full) buffering))
   (cond ((not (or input-p output-p))
          (setf input t))
            (type (member :none :line :full) buffering))
   (cond ((not (or input-p output-p))
          (setf input t))

@@ -2111,7 +2120,10 @@
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
                                  :external-format external-format
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
                                  :external-format external-format

-                                 :timeout timeout)))
+                                 :timeout
+                                 (if timeout
+                                     (coerce timeout 'single-float)
+                                     nil))))

     (set-fd-stream-routines stream element-type external-format
                             input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))
     (set-fd-stream-routines stream element-type external-format
                             input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))