X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=771cd10e7c2cfbaeea272a13c5b6a1bf93900a5a;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=374d10bee741db199582187a56236e9300ea78f8;hpb=34652b637f023fb24cf76df53e6a1936e94ce9ec;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 374d10b..771cd10 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -16,12 +16,29 @@ ;;;; Streams hold BUFFER objects, which contain a SAP, size of the ;;;; memory area the SAP stands for (LENGTH bytes), and HEAD and TAIL ;;;; indexes which delimit the "valid", or "active" area of the -;;;; memory. +;;;; memory. HEAD is inclusive, TAIL is exclusive. ;;;; ;;;; Buffers get allocated lazily, and are recycled by returning them ;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has it's own ;;;; finalizer, to take care of releasing the SAP memory when a stream ;;;; is not properly closed. +;;;; +;;;; The code aims to provide a limited form of thread and interrupt +;;;; safety: parallel writes and reads may lose output or input, cause +;;;; interleaved IO, etc -- but they should not corrupt memory. The +;;;; key to doing this is to read buffer state once, and update the +;;;; state based on the read state: +;;;; +;;;; (let ((tail (buffer-tail buffer))) +;;;; ... +;;;; (setf (buffer-tail buffer) (+ tail n))) +;;;; +;;;; NOT +;;;; +;;;; (let ((tail (buffer-tail buffer))) +;;;; ... +;;;; (incf (buffer-tail buffer) n)) +;;;; (declaim (inline buffer-sap buffer-length buffer-head buffer-tail (setf buffer-head) (setf buffer-tail))) @@ -53,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 @@ -65,8 +82,11 @@ (without-interrupts (let* ((sap (allocate-system-memory size)) (buffer (%make-buffer sap size))) + (when (zerop (sap-int sap)) + (error "Could not allocate ~D bytes for buffer." size)) (finalize buffer (lambda () - (deallocate-system-memory sap size))) + (deallocate-system-memory sap size)) + :dont-save t) buffer))) (defun get-buffer () @@ -97,7 +117,7 @@ (let ((ibuf (fd-stream-ibuf fd-stream)) (obuf (fd-stream-obuf fd-stream)) (queue (loop for item in (fd-stream-output-queue fd-stream) - when (bufferp item) + when (buffer-p item) collect (reset-buffer item)))) (when ibuf (push (reset-buffer ibuf) queue)) @@ -165,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)) @@ -181,16 +203,19 @@ (error ":END before :START!")) (when (> end start) ;; Copy bytes from THING to buffers. - (flet ((copy-to-buffer (buffer offset count) - (declare (buffer buffer) (index offset count)) + (flet ((copy-to-buffer (buffer tail count) + (declare (buffer buffer) (index tail count)) (aver (plusp count)) (let ((sap (buffer-sap buffer))) (etypecase thing (system-area-pointer - (system-area-ub8-copy thing start sap offset count)) + (system-area-ub8-copy thing start sap tail count)) ((simple-unboxed-array (*)) - (copy-ub8-to-system-area thing start sap offset count)))) - (incf (buffer-tail buffer) count) + (copy-ub8-to-system-area thing start sap tail count)))) + ;; Not INCF! If another thread has moved tail from under + ;; us, we don't want to accidentally increment tail + ;; beyond buffer-length. + (setf (buffer-tail buffer) (+ count tail)) (incf start count))) (tagbody ;; First copy is special: the buffer may already contain @@ -202,12 +227,13 @@ (copy-to-buffer obuf tail (min space (- end start))) (go :more-output-p))) :flush-and-fill - ;; Later copies always have an empty buffer, since they are freshly - ;; flushed. + ;; Later copies should always have an empty buffer, since + ;; they are freshly flushed, but if another thread is + ;; stomping on the same buffer that might not be the case. (let* ((obuf (flush-output-buffer stream)) - (offset (buffer-tail obuf))) - (aver (zerop offset)) - (copy-to-buffer obuf offset (min (buffer-length obuf) (- end start)))) + (tail (buffer-tail obuf)) + (space (- (buffer-length obuf) tail))) + (copy-to-buffer obuf tail (min space (- end start)))) :more-output-p (when (> end start) (go :flush-and-fill)))))) @@ -237,20 +263,24 @@ (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) + (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. - (incf (buffer-head obuf) count) + ;; 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))))))))))) + (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) @@ -286,8 +316,10 @@ (head (buffer-head buffer)) (length (- (buffer-tail buffer) head))) (declare (index head length)) + (aver (>= length 0)) (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) head length) + (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) + head length) (cond ((eql count length) ;; Complete write, see if we can do another right ;; away, or remove the handler if we're done. @@ -303,7 +335,8 @@ (count ;; Partial write. Update buffer status and requeue. (aver (< count length)) - (incf (buffer-head buffer) (or count 0)) + ;; Do not use INCF! Another thread might have moved head. + (setf (buffer-head buffer) (+ head count)) (push buffer (fd-stream-output-queue stream))) (not-first-p ;; We tried to do multiple writes, and finally our @@ -315,8 +348,9 @@ (simple-stream-perror "Couldn't write to ~S." stream errno) #!-win32 (if (= errno sb!unix:ewouldblock) - (bug "Unexpected blocking write in WRITE-OUTPUT-FROM-QUEUE.") - (simple-stream-perror "Couldn't write to ~S" stream errno)))))))) + (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.") + (simple-stream-perror "Couldn't write to ~S" + stream errno)))))))) nil) ;;; Try to write THING directly to STREAM without buffering, if @@ -384,12 +418,14 @@ (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)) @@ -416,7 +452,7 @@ (attempt-resync () :report (lambda (stream) (format stream - "~@")) (fd-stream-resync stream) nil) @@ -454,29 +490,30 @@ (defun fd-stream-output-finished-p (stream) (let ((obuf (fd-stream-obuf stream))) (or (not obuf) - (and (zerop (buffer-tail obuf))) - (not (fd-stream-output-queue stream))))) + (and (zerop (buffer-tail obuf)) + (not (fd-stream-output-queue stream)))))) (defmacro output-wrapper/variable-width ((stream size buffering restart) &body body) (let ((stream-var (gensym "STREAM"))) `(let* ((,stream-var ,stream) (obuf (fd-stream-obuf ,stream-var)) + (tail (buffer-tail obuf)) (size ,size)) ,(unless (eq (car buffering) :none) - `(when (< (buffer-length obuf) - (+ (buffer-tail obuf) size)) - (setf obuf (flush-output-buffer ,stream-var)))) + `(when (<= (buffer-length obuf) (+ tail size)) + (setf obuf (flush-output-buffer ,stream-var) + tail (buffer-tail obuf)))) ,(unless (eq (car buffering) :none) ;; FIXME: Why this here? Doesn't seem necessary. `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body - (incf (buffer-tail obuf) size)) + (setf (buffer-tail obuf) (+ tail size))) `(progn ,@body - (incf (buffer-tail obuf) size))) + (setf (buffer-tail obuf) (+ tail size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) @@ -489,21 +526,22 @@ (defmacro output-wrapper ((stream size buffering restart) &body body) (let ((stream-var (gensym "STREAM"))) `(let* ((,stream-var ,stream) - (obuf (fd-stream-obuf ,stream-var))) + (obuf (fd-stream-obuf ,stream-var)) + (tail (buffer-tail obuf))) ,(unless (eq (car buffering) :none) - `(when (< (buffer-length obuf) - (+ (buffer-tail obuf) ,size)) - (setf obuf (flush-output-buffer ,stream-var)))) + `(when (<= (buffer-length obuf) (+ tail ,size)) + (setf obuf (flush-output-buffer ,stream-var) + tail (buffer-tail obuf)))) ;; FIXME: Why this here? Doesn't seem necessary. ,(unless (eq (car buffering) :none) `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body - (incf (buffer-tail obuf) ,size)) + (setf (buffer-tail obuf) (+ tail ,size))) `(progn ,@body - (incf (buffer-tail obuf) ,size))) + (setf (buffer-tail obuf) (+ tail ,size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) @@ -575,7 +613,7 @@ (if (eql byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) - (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf)) + (setf (sap-ref-8 (buffer-sap obuf) tail) (char-code byte))) (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" @@ -583,7 +621,7 @@ nil (:none (unsigned-byte 8)) (:full (unsigned-byte 8))) - (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf)) + (setf (sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" @@ -591,7 +629,7 @@ nil (:none (signed-byte 8)) (:full (signed-byte 8))) - (setf (signed-sap-ref-8 (buffer-sap obuf) (buffer-tail obuf)) + (setf (signed-sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" @@ -599,7 +637,7 @@ nil (:none (unsigned-byte 16)) (:full (unsigned-byte 16))) - (setf (sap-ref-16 (buffer-sap obuf) (buffer-tail obuf)) + (setf (sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" @@ -607,7 +645,7 @@ nil (:none (signed-byte 16)) (:full (signed-byte 16))) - (setf (signed-sap-ref-16 (buffer-sap obuf) (buffer-tail obuf)) + (setf (signed-sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" @@ -615,7 +653,7 @@ nil (:none (unsigned-byte 32)) (:full (unsigned-byte 32))) - (setf (sap-ref-32 (buffer-sap obuf) (buffer-tail obuf)) + (setf (sap-ref-32 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" @@ -623,7 +661,7 @@ nil (:none (signed-byte 32)) (:full (signed-byte 32))) - (setf (signed-sap-ref-32 (buffer-sap obuf) (buffer-tail obuf)) + (setf (signed-sap-ref-32 (buffer-sap obuf) tail) byte)) #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) @@ -633,14 +671,14 @@ nil (:none (unsigned-byte 64)) (:full (unsigned-byte 64))) - (setf (sap-ref-64 (buffer-sap obuf) (buffer-tail obuf)) + (setf (sap-ref-64 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED" 8 nil (:none (signed-byte 64)) (:full (signed-byte 64))) - (setf (signed-sap-ref-64 (buffer-sap obuf) (buffer-tail obuf)) + (setf (signed-sap-ref-64 (buffer-sap obuf) tail) byte))) ;;; the routine to use to output a string. If the stream is @@ -737,14 +775,14 @@ (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) - (+ j (buffer-tail obuf))) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) - (+ j (buffer-tail obuf))) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(unsigned-byte ,i) (/ i 8)))) @@ -758,14 +796,14 @@ (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) - (+ j (buffer-tail obuf))) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) - (+ j (buffer-tail obuf))) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(signed-byte ,i) (/ i 8))))) @@ -785,10 +823,10 @@ ;;; correct on win32. However, none of the places that use it require ;;; further assurance than "may" versus "will definitely not". (defun sysread-may-block-p (stream) - #+win32 + #!+win32 ;; This answers T at EOF on win32, I think. (not (sb!win32:fd-listen (fd-stream-fd stream))) - #-win32 + #!-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) @@ -808,9 +846,9 @@ ;;; then fill the input buffer, and return the number of bytes read. Throws ;;; to EOF-INPUT-CATCHER if the eof was reached. (defun refill-input-buffer (stream) - (let ((fd (fd-stream-fd stream)) - (errno 0) - (count 0)) + (dx-let ((fd (fd-stream-fd stream)) + (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 @@ -834,50 +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! - (incf (buffer-tail ibuf) count)))))) + + ;; 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 @@ -1201,7 +1250,7 @@ (declare (type index start end)) (synchronize-stream-output stream) (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) + (sequence-bounding-indices-bad-error string start end)) (do () ((= end start)) (let ((obuf (fd-stream-obuf stream))) @@ -1378,7 +1427,7 @@ (declare (type index start end)) (synchronize-stream-output stream) (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) + (sequence-bounding-indices-bad string start end)) (do () ((= end start)) (let ((obuf (fd-stream-obuf stream))) @@ -1904,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)) @@ -1989,67 +2044,77 @@ (setf (fd-stream-unread fd-stream) arg1) (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. + ;; Drop input buffers + (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+ + (ansi-stream-cin-buffer fd-stream) nil + (ansi-stream-in-buffer fd-stream) nil) + (cond (arg1 + ;; We got us an abort on our hands. + (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 @@ -2250,6 +2315,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) @@ -2262,7 +2328,8 @@ (sb!unix:unix-close fd) #!+sb-show (format *terminal-io* "** closed file descriptor ~W **~%" - fd)))) + fd)) + :dont-save t)) stream)) ;;; Pick a name to use for the backup file for the :IF-EXISTS @@ -2319,7 +2386,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)) @@ -2496,9 +2563,19 @@ (setf *trace-output* *standard-output*) (values)) +(defun stream-deinit () + ;; Unbind to make sure we're not accidently dealing with it + ;; before we're ready (or after we think it's been deinitialized). + (with-available-buffers-lock () + (without-package-locks + (makunbound '*available-buffers*)))) + ;;; This is called whenever a saved core is restarted. -(defun stream-reinit () - (setf *available-buffers* nil) +(defun stream-reinit (&optional init-buffers-p) + (when init-buffers-p + (with-available-buffers-lock () + (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