X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=1428363c0541ced5448e35dc1e16dc25677f5885;hb=496071a75429677a2c064e4995c379d3ba6ec458;hp=9a7ce726876ad137238f1f3de54f326afc626026;hpb=b86daba1860b622636d9e8f655a3f96de4d86801;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 9a7ce72..1428363 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -70,8 +70,8 @@ ;; ;; ...again, once we have smarted locks the spinlock here can become ;; a mutex. - `(sb!thread::call-with-system-spinlock (lambda () ,@body) - *available-buffers-spinlock*)) + `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) #!+sb-doc @@ -185,6 +185,8 @@ ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null)) (external-format :default) + ;; fixed width, or function to call with a character + (char-size 1 :type (or fixnum function)) (output-bytes #'ill-out :type function)) (def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) @@ -845,6 +847,8 @@ (let ((fd (fd-stream-fd stream)) (errno 0) (count 0)) + (declare (optimize sb!c::stack-allocate-value-cells) + (dynamic-extent fd errno count)) (tagbody ;; Check for blocking input before touching the stream, as if ;; we happen to wait we are liable to be interrupted, and the @@ -868,49 +872,61 @@ ;; 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 - ;; Check the buffer: 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. - (let* ((ibuf (or (fd-stream-ibuf stream) (go :closed-flame))) - (sap (buffer-sap ibuf)) - (length (buffer-length ibuf)) - (head (buffer-head ibuf)) - (tail (buffer-tail ibuf))) - (declare (index length head tail)) - (unless (zerop head) - (cond ((eql head tail) - ;; Buffer is empty, but not at yet reset -- make it so. - (setf head 0 - tail 0) - (reset-buffer ibuf)) - (t - ;; Buffer has things in it, but they are not at the head - ;; -- move them there. - (let ((n (- tail head))) - (system-area-ub8-copy sap head sap 0 n) - (setf head 0 - (buffer-head ibuf) head - tail n - (buffer-tail ibuf) tail))))) - (setf (fd-stream-listen stream) nil) - (setf (values count errno) - (sb!unix:unix-read fd (sap+ sap tail) (- length 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! (Do not use INCF, for sake of other threads.) - (setf (buffer-tail ibuf) (+ count tail))))))) + + ;; Execute the nlx outside without-interrupts to ensure the + ;; resulting thunk is stack-allocatable. + ((lambda (return-reason) + (ecase return-reason + ((nil)) ; fast path normal cases + ((:wait-for-input) (go :wait-for-input)) + ((:closed-flame) (go :closed-flame)) + ((:read-error) (go :read-error)))) + (without-interrupts + ;; Check the buffer: 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. + (block nil + (prog1 nil + (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame))) + (sap (buffer-sap ibuf)) + (length (buffer-length ibuf)) + (head (buffer-head ibuf)) + (tail (buffer-tail ibuf))) + (declare (index length head tail) + (inline sb!unix:unix-read)) + (unless (zerop head) + (cond ((eql head tail) + ;; Buffer is empty, but not at yet reset -- make it so. + (setf head 0 + tail 0) + (reset-buffer ibuf)) + (t + ;; Buffer has things in it, but they are not at the + ;; head -- move them there. + (let ((n (- tail head))) + (system-area-ub8-copy sap head sap 0 n) + (setf head 0 + (buffer-head ibuf) head + tail n + (buffer-tail ibuf) tail))))) + (setf (fd-stream-listen stream) nil) + (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) + (return :wait-for-input) + (return :read-error))) + ((zerop count) + (setf (fd-stream-listen stream) :eof) + (/show0 "THROWing EOF-INPUT-CATCHER") + (throw 'eof-input-catcher nil)) + (t + ;; Success! (Do not use INCF, for sake of other threads.) + (setf (buffer-tail ibuf) (+ count tail)))))))))) count)) ;;; Make sure there are at least BYTES number of bytes in the input @@ -1937,20 +1953,26 @@ input-type output-type)))))) -;;; Handles the resource-release aspects of stream closing. +;;; Handles the resource-release aspects of stream closing, and marks +;;; it as closed. (defun release-fd-stream-resources (fd-stream) (handler-case (without-interrupts + ;; Drop handlers first. + (when (fd-stream-handler fd-stream) + (remove-fd-handler (fd-stream-handler fd-stream)) + (setf (fd-stream-handler fd-stream) nil)) ;; Disable interrupts so that a asynch unwind will not leave ;; us with a dangling finalizer (that would close the same - ;; --possibly reassigned-- FD again). + ;; --possibly reassigned-- FD again), or a stream with a closed + ;; FD that appears open. (sb!unix:unix-close (fd-stream-fd fd-stream)) + (set-closed-flame fd-stream) (when (fboundp 'cancel-finalization) (cancel-finalization fd-stream))) ;; On error unwind from WITHOUT-INTERRUPTS. (serious-condition (e) (error e))) - ;; Release all buffers. If this is undone, or interrupted, ;; we're still safe: buffers have finalizers of their own. (release-fd-stream-buffers fd-stream)) @@ -2023,66 +2045,71 @@ (setf (fd-stream-listen fd-stream) t)) (:close (cond (arg1 ; We got us an abort on our hands. - (when (fd-stream-handler fd-stream) - (remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) - ;; We can't do anything unless we know what file were - ;; dealing with, and we don't want to do anything - ;; strange unless we were writing to the file. - (when (and (fd-stream-file fd-stream) (fd-stream-obuf fd-stream)) - (if (fd-stream-original fd-stream) - ;; If the original is EQ to file we are appending - ;; and can just close the file without renaming. - (unless (eq (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - ;; We have a handle on the original, just revert. + (let ((outputp (fd-stream-obuf fd-stream)) + (file (fd-stream-file fd-stream)) + (orig (fd-stream-original fd-stream))) + ;; This takes care of the important stuff -- everything + ;; rest is cleaning up the file-system, which we cannot + ;; do on some platforms as long as the file is open. + (release-fd-stream-resources fd-stream) + ;; We can't do anything unless we know what file were + ;; dealing with, and we don't want to do anything + ;; strange unless we were writing to the file. + (when (and outputp file) + (if orig + ;; If the original is EQ to file we are appending to + ;; and can just close the file without renaming. + (unless (eq orig file) + ;; We have a handle on the original, just revert. + (multiple-value-bind (okay err) + (sb!unix:unix-rename orig file) + ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the + ;; others are SIMPLE-FILE-ERRORS? Surely they should + ;; all be the same? + (unless okay + (error 'simple-stream-error + :format-control + "~@" + :format-arguments + (list file orig fd-stream (strerror err)) + :stream fd-stream)))) + ;; We can't restore the original, and aren't + ;; appending, so nuke that puppy. + ;; + ;; FIXME: This is currently the fate of superseded + ;; files, and according to the CLOSE spec this is + ;; wrong. However, there seems to be no clean way to + ;; do that that doesn't involve either copying the + ;; data (bad if the :abort resulted from a full + ;; disk), or renaming the old file temporarily + ;; (probably bad because stream opening becomes more + ;; racy). (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) + (sb!unix:unix-unlink file) (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err)))) - ;; We can't restore the original, and aren't - ;; appending, so nuke that puppy. - ;; - ;; FIXME: This is currently the fate of superseded - ;; files, and according to the CLOSE spec this is - ;; wrong. However, there seems to be no clean way to - ;; do that that doesn't involve either copying the - ;; data (bad if the :abort resulted from a full - ;; disk), or renaming the old file temporarily - ;; (probably bad because stream opening becomes more - ;; racy). - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-file fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-file fd-stream) - :format-control - "~@" - :format-arguments (list (fd-stream-file fd-stream) - (strerror err)))))))) + (error 'simple-file-error + :pathname file + :format-control + "~@" + :format-arguments + (list file fd-stream (strerror err))))))))) (t (finish-fd-stream-output fd-stream) - (when (and (fd-stream-original fd-stream) - (fd-stream-delete-original fd-stream)) - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-original fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-original fd-stream) - :format-control - "~@" - :format-arguments - (list (fd-stream-original fd-stream) - fd-stream - (strerror err)))))))) - (release-fd-stream-resources fd-stream) - ;; Mark as closed. FIXME: Maybe this should be the first thing done? - (sb!impl::set-closed-flame fd-stream)) + (let ((orig (fd-stream-original fd-stream))) + (when (and orig (fd-stream-delete-original fd-stream)) + (multiple-value-bind (okay err) (sb!unix:unix-unlink orig) + (unless okay + (error 'simple-file-error + :pathname orig + :format-control + "~@" + :format-arguments + (list orig fd-stream (strerror err))))))) + ;; In case of no-abort close, don't *really* close the + ;; stream until the last moment -- the cleaning up of the + ;; original can be done first. + (release-fd-stream-resources fd-stream)))) (:clear-input (fd-stream-clear-input fd-stream)) (:force-output @@ -2283,6 +2310,7 @@ :buffering buffering :dual-channel-p dual-channel-p :external-format external-format + :char-size (external-format-char-size external-format) :timeout (if timeout (coerce timeout 'single-float) @@ -2353,7 +2381,7 @@ ;; Calculate useful stuff. (multiple-value-bind (input output mask) - (case direction + (ecase direction (:input (values t nil sb!unix:o_rdonly)) (:output (values nil t sb!unix:o_wronly)) (:io (values t t sb!unix:o_rdwr))