[slime-devel] sbcl stream flushing race
Robert J. Macomber
slime at rojoma.com
Thu Mar 30 02:42:52 UTC 2006
On Wed, Mar 29, 2006 at 12:14:23PM +0200, Andras Simon wrote:
> I don't remember seeing this with abcl. abcl doesn't have Gray streams, but
> SlimeInputStream/SlimeOutputStream tailor-made to make slime happy. I'd love
> to not having to change them :-) (I've completely forgotten what they do and
> how they do it!) but I don't want to stand in the way of progress.
Well, if abcl doesn't have the problem, nothing else need change
there. The patch doesn't, as far as I know, break any other backends
(my "updates" to them are simply having them return their argument).
Since there haven't been any horrified reactions to my description of
the approach I took, here's the "cvs diff -u", and an additional file
that actually implements the locked streams.
--
Robert Macomber
slime at rojoma.com / Thas on #lisp
-------------- next part --------------
Index: swank-abcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-abcl.lisp,v
retrieving revision 1.34
diff -u -r1.34 swank-abcl.lisp
--- swank-abcl.lisp 2 Feb 2006 02:45:11 -0000 1.34
+++ swank-abcl.lisp 30 Mar 2006 02:19:18 -0000
@@ -491,7 +491,8 @@
(unless *auto-flush-thread*
(setq *auto-flush-thread*
(ext:make-thread #'flush-streams
- :name "auto-flush-thread"))))
+ :name "auto-flush-thread")))
+ stream)
(defun flush-streams ()
(loop
Index: swank-allegro.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-allegro.lisp,v
retrieving revision 1.82
diff -u -r1.82 swank-allegro.lisp
--- swank-allegro.lisp 10 Feb 2006 16:54:01 -0000 1.82
+++ swank-allegro.lisp 30 Mar 2006 02:19:19 -0000
@@ -130,7 +130,8 @@
(describe (find-class symbol)))))
(defimplementation make-stream-interactive (stream)
- (setf (interactive-stream-p stream) t))
+ (setf (interactive-stream-p stream) t)
+ stream)
;;;; Debugger
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.96
diff -u -r1.96 swank-backend.lisp
--- swank-backend.lisp 25 Feb 2006 12:10:33 -0000 1.96
+++ swank-backend.lisp 30 Mar 2006 02:19:19 -0000
@@ -374,9 +374,9 @@
This is called for each stream used for interaction with the user
\(e.g. *standard-output*). An implementation could setup some
implementation-specific functions to control output flushing at the
-like."
- (declare (ignore stream))
- nil)
+like. Returns a stream that may or may not be the same object as the
+one passed in."
+ stream)
;;;; Documentation
Index: swank-lispworks.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-lispworks.lisp,v
retrieving revision 1.82
diff -u -r1.82 swank-lispworks.lisp
--- swank-lispworks.lisp 10 Feb 2006 16:54:01 -0000 1.82
+++ swank-lispworks.lisp 30 Mar 2006 02:19:20 -0000
@@ -773,7 +773,8 @@
nil)
(let ((lw:*handle-warn-on-redefinition* :warn))
(defmethod stream:stream-soft-force-output ((o (eql stream)))
- (force-output o)))))
+ (force-output o))))
+ stream)
(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
(apply (swank-sym :y-or-n-p-in-emacs) msg args))
Index: swank-loader.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-loader.lisp,v
retrieving revision 1.57
diff -u -r1.57 swank-loader.lisp
--- swank-loader.lisp 25 Feb 2006 14:57:21 -0000 1.57
+++ swank-loader.lisp 30 Mar 2006 02:19:20 -0000
@@ -37,7 +37,7 @@
'("nregex")
#+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
#+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
- #+sbcl '("swank-sbcl" "swank-source-path-parser"
+ #+sbcl '("locked-stream" "swank-sbcl" "swank-source-path-parser"
"swank-source-file-cache" "swank-gray")
#+openmcl '("metering" "swank-openmcl" "swank-gray")
#+lispworks '("swank-lispworks" "swank-gray")
Index: swank-openmcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-openmcl.lisp,v
retrieving revision 1.106
diff -u -r1.106 swank-openmcl.lisp
--- swank-openmcl.lisp 7 Mar 2006 09:51:52 -0000 1.106
+++ swank-openmcl.lisp 30 Mar 2006 02:19:20 -0000
@@ -177,10 +177,11 @@
(setq ccl::*interactive-abort-process* ccl::*current-process*))
(defimplementation make-stream-interactive (stream)
- nil)
+ stream)
(defmethod make-stream-interactive ((stream ccl:fundamental-output-stream))
- (push stream ccl::*auto-flush-streams*))
+ (push stream ccl::*auto-flush-streams*)
+ stream)
;;; Unix signals
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.152
diff -u -r1.152 swank-sbcl.lisp
--- swank-sbcl.lisp 20 Jan 2006 21:31:20 -0000 1.152
+++ swank-sbcl.lisp 30 Mar 2006 02:19:21 -0000
@@ -1195,11 +1195,13 @@
(defvar *auto-flush-thread* nil)
(defimplementation make-stream-interactive (stream)
- (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
- (unless *auto-flush-thread*
- (setq *auto-flush-thread*
- (sb-thread:make-thread #'flush-streams
- :name "auto-flush-thread"))))
+ (let ((stream (swank-locked-stream:make-locked-stream stream)))
+ (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (sb-thread:make-thread #'flush-streams
+ :name "auto-flush-thread")))
+ stream))
(defun flush-streams ()
(loop
Index: swank-scl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-scl.lisp,v
retrieving revision 1.5
diff -u -r1.5 swank-scl.lisp
--- swank-scl.lisp 25 Feb 2006 17:46:13 -0000 1.5
+++ swank-scl.lisp 30 Mar 2006 02:19:22 -0000
@@ -344,7 +344,8 @@
(defimplementation make-stream-interactive (stream)
(when (or (typep stream 'slime-input-stream)
(typep stream 'slime-output-stream))
- (setf (slot-value stream 'interactive) t)))
+ (setf (slot-value stream 'interactive) t))
+ stream)
;;;; Compilation Commands
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.363
diff -u -r1.363 swank.lisp
--- swank.lisp 25 Feb 2006 12:10:33 -0000 1.363
+++ swank.lisp 30 Mar 2006 02:19:25 -0000
@@ -490,8 +490,9 @@
(multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
(let ((out (or dedicated-output out)))
(let ((io (make-two-way-stream in out)))
- (mapc #'make-stream-interactive (list in out io))
- (values dedicated-output in out io)))))))
+ (apply #'values
+ dedicated-output
+ (mapcar #'make-stream-interactive (list in out io)))))))))
(defun make-output-function (connection)
"Create function to send user output to Emacs.
-------------- next part --------------
(defpackage #:swank-locked-stream
(:use #:cl
#+sbcl #:sb-mop
#+sbcl #:sb-gray)
(:export #:make-locked-stream))
(in-package #:swank-locked-stream)
;;; FIXME: there's an explicit sb-thread:with-recursive-lock down
;;; below.
(defclass locked-stream-mixin ()
((lock :initform (swank-backend:make-lock :name "stream lock")
:reader lock-of)))
(defclass wrapped-stream (fundamental-character-input-stream
fundamental-character-output-stream
fundamental-binary-input-stream
fundamental-binary-output-stream)
((stream :initarg :stream :reader stream-of)
(column :initform 0 :accessor column-of :reader stream-line-column)))
(defclass locked-wrapped-stream (locked-stream-mixin
wrapped-stream)
())
(defmacro maybe-defmethod (name &rest args)
(when (and (fboundp name)
(typep (symbol-function name) 'generic-function))
`(defmethod ,name , at args)))
;;{{{ Wrapped stream methods
;;{{{ Character input
(defmethod stream-read-char ((stream wrapped-stream))
(read-char (stream-of stream) nil :eof))
(defmethod stream-unread-char ((stream wrapped-stream) character)
(unread-char character (stream-of stream)))
(defmethod stream-read-char-no-hang ((stream wrapped-stream))
(read-char-no-hang (stream-of stream) nil :eof))
(defmethod stream-peek-char ((stream wrapped-stream))
(peek-char nil (stream-of stream) nil :eof))
(defmethod stream-listen ((stream wrapped-stream))
(listen (stream-of stream)))
(defmethod stream-read-line ((stream wrapped-stream))
(read-line (stream-of stream) nil ""))
(defmethod stream-clear-input ((stream wrapped-stream))
(clear-input (stream-of stream)))
;;}}}
;;{{{ Character output
(defmethod stream-write-char ((stream wrapped-stream) character)
(prog1
(write-char character (stream-of stream))
(if (eql character #\Newline)
(setf (column-of stream) 0)
(incf (column-of stream)))))
(defmethod stream-start-line-p ((stream wrapped-stream))
(eql (column-of stream) 0))
(defun write-string/sequence (f stream seq start/end)
(prog1
(apply f seq (stream-of stream) start/end)
(destructuring-bind (&key start end) start/end
(let ((seqlen (or end (length seq)))
(newline-pos (apply #'position #\Newline seq
:from-end t start/end)))
(if newline-pos
(setf (column-of stream) (- seqlen newline-pos))
(incf (column-of stream) (- seqlen (or start 0))))))))
(defmethod stream-write-string ((stream wrapped-stream)
string
&optional
(start nil startp)
(end nil endp))
(let ((start/end (nconc (if startp (list :start start))
(if endp (list :end end)))))
(write-string/sequence #'write-string stream string start/end)))
(defmethod stream-terpri ((stream wrapped-stream))
(prog1
(terpri (stream-of stream))
(setf (column-of stream) 0)))
(defmethod stream-fresh-line ((stream wrapped-stream))
(prog1
(fresh-line (stream-of stream))
(setf (column-of stream) 0)))
(defmethod stream-finish-output ((stream wrapped-stream))
(finish-output (stream-of stream)))
(defmethod stream-force-output ((stream wrapped-stream))
(force-output (stream-of stream)))
(defmethod stream-advance-to-column ((stream wrapped-stream) column)
(let ((spaces (- column
(column-of stream)))
(stream (stream-of stream)))
(loop for i below spaces
do (write-char #\Space stream)
(incf (column-of stream)))))
(defmethod stream-clear-output ((stream wrapped-stream))
(clear-output (stream-of stream)))
;;}}}
;;{{{ Binary IO
(defmethod stream-read-byte ((stream wrapped-stream))
(read-byte (stream-of stream) nil :eof))
(defmethod stream-write-byte ((stream wrapped-stream stream)
integer)
(write-byte integer (stream-of stream)))
;;}}}
;;{{{ Sequence IO
(defmethod stream-read-sequence ((stream wrapped-stream)
seq
&optional
(start nil startp)
(end nil endp))
(let ((start/end (nconc (if startp (list :start start))
(if endp (list :end end)))))
(apply #'read-sequence seq (stream-of stream) start/end)))
(defmethod stream-write-sequence ((stream wrapped-stream)
seq
&optional
(start nil startp)
(end nil endp))
(let ((start/end (nconc (if startp (list :start start))
(if endp (list :end end)))))
(write-string/sequence #'write-sequence stream seq start/end)))
;;}}}
;;{{{ Misc functions
(defmethod close ((stream wrapped-stream) &key abort)
(close (stream-of stream) :abort abort))
(defmethod open-stream-p ((stream wrapped-stream))
(open-stream-p (stream-of stream)))
(maybe-defmethod streamp ((stream wrapped-stream))
(streamp (stream-of stream)))
(maybe-defmethod input-stream-p ((stream wrapped-stream))
(input-stream-p (stream-of stream)))
(maybe-defmethod output-stream-p ((stream wrapped-stream))
(output-stream-p (stream-of stream)))
(maybe-defmethod stream-element-type ((stream wrapped-stream))
(stream-element-type (stream-of stream)))
(maybe-defmethod stream-yes-or-no-p ((stream wrapped-stream)
&optional format-string
&rest args)
(apply #'yes-or-no-p (stream-of stream) format-string args))
(maybe-defmethod stream-y-or-n-p ((stream wrapped-stream)
&optional format-string
&rest args)
(apply #'y-or-n-p (stream-of stream) format-string args))
;;}}}
;;}}}
(defmacro define-locked-around-methods (&body specs)
`(progn
,@(mapcar (lambda (spec)
(destructuring-bind (name arglist) spec
(let* ((arglist* (copy-list arglist))
(param (member 'stream arglist*)))
(setf (car param) `(,(car param) locked-stream-mixin))
`(maybe-defmethod ,name :around ,arglist*
(declare (ignorable ,@(set-difference arglist
lambda-list-keywords)))
(sb-thread:with-recursive-lock ((lock-of ,(caar param)))
(call-next-method))))))
specs)))
(define-locked-around-methods
(stream-read-char (stream))
(stream-unread-char (stream character))
(stream-read-char-no-hang (stream))
(stream-peek-char (stream))
(stream-listen (stream))
(stream-read-line (stream))
(stream-clear-input (stream))
(stream-write-char (stream character))
(stream-line-column (stream))
(stream-start-line-p (stream))
(stream-write-string (stream string &optional start end))
(stream-terpri (stream))
(stream-fresh-line (stream))
(stream-finish-output (stream))
(stream-force-output (stream))
(stream-advance-to-column (stream column))
(stream-clear-output (stream))
(stream-read-byte (stream))
(stream-write-byte (stream integer))
(stream-read-sequence (stream seq &optional start end))
(stream-write-sequence (stream seq &optional start end))
(close (stream &key abort))
(open-stream-p (stream))
(streamp (stream))
(input-stream-p (stream))
(output-stream-p (stream))
(stream-element-type (stream))
(stream-yes-or-no-p (stream &optional format-string &rest args))
(stream-y-or-n-p (stream &optional format-string &rest args))
(stream-input-fn (stream))
(stream-output-fn (stream))
(stream-line-length (stream))
(stream-output-width (stream)))
(defvar *locked-stream-classes* (make-hash-table))
(defun make-locked-stream (stream)
"Returns a version of STREAM that prevents concurrent access. If
STREAM is already a locked stream, it's returned. If it's a Gray
stream, its class is changed to a subtype of its current class which
has had a locked-stream mixin prepended to its precedence list.
Otherwise, it's wrapped in a Gray stream that simply calls the
standard CL stream functions with a lock held."
(etypecase stream
(locked-stream-mixin
stream)
(fundamental-stream
(let ((locked-class (gethash (class-of stream) *locked-stream-classes*)))
(unless locked-class
(setf locked-class (ensure-class
(gensym (princ-to-string (type-of stream)))
:direct-superclasses (list 'locked-stream-mixin
(class-of stream))))
(setf (gethash (class-of stream) *locked-stream-classes*) locked-class))
(change-class stream locked-class)))
(stream
(make-instance 'locked-wrapped-stream :stream stream))))
More information about the slime-devel
mailing list