X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=6e2b2b4b7720d119cfd5e19e9cf4256407ecf77d;hb=5cd15f4133804a16c5d367556da160144e741852;hp=122809fad8439da373b3cdb67745e7d54ee47e71;hpb=cd3332a71793f4bccee403162ad0daf60ad51fb2;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 122809f..6e2b2b4 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -20,6 +20,20 @@ "List of available buffers. Each buffer is an sap pointing to 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 + ;; 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))) + (defconstant bytes-per-buffer (* 4 1024) #!+sb-doc "Number of bytes per buffer.") @@ -27,9 +41,10 @@ ;;; Return the next available buffer, creating one if necessary. #!-sb-fluid (declaim (inline next-available-buffer)) (defun next-available-buffer () - (if *available-buffers* - (pop *available-buffers*) - (allocate-system-memory bytes-per-buffer))) + (with-available-buffers-lock () + (if *available-buffers* + (pop *available-buffers*) + (allocate-system-memory bytes-per-buffer)))) ;;;; the FD-STREAM structure @@ -177,7 +192,8 @@ (simple-stream-perror "couldn't write to ~S" stream errno))) ((eql count length) ; Hot damn, it worked. (when reuse-sap - (push base *available-buffers*))) + (with-available-buffers-lock () + (push base *available-buffers*)))) ((not (null count)) ; sorta worked.. (push (list base (the index (+ start count)) @@ -486,15 +502,26 @@ (end (or end (length (the vector thing))))) (declare (fixnum start end)) (if (stringp thing) - (let ((last-newline (and (find #\newline (the simple-string thing) - :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline (the simple-string thing) - :from-end t - :start start - :end end)))) + (let ((last-newline + (flet ((do-it (string) + (and (find #\newline string :start start :end end) + ;; FIXME why do we need both calls? + ;; Is find faster forwards than + ;; position is backwards? + (position #\newline string + :from-end t + :start start + :end end)))) + (declare (inline do-it)) + ;; Specialize the common cases + (etypecase thing + (simple-base-string + (do-it (the simple-base-string thing))) + #!+sb-unicode + ((simple-array character) + (do-it (the (simple-array character) thing))) + (string + (do-it thing)))))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format stream) :latin-1)) (ecase (fd-stream-buffering stream) @@ -972,26 +999,49 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) - `(let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) - (incf start))) + (flet ((do-it (string) + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) + (declare (inline do-it)) + ;; Specialized versions for the common cases of + ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) + ;; to avoid doing a generic AREF. + (etypecase string + (simple-base-string + (do-it (the simple-base-string string))) + #!+sb-unicode + ((simple-array character) + ;; For some reason the type information from the + ;; etypecase doesn't propagate through here without + ;; an explicit THE. + (do-it (the (simple-array character) string))) + (string + (do-it string))))) (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1010,41 +1060,41 @@ (tail (fd-stream-obuf-tail stream))) ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p - &aux (total-copied 0)) + &aux (index start) (end (+ start requested))) (declare (type fd-stream stream)) - (declare (type index start requested total-copied)) + (declare (type index start requested index end)) (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) (let ((unread (fd-stream-unread stream))) (when unread - (setf (aref buffer start) unread) + (setf (aref buffer index) unread) (setf (fd-stream-unread stream) nil) (setf (fd-stream-listen stream) nil) - (incf total-copied))) + (incf index))) (do () (nil) (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (sap (fd-stream-ibuf-sap stream))) - (declare (type index head tail)) + (declare (type index head tail) + (type system-area-pointer sap)) ;; Copy data from stream buffer into user's buffer. - (do () - ((or (= tail head) (= requested total-copied))) + (dotimes (i (min (truncate (- tail head) ,size) + (- end index))) + (declare (optimize speed)) (let* ((byte (sap-ref-8 sap head))) - (when (> ,size (- tail head)) - (return)) - (setf (aref buffer (+ start total-copied)) ,in-expr) - (incf total-copied) + (setf (aref buffer index) ,in-expr) + (incf index) (incf head ,size))) (setf (fd-stream-ibuf-head stream) head) ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) - (return total-copied)) + (cond ( ;; If there was enough data in the stream buffer, we're done. + (= index end) + (return (- index start))) ( ;; If EOF, we're done in another way. (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) - (return total-copied))) + (return (- index start)))) ;; Otherwise we refilled the stream buffer, so fall ;; through into another pass of the loop. )))) @@ -1076,28 +1126,50 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - `(let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - (incf start))) + (flet ((do-it (string) + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) + (declare (inline do-it)) + ;; Specialized versions for the common cases of + ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) + ;; to avoid doing a generic AREF. + (etypecase string + (simple-base-string + (do-it (the simple-base-string string))) + #!+sb-unicode + ((simple-array character) + ;; For some reason the type information from the + ;; etypecase doesn't propagate through here without + ;; an explicit THE. + (do-it (the (simple-array character) string))) + (string + (do-it string))))) (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1132,7 +1204,6 @@ (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (sap (fd-stream-ibuf-sap stream)) - (head-start head) (decode-break-reason nil)) (declare (type index head tail)) ;; Copy data from stream buffer into user's buffer. @@ -1149,17 +1220,22 @@ (incf head size)) nil)) (setf (fd-stream-ibuf-head stream) head) - (when (and decode-break-reason - (= head head-start)) + (when decode-break-reason + ;; If we've already read some characters on when the invalid + ;; code sequence is detected, we return immediately. The + ;; handling of the error is deferred until the next call + ;; (where this check will be false). This allows establishing + ;; high-level handlers for decode errors (for example + ;; automatically resyncing in Lisp comments). + (when (plusp total-copied) + (return-from ,in-function total-copied)) (when (stream-decoding-error-and-handle stream decode-break-reason) (if eof-error-p (error 'end-of-file :stream stream) (return-from ,in-function total-copied))) (setf head (fd-stream-ibuf-head stream)) - (setf tail (fd-stream-ibuf-tail stream))) - (when (plusp total-copied) - (return-from ,in-function total-copied))) + (setf tail (fd-stream-ibuf-tail stream)))) (setf (fd-stream-ibuf-head stream) head) ;; Maybe we need to refill the stream buffer. (cond ( ;; If there were enough data in the stream buffer, we're done. @@ -1200,7 +1276,10 @@ ,resync-function) *external-formats*))))) -(define-external-format (:latin-1 :latin1 :iso-8859-1) +;;; Multiple names for the :ISO{,-}8859-* families are needed because on +;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will +;;; return "ISO8859-1" instead of "ISO-8859-1". +(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1) 1 t (if (>= bits 256) (stream-encoding-error-and-handle stream bits) @@ -1267,7 +1346,7 @@ (latin-9-reverse-2 (make-array 16 :element-type '(unsigned-byte 8) :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0)))) - (define-external-format (:latin-9 :latin9 :iso-8859-15) + (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15) 1 t (setf (sap-ref-8 sap tail) (if (< bits 256) @@ -1360,11 +1439,13 @@ ;; drop buffers when direction changes (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil))) (when (and (fd-stream-ibuf-sap fd-stream) (not input-p)) - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil))) (when input-p (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer)) (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer) @@ -1571,11 +1652,13 @@ (cancel-finalization fd-stream)) (sb!unix:unix-close (fd-stream-fd fd-stream)) (when (fd-stream-obuf-sap fd-stream) - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil))) (when (fd-stream-ibuf-sap fd-stream) - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil))) (sb!impl::set-closed-flame fd-stream)) (:clear-input (setf (fd-stream-unread fd-stream) nil)