[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 ()
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
-  (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 @@
     (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 @@
    #+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 ()
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
  ((stream :initarg :stream :reader stream-of)
   (column :initform 0 :accessor column-of :reader stream-line-column)))

(defclass locked-wrapped-stream (locked-stream-mixin

(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)
      (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)
      (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)
                                (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))
      (terpri (stream-of stream))
    (setf (column-of stream) 0)))

(defmethod stream-fresh-line ((stream wrapped-stream))
      (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)
  (write-byte integer (stream-of stream)))

;;{{{ Sequence IO

(defmethod stream-read-sequence ((stream wrapped-stream)
                                 (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)
                                  (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)
    ,@(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
                      (sb-thread:with-recursive-lock ((lock-of ,(caar param)))

  (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
     (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)))
     (make-instance 'locked-wrapped-stream :stream stream))))

More information about the slime-devel mailing list