X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=789e9621c8e4c96aa4000f6f08c444f5e5ff5917;hb=b38f10027f48f657f77b290719da4fec30064e25;hp=69505b885362af06134e9a3f2bced31113e9405d;hpb=b021c15b8d8e4ea4740323eaee9535c4e7cb2232;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 69505b8..789e962 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) @@ -156,7 +147,7 @@ ;; the type of element being transfered (element-type 'base-char) ;; the Unix file descriptor - (fd -1 :type fixnum) + (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word) ;; What do we know about the FD? (fd-type :unknown :type keyword) ;; controls when the output buffer is flushed @@ -299,6 +290,8 @@ ((eql errno sb!unix:ewouldblock) ;; Blocking, queue or wair. (queue-or-wait)) + ;; if interrupted on win32, just try again + #!+win32 ((eql errno sb!unix:eintr)) (t (simple-stream-perror "Couldn't write to ~s" stream errno))))))))))))) @@ -435,39 +428,26 @@ :format-arguments (list note-format (list pathname) (strerror errno)))) -(defun stream-decoding-error (stream octets) - (error 'stream-decoding-error - :external-format (stream-external-format stream) - :stream stream - ;; FIXME: dunno how to get at OCTETS currently, or even if - ;; that's the right thing to report. - :octets octets)) -(defun stream-encoding-error (stream code) - (error 'stream-encoding-error - :external-format (stream-external-format stream) - :stream stream - :code code)) - (defun c-string-encoding-error (external-format code) (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. (defun stream-decoding-error-and-handle (stream octet-count) (restart-case - (stream-decoding-error stream - (let* ((buffer (fd-stream-ibuf stream)) - (sap (buffer-sap buffer)) - (head (buffer-head buffer))) - (loop for i from 0 below octet-count - collect (sap-ref-8 sap (+ head i))))) + (error 'stream-decoding-error + :external-format (stream-external-format stream) + :stream stream + :octets (let ((buffer (fd-stream-ibuf stream))) + (sap-ref-octets (buffer-sap buffer) + (buffer-head buffer) + octet-count))) (attempt-resync () :report (lambda (stream) (format stream @@ -499,7 +479,10 @@ (defun stream-encoding-error-and-handle (stream code) (restart-case - (stream-encoding-error stream code) + (error 'stream-encoding-error + :external-format (stream-external-format stream) + :stream stream + :code code) (output-nothing () :report (lambda (stream) (format stream "~@")) @@ -971,6 +954,9 @@ (errno 0) (count 0)) (tagbody + #!+win32 + (go :main) + ;; 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. @@ -1003,7 +989,7 @@ ((lambda (return-reason) (ecase return-reason ((nil)) ; fast path normal cases - ((:wait-for-input) (go :wait-for-input)) + ((:wait-for-input) (go #!-win32 :wait-for-input #!+win32 :main)) ((:closed-flame) (go :closed-flame)) ((:read-error) (go :read-error)))) (without-interrupts @@ -1039,10 +1025,9 @@ (setf (values count errno) (sb!unix:unix-read fd (sap+ sap tail) (- length tail))) (cond ((null count) - #!+win32 - (return :read-error) - #!-win32 - (if (eql errno sb!unix:ewouldblock) + (if (eql errno + #!+win32 sb!unix:eintr + #!-win32 sb!unix:ewouldblock) (return :wait-for-input) (return :read-error))) ((zerop count) @@ -1098,7 +1083,9 @@ (catch 'eof-input-catcher (setf decode-break-reason (block decode-break-reason - (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes))) + (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)) ,@(when (consp bytes) @@ -1598,12 +1585,15 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,(if (consp in-size-expr) (cadr in-size-expr) 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))) @@ -1617,12 +1607,15 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,(if (consp in-size-expr) (cadr in-size-expr) 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) @@ -2033,8 +2026,8 @@ (:external-format (fd-stream-external-format fd-stream)) (:interactive-p - (= 1 (the (member 0 1) - (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) + (plusp (the (integer 0) + (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) (:line-length 80) (:charpos @@ -2050,6 +2043,7 @@ :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) + #!-win32 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) @@ -2059,7 +2053,21 @@ (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) (if (zerop mode) nil - (truncate size (fd-stream-element-size fd-stream))))) + (truncate size (fd-stream-element-size fd-stream)))) + #!+win32 + (let* ((handle (fd-stream-fd fd-stream)) + (element-size (fd-stream-element-size fd-stream))) + (multiple-value-bind (got native-size) + (sb!win32:get-file-size-ex handle 0) + (if (zerop got) + ;; Might be a block device, in which case we fall back to + ;; a non-atomic workaround: + (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr)) + (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd))) + (when (and here there) + (sb!unix:unix-lseek handle here sb!unix:l_set) + (truncate there element-size))) + (truncate native-size element-size))))) (:file-string-length (etypecase arg1 (character (fd-stream-character-size fd-stream arg1)) @@ -2093,7 +2101,7 @@ (declare (fd-stream stream)) (without-interrupts (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr))) - (declare (type (or (alien sb!unix:off-t) null) posn)) + (declare (type (or (alien sb!unix:unix-offset) null) posn)) ;; We used to return NIL for errno==ESPIPE, and signal an error ;; in other failure cases. However, CLHS says to return NIL if ;; the position cannot be determined -- so that's what we do. @@ -2122,7 +2130,7 @@ (defun fd-stream-set-file-position (stream position-spec) (declare (fd-stream stream)) (check-type position-spec - (or (alien sb!unix:off-t) (member nil :start :end)) + (or (alien sb!unix:unix-offset) (member nil :start :end)) "valid file position designator") (tagbody :again @@ -2154,7 +2162,7 @@ (t (values (* position-spec (fd-stream-element-size stream)) sb!unix:l_set))) - (declare (type (alien sb!unix:off-t) offset)) + (declare (type (alien sb!unix:unix-offset) offset)) (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) offset origin))) ;; CLHS says to return true if the file-position was set @@ -2166,7 +2174,7 @@ ;; FIXME: We are still liable to signal an error if flushing ;; output fails. (return-from fd-stream-set-file-position - (typep posn '(alien sb!unix:off-t)))))))) + (typep posn '(alien sb!unix:unix-offset)))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -2495,9 +2503,15 @@ (without-package-locks (makunbound '*available-buffers*)))) -(defun stdstream-external-format (outputp) - (declare (ignorable outputp)) - (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage)) +(defun stdstream-external-format (fd outputp) + #!-win32 (declare (ignore fd outputp)) + (let* ((keyword #!+win32 (if (and (/= fd -1) + (logbitp 0 fd) + (logbitp 1 fd)) + :ucs-2 + (if outputp + (sb!win32::console-output-codepage) + (sb!win32::console-input-codepage))) #!-win32 (default-external-format)) (ef (get-external-format keyword)) (replacement (ef-default-replacement-character ef))) @@ -2510,27 +2524,34 @@ (aver (not (boundp '*available-buffers*))) (setf *available-buffers* nil))) (with-output-to-string (*error-output*) - (setf *stdin* - (make-fd-stream 0 :name "standard input" :input t :buffering :line - :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 - :element-type :default - :external-format (stdstream-external-format t))) - (setf *stderr* - (make-fd-stream 2 :name "standard error" :output t :buffering :line - :element-type :default - :external-format (stdstream-external-format t))) + (multiple-value-bind (in out err) + #!-win32 (values 0 1 2) + #!+win32 (sb!win32::get-std-handles) + (flet ((stdio-stream (handle name inputp outputp) + (make-fd-stream + handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :external-format (stdstream-external-format handle outputp)))) + (setf *stdin* (stdio-stream in "standard input" t nil)) + (setf *stdout* (stdio-stream out "standard output" nil t)) + (setf *stderr* (stdio-stream err "standard error" nil t)))) + #!+win32 + (setf *tty* (make-two-way-stream *stdin* *stdout*)) + #!-win32 (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty (setf *tty* (make-fd-stream tty :name "the terminal" :input t :output t :buffering :line - :external-format (stdstream-external-format t) - :serve-events t + :external-format (stdstream-external-format + tty t) + :serve-events (or #!-win32 t) :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*))