[nongnu] elpa/slime 9639120b5a 1/2: Buffer FINISH-OUTPUT calls.

[ELPA Syncer]

branch: elpa/slime
commit 9639120b5afcc27610e42bd9a4c2d43bf7f6014f
Author: Stas Boukarev <stassats@gmail.com>
Commit: Stas Boukarev <stassats@gmail.com>

    Buffer FINISH-OUTPUT calls.
    
    It'll be flushed pretty quickly by the auto-flush thread. Otherwise
    continuous output becomes really slow.
---
 contrib/swank-presentations.lisp |  2 +-
 contrib/swank-repl.lisp          |  4 ++--
 swank.lisp                       |  2 +-
 swank/backend.lisp               |  9 +++++++--
 swank/gray.lisp                  | 28 ++++++++++++++++++++--------
 5 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/contrib/swank-presentations.lisp b/contrib/swank-presentations.lisp
index 11326afe32..6913762f25 100644
--- a/contrib/swank-presentations.lisp
+++ b/contrib/swank-presentations.lisp
@@ -110,7 +110,7 @@ The secondary value indicates the absence of an entry."
             (send-to-emacs `(:write-string ,(string #\Newline)
                                            :repl-result)))))
     (fresh-line)
-    (finish-output)
+    (really-finish-output *standard-output*)
     (if (null values)
         (send-to-emacs `(:write-string "; No value" :repl-result))
         (mapc #'send values))))
diff --git a/contrib/swank-repl.lisp b/contrib/swank-repl.lisp
index 8e141a8e07..ee4312649c 100644
--- a/contrib/swank-repl.lisp
+++ b/contrib/swank-repl.lisp
@@ -221,7 +221,7 @@ This is an optimized way for Lisp to deliver output to 
Emacs."
 
 (defun read-user-input-from-emacs ()
   (let ((tag (make-tag)))
-    (force-output)
+    (really-finish-output *standard-output*)
     (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
     (let ((ok nil))
       (unwind-protect
@@ -286,7 +286,7 @@ LISTENER-EVAL directly, so that spacial variables *, etc 
are set."
                              (package-string-for-prompt *package*)))))))
 
 (defun send-repl-results-to-emacs (values)
-  (finish-output)
+  (really-finish-output *standard-output*)
   (if (null values)
       (send-to-emacs `(:write-string "; No value" :repl-result))
       (dolist (v values)
diff --git a/swank.lisp b/swank.lisp
index c975740b95..0e43b9388f 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -1311,7 +1311,7 @@ event was found."
 
 ;; FIXME: belongs to swank-repl.lisp
 (defun force-user-output ()
-  (force-output (connection.user-io *emacs-connection*)))
+  (really-finish-output (connection.user-io *emacs-connection*)))
 
 (add-hook *pre-reply-hook* 'force-user-output)
 
diff --git a/swank/backend.lisp b/swank/backend.lisp
index fe6be316b0..ddbbc700ae 100644
--- a/swank/backend.lisp
+++ b/swank/backend.lisp
@@ -637,12 +637,12 @@ The stream calls READ-STRING when input is needed.")
 
 (defvar *auto-flush-interval* 0.2)
 
-(defun auto-flush-loop (stream interval &optional receive)
+(defun auto-flush-loop (stream interval &optional receive (flush 
#'force-output))
   (loop
    (when (not (and (open-stream-p stream)
                    (output-stream-p stream)))
      (return nil))
-   (force-output stream)
+   (funcall flush stream)
    (when receive
      (receive-if #'identity))
    (sleep interval)))
@@ -652,6 +652,11 @@ The stream calls READ-STRING when input is needed.")
   (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil))
          :name "auto-flush-thread"))
 
+(definterface really-finish-output (stream)
+  "Make an auto-flush thread"
+  (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil))
+         :name "auto-flush-thread"))
+
 
 ;;;; Documentation
 
diff --git a/swank/gray.lisp b/swank/gray.lisp
index ae4de419f0..e7c8ef62df 100644
--- a/swank/gray.lisp
+++ b/swank/gray.lisp
@@ -53,10 +53,12 @@
                     :accessor flush-scheduled)))
 
 (defun maybe-schedule-flush (stream)
-  (when (and (flush-thread stream)
-             (not (flush-scheduled stream)))
-    (setf (flush-scheduled stream) t)
-    (send (flush-thread stream) t)))
+  (when (flush-thread stream)
+    (or (flush-scheduled stream)
+        (progn
+          (setf (flush-scheduled stream) t)
+          (send (flush-thread stream) t)
+          t))))
 
 (defmacro with-slime-output-stream (stream &body body)
   `(with-slots (lock output-fn buffer fill-pointer column) ,stream
@@ -70,7 +72,7 @@
     (when (char= #\newline char)
       (setf column 0))
     (if (= fill-pointer (length buffer))
-        (finish-output stream)
+        (%stream-finish-output stream)
         (maybe-schedule-flush stream)))
   char)
 
@@ -83,7 +85,7 @@
            (count (- end start))
            (free (- len fill-pointer)))
       (when (>= count free)
-        (stream-finish-output stream))
+        (%stream-finish-output stream))
       (cond ((< count len)
              (replace buffer string :start1 fill-pointer
                       :start2 start :end2 end)
@@ -104,7 +106,7 @@
 (defun reset-stream-line-column (stream)
   (with-slime-output-stream stream (setf column 0)))
 
-(defmethod stream-finish-output ((stream slime-output-stream))
+(defun %stream-finish-output (stream)
   (with-slime-output-stream stream
     (unless (zerop fill-pointer)
       (funcall output-fn (subseq buffer 0 fill-pointer))
@@ -129,6 +131,10 @@
 (defmethod stream-force-output ((stream slime-output-stream))
   (stream-finish-output stream))
 
+(defmethod stream-finish-output ((stream slime-output-stream))
+  (unless (maybe-schedule-flush stream)
+    (%stream-finish-output stream)))
+
 (defmethod stream-fresh-line ((stream slime-output-stream))
   (with-slime-output-stream stream
     (cond ((zerop column) nil)
@@ -210,11 +216,17 @@
 (defimplementation make-auto-flush-thread (stream)
   (if (typep stream 'slime-output-stream)
       (setf (flush-thread stream)
-            (spawn (lambda () (auto-flush-loop stream 0.08 t))
+            (spawn (lambda () (auto-flush-loop stream 0.05 t 
#'%stream-finish-output))
                    :name "auto-flush-thread"))
       (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*))
              :name "auto-flush-thread")))
 
+(defimplementation really-finish-output (stream)
+  (let ((stream (swank::real-output-stream stream)))
+    (if (typep stream 'slime-output-stream)
+        (%stream-finish-output stream)
+        (finish-output stream))))
+
 (defimplementation make-output-stream (write-string)
   (make-instance 'slime-output-stream :output-fn write-string))