1.0.7.30: be more paranoid about saps

[sbcl.git] / src / code / fd-stream.lisp

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 6c73160..26d8f07 100644 (file)
--- 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
@@ -1111,7 +1109,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
-                                    (simple-array character)
+                                    (simple-array character (*))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))
@@ -1229,26 +1227,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
@@ -1291,7 +1285,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
-                                    (simple-array character)
+                                    (simple-array character (*))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))
@@ -1481,29 +1475,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*