X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=37ae9970891173ced318e34db34a71c53ca29547;hb=ef716ee5409d0d55020aea422e29a9175c2b4b74;hp=7bef99d3d3e0b06380c0c91ba563de92ef1d2b4e;hpb=176df6fde6fb14b3dd158785d8a30e98a375ff77;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 7bef99d..37ae997 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -18,21 +18,19 @@ (defvar *available-buffers* () #!+sb-doc "List of available buffers. Each buffer is an sap pointing to - bytes-per-buffer of memory.") +bytes-per-buffer of memory.") -#!+sb-thread (defvar *available-buffers-mutex* (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) - ;; WITHOUT-INTERRUPTS because streams are low-level enough to be + ;; 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 - `(without-interrupts - (sb!thread:with-mutex (*available-buffers-mutex*) - ,@body))) + `(sb!thread::call-with-system-mutex (lambda () ,@body) + *available-buffers-mutex*)) (defconstant bytes-per-buffer (* 4 1024) #!+sb-doc @@ -221,7 +219,8 @@ ((not (null count)) ; sorta worked.. (push (list base (the index (+ start count)) - end) + end + reuse-sap) (fd-stream-output-later stream)))))) (unless (fd-stream-output-later stream) (remove-fd-handler (fd-stream-handler stream)) @@ -1229,26 +1228,22 @@ (let* ((length (length string)) (,n-buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8))) - ;; This SAP-taking may seem unsafe without pinning, - ;; but since the variable name is a gensym OUT-EXPR - ;; cannot close over it even if it tried, so the buffer - ;; will always be either in a register or on stack. - ;; FIXME: But ...this is true on x86oids only! - (sap (vector-sap ,n-buffer)) (tail 0) (stream ,name)) - (declare (type index length tail) - (type system-area-pointer sap)) - (dotimes (i length) - (let* ((byte (aref string i)) - (bits (char-code byte))) - (declare (ignorable byte bits)) - ,out-expr) - (incf tail ,size)) - (let* ((bits 0) - (byte (code-char bits))) - (declare (ignorable bits byte)) - ,out-expr) + (declare (type index length tail)) + (with-pinned-objects (,n-buffer) + (let ((sap (vector-sap ,n-buffer))) + (declare (system-area-pointer sap)) + (dotimes (i length) + (let* ((byte (aref string i)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + ,out-expr) + (incf tail ,size)) + (let* ((bits 0) + (byte (code-char bits))) + (declare (ignorable bits byte)) + ,out-expr))) ,n-buffer))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function @@ -1481,29 +1476,25 @@ (tail 0) (,n-buffer (make-array buffer-length :element-type '(unsigned-byte 8))) - ;; This SAP-taking may seem unsafe without pinning, - ;; but since the variable name is a gensym OUT-EXPR - ;; cannot close over it even if it tried, so the buffer - ;; will always be either in a register or on stack. - ;; FIXME: But ...this is true on x86oids only! - (sap (vector-sap ,n-buffer)) stream) (declare (type index length buffer-length tail) - (type system-area-pointer sap) (type null stream) (ignorable stream)) - (loop for i of-type index below length - for byte of-type character = (aref string i) - for bits = (char-code byte) - for size of-type index = (aref char-length i) - do (prog1 - ,out-expr - (incf tail size))) - (let* ((bits 0) - (byte (code-char bits)) - (size (aref char-length length))) - (declare (ignorable bits byte size)) - ,out-expr) + (with-pinned-objects (,n-buffer) + (let ((sap (vector-sap ,n-buffer))) + (declare (system-area-pointer sap)) + (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + for size of-type index = (aref char-length i) + do (prog1 + ,out-expr + (incf tail size))) + (let* ((bits 0) + (byte (code-char bits)) + (size (aref char-length length))) + (declare (ignorable bits byte size)) + ,out-expr))) ,n-buffer))) (setf *external-formats*