;;;; 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)))
;;
;; ...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
(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 ()
(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))
;; 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))
(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
(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))))))
(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)
(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.
(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
(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
(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))
(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))
(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"
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"
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"
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"
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"
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"
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))
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
(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))))
(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)))))
(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
;; 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
(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)))
(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)))
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))
(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
+ "~@<Couldn't restore ~S to its original contents ~
+ from ~S while closing ~S: ~2I~_~A~:>"
+ :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
- "~@<couldn't remove ~S: ~2I~_~A~:>"
- :format-arguments (list (fd-stream-file fd-stream)
- (strerror err))))))))
+ (error 'simple-file-error
+ :pathname file
+ :format-control
+ "~@<Couldn't remove ~S while closing ~S: ~2I~_~A~:>"
+ :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
- "~@<couldn't delete ~S during close of ~S: ~
- ~2I~_~A~:>"
- :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
+ "~@<couldn't delete ~S while closing ~S: ~2I~_~A~:>"
+ :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
: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)
(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
;; 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))
(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
projects / sbcl.git / blobdiff