[slime-cvs] CVS slime
nsiivola
nsiivola at common-lisp.net
Wed Apr 12 08:43:56 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26386
Modified Files:
ChangeLog swank-backend.lisp swank-gray.lisp swank-sbcl.lisp
Log Message:
Stream locking patch from Robert Macomber
--- /project/slime/cvsroot/slime/ChangeLog 2006/04/01 22:55:28 1.879
+++ /project/slime/cvsroot/slime/ChangeLog 2006/04/12 08:43:55 1.880
@@ -1,3 +1,16 @@
+2006-04-12 Robert Macomber <slime at rojoma.com>
+ * swank-backend.lisp (make-recursive-lock): New interface
+ function.
+ (call-with-recursive-lock-held): New interface function.
+
+ * swank-grey.lisp (class slime-output-stream): Added recursive
+ locking to class and generic functions specialized on it.
+ (clss slime-input-stream): Added recursive locking to class and
+ generic functions specialized on it.
+
+ * swank-sbcl.lisp (make-recursive-lock): Implement the new interface.
+ (call-with-recursive-lock): Implement the new interface.
+
2006-04-01 Matthew D. Swank <akopa at charter.net>
* slime.el (slime-fontify-string): Use set-text-properties, not
--- /project/slime/cvsroot/slime/swank-backend.lisp 2006/03/22 16:40:01 1.97
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/04/12 08:43:55 1.98
@@ -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)
--- /project/slime/cvsroot/slime/swank-gray.lisp 2005/09/22 20:15:11 1.9
+++ /project/slime/cvsroot/slime/swank-gray.lisp 2006/04/12 08:43:55 1.10
@@ -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
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/03/22 16:40:01 1.153
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/04/12 08:43:55 1.154
@@ -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-cvs
mailing list