X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=37ae9970891173ced318e34db34a71c53ca29547;hb=ef716ee5409d0d55020aea422e29a9175c2b4b74;hp=88b22af956cd80f5e5d6fda16abfbff8003bcfcc;hpb=8cad02355db787b9f077b77f508329550ccd0db6;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 88b22af..37ae997 100644 --- 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 - 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) - ;; 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 - `(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 @@ -98,8 +96,8 @@ ;; 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) @@ -221,7 +219,8 @@ ((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)) @@ -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. -;;; -;;; 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) + (declare (type fd-stream stream) (type string thing)) (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 @@ -718,56 +698,80 @@ 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)) - (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. @@ -1106,7 +1110,7 @@ (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)) @@ -1224,26 +1228,22 @@ (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)) - (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 @@ -1286,7 +1286,7 @@ (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)) @@ -1476,29 +1476,25 @@ (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) - (type system-area-pointer sap) (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* @@ -1972,6 +1968,19 @@ (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 () @@ -2096,7 +2105,7 @@ (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)) @@ -2111,7 +2120,10 @@ :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))