(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
;;; unbuffered, slam the string down the file descriptor, otherwise
;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
;;; checking to see where the last newline was.
-;;;
-;;; Note: some bozos (the FASL dumper) call write-string with things
-;;; other than strings. Therefore, we must make sure we have a string
-;;; before calling POSITION on it.
-;;; KLUDGE: It would be better to fix the bozos instead of trying to
-;;; cover for them here. -- WHN 20000203
(defun fd-sout (stream thing start end)
+ (declare (type fd-stream stream) (type string thing))
(let ((start (or start 0))
(end (or end (length (the vector thing)))))
(declare (fixnum start end))
- (if (stringp thing)
- (let ((last-newline
- (string-dispatch (simple-base-string
- #!+sb-unicode
- (simple-array character)
- string)
- thing
- (and (find #\newline thing :start start :end end)
- ;; FIXME why do we need both calls?
- ;; Is find faster forwards than
- ;; position is backwards?
- (position #\newline thing
- :from-end t
- :start start
- :end end)))))
- (if (and (typep thing 'base-string)
- (eq (fd-stream-external-format stream) :latin-1))
- (ecase (fd-stream-buffering stream)
- (:full
- (output-raw-bytes stream thing start end))
- (:line
- (output-raw-bytes stream thing start end)
- (when last-newline
- (flush-output-buffer stream)))
- (:none
- (frob-output stream thing start end nil)))
- (ecase (fd-stream-buffering stream)
- (:full (funcall (fd-stream-output-bytes stream)
- stream thing nil start end))
- (:line (funcall (fd-stream-output-bytes stream)
- stream thing last-newline start end))
- (:none (funcall (fd-stream-output-bytes stream)
- stream thing t start end))))
- (if last-newline
- (setf (fd-stream-char-pos stream)
- (- end last-newline 1))
- (incf (fd-stream-char-pos stream)
- (- end start))))
- (ecase (fd-stream-buffering stream)
- ((:line :full)
- (output-raw-bytes stream thing start end))
- (:none
- (frob-output stream thing start end nil))))))
+ (let ((last-newline
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character (*))
+ string)
+ thing
+ (position #\newline thing :from-end t
+ :start start :end end))))
+ (if (and (typep thing 'base-string)
+ (eq (fd-stream-external-format stream) :latin-1))
+ (ecase (fd-stream-buffering stream)
+ (:full
+ (output-raw-bytes stream thing start end))
+ (:line
+ (output-raw-bytes stream thing start end)
+ (when last-newline
+ (flush-output-buffer stream)))
+ (:none
+ (frob-output stream thing start end nil)))
+ (ecase (fd-stream-buffering stream)
+ (:full (funcall (fd-stream-output-bytes stream)
+ stream thing nil start end))
+ (:line (funcall (fd-stream-output-bytes stream)
+ stream thing last-newline start end))
+ (:none (funcall (fd-stream-output-bytes stream)
+ stream thing t start end))))
+ (if last-newline
+ (setf (fd-stream-char-pos stream) (- end last-newline 1))
+ (incf (fd-stream-char-pos stream) (- end start))))))
(defvar *external-formats* ()
#!+sb-doc
(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))
(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
(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))
(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*
projects / sbcl.git / blobdiff