X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=311a4b990389bf74d9110527a352bf6beb440a95;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=79911fc45a2948e5f2c4f7c7d9497e6701219db4;hpb=d508d8681eab5c3c3a36cb96c64a5367d0c7ddb3;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 79911fc..311a4b9 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -52,25 +52,16 @@ #!+sb-doc "List of available buffers.") -(defvar *available-buffers-spinlock* (sb!thread::make-spinlock - :name "lock for *AVAILABLE-BUFFERS*") +(defvar *available-buffers-lock* (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) - ;; CALL-WITH-SYSTEM-SPINLOCK because - ;; - ;; 1. 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 - ;; - ;; 2. this can potentially be a fairly busy (but also probably - ;; uncontended) lock, so we don't want to pay the syscall per - ;; release -- hence a spinlock. - ;; - ;; ...again, once we have smarted locks the spinlock here can become - ;; a mutex. - `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ;; 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. + `(sb!thread::with-system-mutex (*available-buffers-lock*) ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) @@ -157,6 +148,8 @@ (element-type 'base-char) ;; the Unix file descriptor (fd -1 :type fixnum) + ;; What do we know about the FD? + (fd-type :unknown :type keyword) ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) ;; controls whether the input buffer must be cleared before output @@ -169,6 +162,8 @@ (char-pos nil :type (or unsigned-byte null)) ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) + ;; T if serve-event is allowed when this stream blocks + (serve-events nil :type boolean) ;; the input buffer (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*))) @@ -185,7 +180,8 @@ (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) + ;; Not :DEFAULT, because we want to match CHAR-SIZE! + (external-format :latin-1) ;; fixed width, or function to call with a character (char-size 1 :type (or fixnum function)) (output-bytes #'ill-out :type function) @@ -262,32 +258,45 @@ (aver (< head tail)) (%queue-and-replace-output-buffer stream)) (t - ;; Try a non-blocking write, queue whatever is left over. + ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue + ;; whatever is left over. Otherwise wait until we can write. (aver (< head tail)) (synchronize-stream-output stream) - (let ((length (- tail head))) - (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) - head length) - (cond ((eql count length) - ;; Complete write -- we can use the same buffer. - (reset-buffer obuf)) - (count - ;; Partial write -- update buffer status and queue. - ;; Do not use INCF! Another thread might have moved - ;; head... - (setf (buffer-head obuf) (+ count head)) - (%queue-and-replace-output-buffer stream)) - #!-win32 - ((eql errno sb!unix:ewouldblock) - ;; Blocking, queue. - (%queue-and-replace-output-buffer stream)) - (t - (simple-stream-perror "Couldn't write to ~s" - stream errno))))))))))) + (loop + (let ((length (- tail head))) + (multiple-value-bind (count errno) + (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) + head length) + (flet ((queue-or-wait () + (if (fd-stream-serve-events stream) + (return (%queue-and-replace-output-buffer stream)) + (or (wait-until-fd-usable (fd-stream-fd stream) :output + (fd-stream-timeout stream) + nil) + (signal-timeout 'io-timeout + :stream stream + :direction :output + :seconds (fd-stream-timeout stream)))))) + (cond ((eql count length) + ;; Complete write -- we can use the same buffer. + (return (reset-buffer obuf))) + (count + ;; Partial write -- update buffer status and + ;; queue or wait. + (incf head count) + (setf (buffer-head obuf) head) + (queue-or-wait)) + #!-win32 + ((eql errno sb!unix:ewouldblock) + ;; Blocking, queue or wair. + (queue-or-wait)) + (t + (simple-stream-perror "Couldn't write to ~s" + stream errno))))))))))))) ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer. (defun %queue-and-replace-output-buffer (stream) + (aver (fd-stream-serve-events stream)) (let ((queue (fd-stream-output-queue stream)) (later (list (or (fd-stream-obuf stream) (bug "Missing obuf.")))) (new (get-buffer))) @@ -312,6 +321,7 @@ ;;; This is called by the FD-HANDLER for the stream when output is ;;; possible. (defun write-output-from-queue (stream) + (aver (fd-stream-serve-events stream)) (synchronize-stream-output stream) (let (not-first-p) (tagbody @@ -390,14 +400,10 @@ ;;; this is not something we want to export. Nikodemus thinks the ;;; right thing is to support a low-level non-stream like IO layer, ;;; akin to java.nio. -(defun output-raw-bytes (stream thing &optional start end) +(declaim (inline output-raw-bytes)) +(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence + (stream thing &optional start end) (write-or-buffer-output stream thing (or start 0) (or end (length thing)))) - -(define-compiler-macro output-raw-bytes (stream thing &optional start end) - (deprecation-warning 'output-raw-bytes) - (let ((x (gensym "THING"))) - `(let ((,x ,thing)) - (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x)))))) ;;;; output routines and related noise @@ -437,11 +443,10 @@ (error 'c-string-encoding-error :external-format external-format :code code)) - -(defun c-string-decoding-error (external-format octets) +(defun c-string-decoding-error (external-format sap offset count) (error 'c-string-decoding-error :external-format external-format - :octets octets)) + :octets (sap-ref-octets sap offset count))) ;;; Returning true goes into end of file handling, false will enter another ;;; round of input buffer filling followed by re-entering character decode. @@ -775,6 +780,11 @@ (octets-to-string-fun (missing-arg) :type function) (string-to-octets-fun (missing-arg) :type function)) +(defun ef-char-size (ef-entry) + (if (variable-width-external-format-p ef-entry) + (bytes-for-char-fun ef-entry) + (funcall (bytes-for-char-fun ef-entry) #\x))) + (defun wrap-external-format-functions (external-format fun) (let ((result (%copy-external-format external-format))) (macrolet ((frob (accessor) @@ -835,7 +845,7 @@ (defun get-external-format-or-lose (external-format) (or (get-external-format external-format) - (error "Undefined external-format ~A" external-format))) + (error "Undefined external-format: ~S" external-format))) (defun external-format-keyword (external-format) (typecase external-format @@ -855,17 +865,17 @@ ;;; number of bytes per element. (defun pick-output-routine (type buffering &optional external-format) (when (subtypep type 'character) - (let ((entry (get-external-format external-format))) - (when entry - (return-from pick-output-routine - (values (ecase buffering - (:none (ef-write-char-none-buffered-fun entry)) - (:line (ef-write-char-line-buffered-fun entry)) - (:full (ef-write-char-full-buffered-fun entry))) - 'character - 1 - (ef-write-n-bytes-fun entry) - (canonize-external-format external-format entry)))))) + (let ((entry (get-external-format-or-lose external-format))) + (return-from pick-output-routine + (values (ecase buffering + (:none (ef-write-char-none-buffered-fun entry)) + (:line (ef-write-char-line-buffered-fun entry)) + (:full (ef-write-char-full-buffered-fun entry))) + 'character + 1 + (ef-write-n-bytes-fun entry) + (ef-char-size entry) + (canonize-external-format external-format entry))))) (dolist (entry *output-routines*) (when (and (subtypep type (first entry)) (eq buffering (second entry)) @@ -941,20 +951,7 @@ ;; This answers T at EOF on win32, I think. (not (sb!win32:fd-listen (fd-stream-fd stream))) #!-win32 - (sb!unix:with-restarted-syscall (count errno) - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd stream)) - (sb!alien:addr read-fds) - nil nil 0 0)) - (case count - ((1) nil) - ((0) t) - (otherwise - (simple-stream-perror "couldn't check whether ~S is readable" - stream - errno))))) + (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0))) ;;; 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 @@ -964,10 +961,11 @@ (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) + ;; Check for blocking input before touching the stream if we are to + ;; serve events: if the FD is blocking, we don't want to try an uninterruptible + ;; read(). Regular files should never block, so we can elide the check. + (if (and (neq :regular (fd-stream-fd-type stream)) + (sysread-may-block-p stream)) (go :wait-for-input) (go :main)) ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what @@ -979,8 +977,11 @@ :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 + (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream) + (fd-stream-serve-events stream)) + (signal-timeout 'io-timeout + :stream stream + :direction :input :seconds (fd-stream-timeout stream))) :main ;; Since the read should not block, we'll disable the @@ -991,7 +992,7 @@ ;; resulting thunk is stack-allocatable. ((lambda (return-reason) (ecase return-reason - ((nil)) ; fast path normal cases + ((nil)) ; fast path normal cases ((:wait-for-input) (go :wait-for-input)) ((:closed-flame) (go :closed-flame)) ((:read-error) (go :read-error)))) @@ -1087,12 +1088,15 @@ (catch 'eof-input-catcher (setf decode-break-reason (block decode-break-reason - (input-at-least ,stream-var 1) - (let* ((byte (sap-ref-8 (buffer-sap ibuf) - (buffer-head ibuf)))) + (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes))) + (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf)))) (declare (ignorable byte)) - (setq size ,bytes) - (input-at-least ,stream-var size) + ,@(when (consp bytes) + `((let ((sap (buffer-sap ibuf)) + (head (buffer-head ibuf))) + (declare (ignorable sap head)) + (setq size ,(cadr bytes)) + (input-at-least ,stream-var size)))) (setq ,element-var (locally ,@read-forms)) (setq ,retry-var nil)) nil)) @@ -1209,14 +1213,14 @@ ;;; bytes per element (and for character types string input routine). (defun pick-input-routine (type &optional external-format) (when (subtypep type 'character) - (let ((entry (get-external-format external-format))) - (when entry - (return-from pick-input-routine - (values (ef-read-char-fun entry) - 'character - 1 - (ef-read-n-chars-fun entry) - (canonize-external-format external-format entry)))))) + (let ((entry (get-external-format-or-lose external-format))) + (return-from pick-input-routine + (values (ef-read-char-fun entry) + 'character + 1 + (ef-read-n-chars-fun entry) + (ef-char-size entry) + (canonize-external-format external-format entry))))) (dolist (entry *input-routines*) (when (and (subtypep type (first entry)) (or (not (fourth entry)) @@ -1501,9 +1505,12 @@ ((or (= tail head) (= requested total-copied))) (setf decode-break-reason (block decode-break-reason + ,@(when (consp in-size-expr) + `((when (> ,(car in-size-expr) (- tail head)) + (return)))) (let ((byte (sap-ref-8 sap head))) (declare (ignorable byte)) - (setq size ,in-size-expr) + (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)) (when (> size (- tail head)) (return)) (setf (aref buffer (+ start total-copied)) ,in-expr) @@ -1531,8 +1538,8 @@ (return-from ,in-function total-copied))) (setf (buffer-head ibuf) 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) + (cond ( ;; If was data in the stream buffer, we're done. + (plusp total-copied) (return total-copied)) ( ;; If EOF, we're done in another way. (or (eq decode-break-reason 'eof) @@ -1552,18 +1559,20 @@ (declare (ignorable byte)) ,in-expr)) (defun ,resync-function (stream) - (let ((ibuf (fd-stream-ibuf stream))) + (let ((ibuf (fd-stream-ibuf stream)) + size) (catch 'eof-input-catcher (loop (incf (buffer-head ibuf)) - (input-at-least stream 1) + (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr))) (unless (block decode-break-reason (let* ((sap (buffer-sap ibuf)) (head (buffer-head ibuf)) - (byte (sap-ref-8 sap head)) - (size ,in-size-expr)) + (byte (sap-ref-8 sap head))) (declare (ignorable byte)) - (input-at-least stream size) + ,@(when (consp in-size-expr) + `((setq size ,(cadr in-size-expr)) + (input-at-least stream size))) (setf head (buffer-head ibuf)) ,in-expr) nil) @@ -1579,12 +1588,13 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,in-size-expr + size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason - (c-string-decoding-error ,name decode-break-reason)) + (c-string-decoding-error + ,name sap head decode-break-reason)) (when (zerop (char-code char)) (return count)))) (string (make-string length :element-type element-type))) @@ -1598,12 +1608,13 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,in-size-expr + size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason - (c-string-decoding-error ,name decode-break-reason)) + (c-string-decoding-error + ,name sap head decode-break-reason)) (setf (aref string index) char))))) (defun ,output-c-string-function (string) @@ -1685,6 +1696,7 @@ (character-stream-p (subtypep target-type 'character)) (bivalent-stream-p (eq element-type :default)) normalized-external-format + char-size (bin-routine #'ill-bin) (bin-type nil) (bin-size nil) @@ -1728,24 +1740,23 @@ (when output-p (setf (fd-stream-char-pos fd-stream) 0)) - (when (and character-stream-p - (eq external-format :default)) + (when (and character-stream-p (eq external-format :default)) (/show0 "/getting default external format") (setf external-format (default-external-format))) (when input-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bin-routine bin-type bin-size read-n-characters - normalized-external-format) - (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) - target-type) - external-format)) + (setf (values bin-routine bin-type bin-size read-n-characters + char-size normalized-external-format) + (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) + target-type) + external-format)) (unless bin-routine (error "could not find any input routine for ~S" target-type))) (when character-stream-p - (multiple-value-setq (cin-routine cin-type cin-size read-n-characters - normalized-external-format) - (pick-input-routine target-type external-format)) + (setf (values cin-routine cin-type cin-size read-n-characters + char-size normalized-external-format) + (pick-input-routine target-type external-format)) (unless cin-routine (error "could not find any input routine for ~S" target-type))) (setf (fd-stream-in fd-stream) cin-routine @@ -1754,8 +1765,8 @@ (setf input-size (or cin-size bin-size)) (setf input-type (or cin-type bin-type)) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when (= (or cin-size 1) (or bin-size 1) 1) (setf (fd-stream-n-bin fd-stream) ;XXX (if (and character-stream-p (not bivalent-stream-p)) @@ -1782,30 +1793,33 @@ (when output-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bout-routine bout-type bout-size output-bytes - normalized-external-format) - (pick-output-routine (if bivalent-stream-p - '(unsigned-byte 8) - target-type) - (fd-stream-buffering fd-stream) - external-format)) + (setf (values bout-routine bout-type bout-size output-bytes + char-size normalized-external-format) + (let ((buffering (fd-stream-buffering fd-stream))) + (if bivalent-stream-p + (pick-output-routine '(unsigned-byte 8) + (if (eq :line buffering) + :full + buffering) + external-format) + (pick-output-routine target-type buffering external-format)))) (unless bout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when character-stream-p - (multiple-value-setq (cout-routine cout-type cout-size output-bytes - normalized-external-format) - (pick-output-routine target-type - (fd-stream-buffering fd-stream) - external-format)) + (setf (values cout-routine cout-type cout-size output-bytes + char-size normalized-external-format) + (pick-output-routine target-type + (fd-stream-buffering fd-stream) + external-format)) (unless cout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when character-stream-p (setf (fd-stream-output-bytes fd-stream) output-bytes)) (setf (fd-stream-out fd-stream) cout-routine @@ -2064,6 +2078,7 @@ (flush-output-buffer stream) (do () ((null (fd-stream-output-queue stream))) + (aver (fd-stream-serve-events stream)) (serve-all-events))) (defun fd-stream-get-file-position (stream) @@ -2165,6 +2180,9 @@ ;;; FILE is the name of the file (will be returned by PATHNAME). ;;; ;;; NAME is used to identify the stream when printed. +;;; +;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to +;;; handle blocking IO on the stream. (defun make-fd-stream (fd &key (input nil input-p) @@ -2172,6 +2190,7 @@ (element-type 'base-char) (buffering :full) (external-format :default) + serve-events timeout file original @@ -2190,6 +2209,12 @@ ((not (or input output)) (error "File descriptor must be opened either for input or output."))) (let ((stream (%make-fd-stream :fd fd + :fd-type (progn + #!-win32 (sb!unix:fd-type fd) + ;; KLUDGE. + #!+win32 (if serve-events + :unknown + :regular)) :name name :file file :original original @@ -2197,9 +2222,8 @@ :pathname pathname :buffering buffering :dual-channel-p dual-channel-p - :external-format external-format :bivalent-p (eq element-type :default) - :char-size (external-format-char-size external-format) + :serve-events serve-events :timeout (if timeout (coerce timeout 'single-float) @@ -2392,6 +2416,10 @@ (cond ((numberp fd) (case direction ((:input :output :io) + ;; For O_APPEND opened files, lseek returns 0 until first write. + ;; So we jump ahead here. + (when (eq if-exists :append) + (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd)) (make-fd-stream fd :input input :output output @@ -2402,6 +2430,7 @@ :delete-original delete-original :pathname pathname :dual-channel-p nil + :serve-events nil :input-buffer-p t :auto-close t)) (:probe @@ -2475,13 +2504,17 @@ (with-output-to-string (*error-output*) (setf *stdin* (make-fd-stream 0 :name "standard input" :input t :buffering :line - :external-format (stdstream-external-format nil))) + :element-type :default + :serve-events t + :external-format (stdstream-external-format nil))) (setf *stdout* (make-fd-stream 1 :name "standard output" :output t :buffering :line - :external-format (stdstream-external-format t))) + :element-type :default + :external-format (stdstream-external-format t))) (setf *stderr* (make-fd-stream 2 :name "standard error" :output t :buffering :line - :external-format (stdstream-external-format t))) + :element-type :default + :external-format (stdstream-external-format t))) (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty @@ -2489,6 +2522,7 @@ (make-fd-stream tty :name "the terminal" :input t :output t :buffering :line :external-format (stdstream-external-format t) + :serve-events t :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*))