[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sun Aug 3 18:23:10 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv8826
Modified Files:
ChangeLog slime.el swank-allegro.lisp swank-backend.lisp
swank-clisp.lisp swank-cmucl.lisp swank-lispworks.lisp
swank-openmcl.lisp swank-sbcl.lisp swank.lisp
Log Message:
Add some flow-control.
* swank.lisp (make-output-function): Synchronize with Emacs on
every 100th chunk of output.
(wait-for-event,wait-for-event/event-loop,event-match-p): New
functions. Used to selectively wait for some events and to queue
the other events.
(dispatch-event, read-from-socket-io): Tag non-queueable events
with :call.
(read-from-control-thread, read-from-emacs): Process
:call events only; enqueue the others.
(*log-output*): Don't use synonym-streams here. Dereference the
symbol until we get at the real stream.
(log-event): Escape non-ascii characters more carefully.
* swank-backend.lisp (receive-if): New function.
Update backends accordingly. (not yet for ABCL and SCL)
* slime.el (slime-dispatch-event): Handle ping event.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/03 13:30:10 1.1381
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/03 18:23:09 1.1382
@@ -1,3 +1,26 @@
+2008-08-03 Helmut Eller <heller at common-lisp.net>
+
+ Add some flow-control.
+
+ * swank.lisp (make-output-function): Synchronize with Emacs on
+ every 100th chunk of output.
+ (wait-for-event,wait-for-event/event-loop,event-match-p): New
+ functions. Used to selectively wait for some events and to queue
+ the other events.
+ (dispatch-event, read-from-socket-io): Tag non-queueable events
+ with :call.
+ (read-from-control-thread, read-from-emacs): Process
+ :call events only; enqueue the others.
+
+ (*log-output*): Don't use synonym-streams here. Dereference the
+ symbol until we get at the real stream.
+ (log-event): Escape non-ascii characters more carefully.
+
+ * swank-backend.lisp (receive-if): New function.
+ Update backends accordingly. (not yet for ABCL and SCL)
+
+ * slime.el (slime-dispatch-event): Handle ping event.
+
2008-08-03 Tobias C. Rittweiler <tcr at freebits.de>
* slime.el: Make code related to temp buffers more consistent.
--- /project/slime/cvsroot/slime/slime.el 2008/08/03 12:05:09 1.954
+++ /project/slime/cvsroot/slime/slime.el 2008/08/03 18:23:10 1.955
@@ -2337,7 +2337,9 @@
(slime-background-message "%s" message))
((:debug-condition thread message)
(assert thread)
- (message "%s" message))))))
+ (message "%s" message))
+ ((:ping thread tag)
+ (slime-send `(:emacs-pong ,thread ,tag)))))))
(defun slime-send (sexp)
"Send SEXP directly over the wire on the current connection."
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/07/04 22:59:53 1.103
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/03 18:23:10 1.104
@@ -674,11 +674,6 @@
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
- (mp:process-wait-with-timeout
- "yielding before sending" 0.1
- (lambda ()
- (mp:with-process-lock (mutex)
- (< (length (mailbox.queue mbox)) 10))))
(mp:with-process-lock (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
@@ -690,6 +685,17 @@
(mp:with-process-lock (mutex)
(pop (mailbox.queue mbox)))))
+(defimplementation receive-if (test)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (mp:process-wait "receive-if"
+ (lambda () (some test (mailbox.queue mbox))))
+ (mp:with-process-lock ((mailbox.mutex mbox))
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (assert tail)
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (car tail)))))
+
(defimplementation quit-lisp ()
(excl:exit 0 :quiet t))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/07/26 23:05:59 1.135
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/03 18:23:10 1.136
@@ -36,6 +36,7 @@
#:emacs-inspect
#:label-value-line
#:label-value-line*
+
#:with-struct
))
@@ -1020,6 +1021,9 @@
(definterface receive ()
"Return the next message from current thread's mailbox.")
+(definterface receive-if (predicate)
+ "Return the first message satisfiying PREDICATE.")
+
(definterface toggle-trace (spec)
"Toggle tracing of the function(s) given with SPEC.
SPEC can be:
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/04/17 14:56:43 1.69
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/03 18:23:10 1.70
@@ -667,6 +667,10 @@
#+lisp=cl (ext:quit)
#-lisp=cl (lisp:quit))
+(defimplementation thread-id (thread)
+ (declare (ignore thread))
+ 0)
+
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/06/02 18:24:41 1.181
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/03 18:23:10 1.182
@@ -2110,6 +2110,19 @@
(mp:with-lock-held (mutex)
(pop (mailbox.queue mbox)))))
+ (defimplementation receive-if (test)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (mp:process-wait "receive-if"
+ (lambda (mbox test)
+ (some test (mailbox.queue mbox)))
+ mbox test)
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (assert tail)
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (car tail)))))
+
) ;; #+mp
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/07/02 10:02:57 1.100
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/03 18:23:10 1.101
@@ -744,7 +744,20 @@
(mp:make-mailbox)))))
(defimplementation receive ()
- (mp:mailbox-read (mailbox mp:*current-process*)))
+ (receive-if (constantly t)))
+
+(defimplementation receive-if (test)
+ (loop
+ (let* ((self mp:*current-process*)
+ (q (getf (mp:process-plist self) 'queue))
+ (tail (member-if test q)))
+ (cond (tail
+ (setf (getf (mp:process-plist self) 'queue)
+ (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail)))
+ (t
+ (setf (getf (mp:process-plist self) 'queue)
+ (nconc q (list (mp:mailbox-read (mailbox self))))))))))
(defimplementation send (thread object)
(mp:mailbox-send (mailbox thread) object))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/04/17 14:56:43 1.125
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/03 18:23:10 1.126
@@ -959,12 +959,20 @@
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
(defimplementation receive ()
+ (receive-if (constantly t)))
+
+(defimplementation receive-if (test)
(let* ((mbox (mailbox ccl:*current-process*))
(mutex (mailbox.mutex mbox)))
- (ccl:wait-on-semaphore (mailbox.semaphore mbox))
- (ccl:with-lock-grabbed (mutex)
- (assert (mailbox.queue mbox))
- (pop (mailbox.queue mbox)))))
+ (loop
+ (ccl:with-lock-grabbed (mutex)
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox.queue mbox)
+ (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail)))))
+ (ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
(defimplementation quit-lisp ()
(ccl::quit))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/07/29 11:03:25 1.201
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/03 18:23:10 1.202
@@ -1295,6 +1295,18 @@
(t (sb-thread:condition-wait (mailbox.waitqueue mbox)
mutex))))))))
+ (defimplementation receive-if (test)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (sb-thread:with-mutex (mutex)
+ (loop
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (cond (tail
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail)))
+ (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
+ mutex))))))))
;; Auto-flush streams
--- /project/slime/cvsroot/slime/swank.lisp 2008/07/26 23:05:59 1.548
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/03 18:23:10 1.549
@@ -358,7 +358,12 @@
;;;;; Logging
(defvar *log-events* nil)
-(defvar *log-output* *error-output*)
+(defvar *log-output*
+ (labels ((ref (x)
+ (cond ((typep x 'synonym-stream)
+ (ref (symbol-value (synonym-stream-symbol x))))
+ (t x))))
+ (ref *error-output*)))
(defvar *event-history* (make-array 40 :initial-element nil)
"A ring buffer to record events for better error messages.")
(defvar *event-history-index* 0)
@@ -377,7 +382,8 @@
(setf *event-history-index*
(mod (1+ *event-history-index*) (length *event-history*))))
(when *log-events*
- (apply #'format *log-output* format-string args)
+ (write-string (escape-non-ascii (format nil "~?" format-string args))
+ *log-output*)
(force-output *log-output*)))))
(defun event-history-to-list ()
@@ -394,7 +400,10 @@
(cond ((stringp event)
(write-string (escape-non-ascii event) stream))
((null event))
- (t (format stream "Unexpected event: ~A~%" event))))
+ (t
+ (write-string
+ (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
+ stream))))
(defun escape-non-ascii (string)
"Return a string like STRING but with non-ascii chars escaped."
@@ -701,40 +710,38 @@
(defun open-streams (connection)
"Return the 5 streams for IO redirection:
DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
- (multiple-value-bind (output-fn dedicated-output)
- (make-output-function connection)
- (let ((input-fn
- (lambda ()
- (with-connection (connection)
- (with-simple-restart (abort-read
- "Abort reading input from Emacs.")
- (read-user-input-from-emacs))))))
- (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))
- (let ((repl-results
- (make-output-stream-for-target connection :repl-result)))
- (values dedicated-output in out io repl-results))))))))
+ (let ((output-fn (make-output-function connection))
+ (input-fn
+ (lambda ()
+ (with-connection (connection)
+ (with-simple-restart (abort-read
+ "Abort reading input from Emacs.")
+ (read-user-input-from-emacs))))))
+ (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
+ (let* ((dedicated-output (if *use-dedicated-output-stream*
+ (open-dedicated-output-stream
+ (connection.socket-io connection))))
+ (out (or dedicated-output out))
+ (io (make-two-way-stream in out))
+ (repl-results (make-output-stream-for-target connection
+ :repl-result)))
+ (mapc #'make-stream-interactive (list in out io))
+ (values dedicated-output in out io repl-results)))))
+;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
(defun make-output-function (connection)
- "Create function to send user output to Emacs.
-This function may open a dedicated socket to send output. It
-returns two values: the output function, and the dedicated
-stream (or NIL if none was created)."
- (if *use-dedicated-output-stream*
- (let ((stream (open-dedicated-output-stream
- (connection.socket-io connection))))
- (values (lambda (string)
- (write-string string stream)
- (force-output stream))
- stream))
- (values (lambda (string)
- (with-connection (connection)
- (with-simple-restart
- (abort "Abort sending output to Emacs.")
- (send-to-emacs `(:write-string ,string)))))
- nil)))
+ "Create function to send user output to Emacs."
+ (let ((max 100) (i 0) (tag 0))
+ (lambda (string)
+ (with-connection (connection)
+ (with-simple-restart (abort "Abort sending output to Emacs.")
+ (when (= i max)
+ (setf tag (mod (1+ tag) 1000))
+ (send-to-emacs `(:ping ,(thread-id (current-thread)) ,tag))
+ (wait-for-event `(:emacs-pong ,tag))
+ (setf i 0))
+ (incf i)
+ (send-to-emacs `(:write-string ,string)))))))
(defun make-output-function-for-target (connection target)
"Create a function to send user output to a specific TARGET in Emacs."
@@ -922,7 +929,7 @@
((:emacs-rex form package thread-id id)
(let ((thread (thread-for-evaluation thread-id)))
(push thread *active-threads*)
- (send thread `(eval-for-emacs ,form ,package ,id))))
+ (send thread `(:call eval-for-emacs ,form ,package ,id))))
((:return thread &rest args)
(let ((tail (member thread *active-threads*)))
(setq *active-threads* (nconc (ldiff *active-threads* tail)
@@ -940,14 +947,16 @@
((:read-aborted thread &rest args)
(encode-message `(:read-aborted ,(thread-id thread) , at args) socket-io))
((:emacs-return-string thread-id tag string)
- (send (find-thread thread-id) `(take-input ,tag ,string)))
+ (send (find-thread thread-id) `(:call take-input ,tag ,string)))
((:eval thread &rest args)
(encode-message `(:eval ,(thread-id thread) , at args) socket-io))
((:emacs-return thread-id tag value)
- (send (find-thread thread-id) `(take-input ,tag ,value)))
+ (send (find-thread thread-id) `(:call take-input ,tag ,value)))
+ ((:emacs-pong thread-id tag)
+ (send (find-thread thread-id) `(:emacs-pong ,tag)))
(((:write-string :presentation-start :presentation-end
:new-package :new-features :ed :%apply :indentation-update
- :eval-no-wait :background-message :inspect)
+ :eval-no-wait :background-message :inspect :ping)
&rest _)
(declare (ignore _))
(encode-message event socket-io))))
@@ -1061,16 +1070,19 @@
(destructure-case event
((:emacs-rex form package thread id)
(declare (ignore thread))
- `(eval-for-emacs ,form ,package ,id))
+ `(:call eval-for-emacs ,form ,package ,id))
((:emacs-interrupt thread)
(declare (ignore thread))
- '(simple-break))
+ '(:call simple-break))
((:emacs-return-string thread tag string)
(declare (ignore thread))
- `(take-input ,tag ,string))
+ `(:call take-input ,tag ,string))
((:emacs-return thread tag value)
(declare (ignore thread))
- `(take-input ,tag ,value)))))
+ `(:call take-input ,tag ,value))
+ ((:emacs-pong thread tag)
+ (declare (ignore thread))
+ `(:emacs-pong ,tag)))))
(defun send-to-socket-io (event)
(log-event "DISPATCHING: ~S~%" event)
@@ -1089,7 +1101,7 @@
(((:write-string :new-package :new-features :debug-condition
:presentation-start :presentation-end
:indentation-update :ed :%apply :eval-no-wait
- :background-message :inspect)
+ :background-message :inspect :ping)
&rest _)
(declare (ignore _))
(send event)))))
@@ -1130,7 +1142,8 @@
(make-connection :socket-io socket-io
:read #'read-from-socket-io
:send #'send-to-socket-io
- :serve-requests #'simple-serve-requests)))))
+ :serve-requests #'simple-serve-requests))
+ )))
(setf (connection.communication-style c) style)
(initialize-streams-for-connection c)
(setf success t)
@@ -1315,6 +1328,8 @@
(defmacro with-thread-description (description &body body)
`(call-with-thread-description ,description #'(lambda () , at body)))
+(defvar *event-queue* '())
+
(defun read-from-emacs ()
"Read and process a request from Emacs."
(flet ((request-to-string (req)
@@ -1331,10 +1346,47 @@
;; created by swank are currently doing.
(with-thread-description (truncate-string (request-to-string request) 55)
(apply #'funcall request))
- (apply #'funcall request)))))
+ (destructure-case request
+ ((:call . args) (apply #'funcall args))
+ (t (setf *event-queue*
+ (nconc *event-queue* (list request)))))))))
+
+(defun wait-for-event (pattern)
+ (log-event "wait-for-event: %S~%" pattern)
+ (case (connection.communication-style *emacs-connection*)
+ (:spawn (receive-if (lambda (e) (event-match-p e pattern))))
+ (t (wait-for-event/event-loop pattern))))
+
+(defun wait-for-event/event-loop (pattern)
+ (loop
+ (let ((tail (member-if (lambda (e) (event-match-p e pattern))
+ *event-queue*)))
+ (cond (tail
+ (setq *event-queue*
+ (nconc (ldiff *event-queue* tail) (cdr tail)))
+ (return (car tail)))
+ (t
+ (let ((event (read-from-socket-io)))
+ (cond ((event-match-p event pattern) (return event))
+ ((eq (car event) :call)
+ (apply #'funcall (cdr event)))
+ (t
+ (setf *event-queue*
+ (nconc *event-queue* (list event)))))))))))
+
+(defun event-match-p (event pattern)
+ (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
+ (member pattern '(nil t)))
+ (equal event pattern))
+ ((symbolp pattern) t)
+ ((consp pattern)
+ (and (consp event)
+ (and (event-match-p (car event) (car pattern))
+ (event-match-p (cdr event) (cdr pattern)))))
+ (t (error "Invalid pattern: ~S" pattern))))
(defun read-from-control-thread ()
- (receive))
+ (cdr (receive-if (lambda (e) (event-match-p e '(:call . _))))))
(defun decode-message (stream)
"Read an S-expression from STREAM using the SLIME protocol."
More information about the slime-cvs
mailing list