[slime-devel] sbcl stream flushing race
Robert J. Macomber
slime at rojoma.com
Thu Mar 30 16:41:17 UTC 2006
On Thu, Mar 30, 2006 at 07:35:35AM +0200, Helmut Eller wrote:
> Wouldn't it be easier turn the dedicated stream off and add the
> neccessary locking to the stream in swank-gray.lisp?
Errm. That hadn't actually occurred to me.
Patch attached. Not as thoroughly tested as the other, which I'd been
using for a couple of days, but I haven't seen it behave badly yet.
--
Robert Macomber
slime at rojoma.com / Thas on #lisp
-------------- next part --------------
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.97
diff -u -r1.97 swank-backend.lisp
--- swank-backend.lisp 22 Mar 2006 16:40:01 -0000 1.97
+++ swank-backend.lisp 30 Mar 2006 16:29:10 -0000
@@ -836,6 +836,24 @@
(type function function))
(funcall function))
+(definterface make-recursive-lock (&key name)
+ "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
+at a time, but that thread may hold it more than once."
+ (cons nil (make-lock :name name)))
+
+(definterface call-with-recursive-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (if (eql (car lock) (current-thread))
+ (funcall function)
+ (call-with-lock-held (cdr lock)
+ (lambda ()
+ (unwind-protect
+ (progn
+ (setf (car lock) (current-thread))
+ (funcall function))
+ (setf (car lock) nil))))))
+
(definterface current-thread ()
"Return the currently executing thread."
0)
Index: swank-gray.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-gray.lisp,v
retrieving revision 1.9
diff -u -r1.9 swank-gray.lisp
--- swank-gray.lisp 22 Sep 2005 20:15:11 -0000 1.9
+++ swank-gray.lisp 30 Mar 2006 16:29:11 -0000
@@ -15,86 +15,115 @@
(buffer :initform (make-string 8000))
(fill-pointer :initform 0)
(column :initform 0)
- (last-flush-time :initform (get-internal-real-time))))
+ (last-flush-time :initform (get-internal-real-time))
+ (lock :initform (make-recursive-lock :name "buffer write lock"))))
(defmethod stream-write-char ((stream slime-output-stream) char)
- (with-slots (buffer fill-pointer column) stream
- (setf (schar buffer fill-pointer) char)
- (incf fill-pointer)
- (incf column)
- (when (char= #\newline char)
- (setf column 0)
- (force-output stream))
- (when (= fill-pointer (length buffer))
- (finish-output stream)))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer column) stream
+ (setf (schar buffer fill-pointer) char)
+ (incf fill-pointer)
+ (incf column)
+ (when (char= #\newline char)
+ (setf column 0)
+ (force-output stream))
+ (when (= fill-pointer (length buffer))
+ (finish-output stream)))))
char)
(defmethod stream-line-column ((stream slime-output-stream))
- (slot-value stream 'column))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (slot-value stream 'column))))
(defmethod stream-line-length ((stream slime-output-stream))
75)
(defmethod stream-finish-output ((stream slime-output-stream))
- (with-slots (buffer fill-pointer output-fn last-flush-time) stream
- (let ((end fill-pointer))
- (unless (zerop end)
- (funcall output-fn (subseq buffer 0 end))
- (setf fill-pointer 0)))
- (setf last-flush-time (get-internal-real-time)))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer output-fn last-flush-time) stream
+ (let ((end fill-pointer))
+ (unless (zerop end)
+ (funcall output-fn (subseq buffer 0 end))
+ (setf fill-pointer 0)))
+ (setf last-flush-time (get-internal-real-time)))))
nil)
(defmethod stream-force-output ((stream slime-output-stream))
- (with-slots (last-flush-time fill-pointer) stream
- (let ((now (get-internal-real-time)))
- (when (> (/ (- now last-flush-time)
- (coerce internal-time-units-per-second 'double-float))
- 0.2)
- (finish-output stream))))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (last-flush-time fill-pointer) stream
+ (let ((now (get-internal-real-time)))
+ (when (> (/ (- now last-flush-time)
+ (coerce internal-time-units-per-second 'double-float))
+ 0.2)
+ (finish-output stream))))))
nil)
(defmethod stream-fresh-line ((stream slime-output-stream))
- (with-slots (column) stream
- (cond ((zerop column) nil)
- (t (terpri stream) t))))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (column) stream
+ (cond ((zerop column) nil)
+ (t (terpri stream) t))))))
(defclass slime-input-stream (fundamental-character-input-stream)
((output-stream :initarg :output-stream)
(input-fn :initarg :input-fn)
- (buffer :initform "") (index :initform 0)))
+ (buffer :initform "") (index :initform 0)
+ (lock :initform (make-lock :name "buffer read lock"))))
(defmethod stream-read-char ((s slime-input-stream))
- (with-slots (buffer index output-stream input-fn) s
- (when (= index (length buffer))
- (when output-stream
- (finish-output output-stream))
- (let ((string (funcall input-fn)))
- (cond ((zerop (length string))
- (return-from stream-read-char :eof))
- (t
- (setf buffer string)
- (setf index 0)))))
- (assert (plusp (length buffer)))
- (prog1 (aref buffer index) (incf index))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index output-stream input-fn) s
+ (when (= index (length buffer))
+ (when output-stream
+ (finish-output output-stream))
+ (let ((string (funcall input-fn)))
+ (cond ((zerop (length string))
+ (return-from stream-read-char :eof))
+ (t
+ (setf buffer string)
+ (setf index 0)))))
+ (assert (plusp (length buffer)))
+ (prog1 (aref buffer index) (incf index))))))
(defmethod stream-listen ((s slime-input-stream))
- (with-slots (buffer index) s
- (< index (length buffer))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (< index (length buffer))))))
(defmethod stream-unread-char ((s slime-input-stream) char)
- (with-slots (buffer index) s
- (decf index)
- (cond ((eql (aref buffer index) char)
- (setf (aref buffer index) char))
- (t
- (warn "stream-unread-char: ignoring ~S (expected ~S)"
- char (aref buffer index)))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (decf index)
+ (cond ((eql (aref buffer index) char)
+ (setf (aref buffer index) char))
+ (t
+ (warn "stream-unread-char: ignoring ~S (expected ~S)"
+ char (aref buffer index)))))))
nil)
(defmethod stream-clear-input ((s slime-input-stream))
- (with-slots (buffer index) s
- (setf buffer ""
- index 0))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (setf buffer ""
+ index 0))))
nil)
(defmethod stream-line-column ((s slime-input-stream))
@@ -113,9 +142,12 @@
;; We could make do with either of the two methods below.
(defmethod stream-read-char-no-hang ((s slime-input-stream))
- (with-slots (buffer index) s
- (when (< index (length buffer))
- (prog1 (aref buffer index) (incf index)))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (when (< index (length buffer))
+ (prog1 (aref buffer index) (incf index)))))))
;; This CLISP extension is what listen_char actually calls. The
;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.153
diff -u -r1.153 swank-sbcl.lisp
--- swank-sbcl.lisp 22 Mar 2006 16:40:01 -0000 1.153
+++ swank-sbcl.lisp 30 Mar 2006 16:29:11 -0000
@@ -1136,6 +1136,13 @@
(declare (type function function))
(sb-thread:with-mutex (lock) (funcall function)))
+ (defimplementation make-recursive-lock (&key name)
+ (sb-thread:make-mutex :name name))
+
+ (defimplementation call-with-recursive-lock-held (lock function)
+ (declare (type function function))
+ (sb-thread:with-recursive-lock (lock) (funcall function)))
+
(defimplementation current-thread ()
sb-thread:*current-thread*)
More information about the slime-devel
mailing list