X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=0ef85b1ff67a2d209316d788fa15ed764552d603;hb=abd50c820df25616883a6850df1780044365137e;hp=1c96917089e524990f0c922610ea509482dfded2;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 1c96917..0ef85b1 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -20,6 +20,20 @@ "List of available buffers. Each buffer is an sap pointing to 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 + ;; 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))) + (defconstant bytes-per-buffer (* 4 1024) #!+sb-doc "Number of bytes per buffer.") @@ -27,9 +41,10 @@ ;;; Return the next available buffer, creating one if necessary. #!-sb-fluid (declaim (inline next-available-buffer)) (defun next-available-buffer () - (if *available-buffers* - (pop *available-buffers*) - (allocate-system-memory bytes-per-buffer))) + (with-available-buffers-lock () + (if *available-buffers* + (pop *available-buffers*) + (allocate-system-memory bytes-per-buffer)))) ;;;; the FD-STREAM structure @@ -177,7 +192,8 @@ (simple-stream-perror "couldn't write to ~S" stream errno))) ((eql count length) ; Hot damn, it worked. (when reuse-sap - (push base *available-buffers*))) + (with-available-buffers-lock () + (push base *available-buffers*)))) ((not (null count)) ; sorta worked.. (push (list base (the index (+ start count)) @@ -1013,6 +1029,7 @@ &aux (total-copied 0)) (declare (type fd-stream stream)) (declare (type index start requested total-copied)) + (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) (let ((unread (fd-stream-unread stream))) (when unread (setf (aref buffer start) unread) @@ -1119,6 +1136,7 @@ &aux (total-copied 0)) (declare (type fd-stream stream)) (declare (type index start requested total-copied)) + (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) (let ((unread (fd-stream-unread stream))) (when unread (setf (aref buffer start) unread) @@ -1198,7 +1216,10 @@ ,resync-function) *external-formats*))))) -(define-external-format (:latin-1 :latin1 :iso-8859-1) +;;; Multiple names for the :ISO{,-}8859-* families are needed because on +;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will +;;; return "ISO8859-1" instead of "ISO-8859-1". +(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1) 1 t (if (>= bits 256) (stream-encoding-error-and-handle stream bits) @@ -1265,7 +1286,7 @@ (latin-9-reverse-2 (make-array 16 :element-type '(unsigned-byte 8) :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0)))) - (define-external-format (:latin-9 :latin9 :iso-8859-15) + (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15) 1 t (setf (sap-ref-8 sap tail) (if (< bits 256) @@ -1358,11 +1379,13 @@ ;; drop buffers when direction changes (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil))) (when (and (fd-stream-ibuf-sap fd-stream) (not input-p)) - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil))) (when input-p (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer)) (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer) @@ -1376,26 +1399,7 @@ (when (and character-stream-p (eq external-format :default)) (/show0 "/getting default external format") - (setf external-format (default-external-format)) - (/show0 "cold-printing defaulted external-format:") - #!+sb-show - (cold-print external-format) - (/show0 "matching to known aliases") - (dolist (entry *external-formats* - (restart-case - (error "Invalid external-format ~A" - external-format) - (use-default () - :report "Set external format to LATIN-1" - (setf external-format :latin-1)))) - (/show0 "cold printing known aliases:") - #!+sb-show - (dolist (alias (first entry)) (cold-print alias)) - (/show0 "done cold-printing known aliases") - (when (member external-format (first entry)) - (/show0 "matched") - (return))) - (/show0 "/default external format ok")) + (setf external-format (default-external-format))) (when input-p (when (or (not character-stream-p) bivalent-stream-p) @@ -1588,11 +1592,13 @@ (cancel-finalization fd-stream)) (sb!unix:unix-close (fd-stream-fd fd-stream)) (when (fd-stream-obuf-sap fd-stream) - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil))) (when (fd-stream-ibuf-sap fd-stream) - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil)) + (with-available-buffers-lock () + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil))) (sb!impl::set-closed-flame fd-stream)) (:clear-input (setf (fd-stream-unread fd-stream) nil) @@ -2034,23 +2040,25 @@ ;;; This is called whenever a saved core is restarted. (defun stream-reinit () (setf *available-buffers* nil) - (setf *stdin* - (make-fd-stream 0 :name "standard input" :input t :buffering :line)) - (setf *stdout* - (make-fd-stream 1 :name "standard output" :output t :buffering :line)) - (setf *stderr* - (make-fd-stream 2 :name "standard error" :output t :buffering :line)) - (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) - (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) - (if tty - (setf *tty* - (make-fd-stream tty - :name "the terminal" - :input t - :output t - :buffering :line - :auto-close t)) - (setf *tty* (make-two-way-stream *stdin* *stdout*)))) + (with-output-to-string (*error-output*) + (setf *stdin* + (make-fd-stream 0 :name "standard input" :input t :buffering :line)) + (setf *stdout* + (make-fd-stream 1 :name "standard output" :output t :buffering :line)) + (setf *stderr* + (make-fd-stream 2 :name "standard error" :output t :buffering :line)) + (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) + (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) + (if tty + (setf *tty* + (make-fd-stream tty + :name "the terminal" + :input t + :output t + :buffering :line + :auto-close t)) + (setf *tty* (make-two-way-stream *stdin* *stdout*)))) + (princ (get-output-stream-string *error-output*) *stderr*)) (values)) ;;;; miscellany