Permalink
Browse files

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.
  • Loading branch information...
Helmut Eller
Helmut Eller committed Aug 3, 2008
1 parent 92ae75d commit 18121840629d5fe12902f0ff84a824bda93f374e
Showing with 196 additions and 59 deletions.
  1. +23 −0 ChangeLog
  2. +3 −1 slime.el
  3. +11 −5 swank-allegro.lisp
  4. +4 −0 swank-backend.lisp
  5. +4 −0 swank-clisp.lisp
  6. +13 −0 swank-cmucl.lisp
  7. +14 −1 swank-lispworks.lisp
  8. +12 −4 swank-openmcl.lisp
  9. +12 −0 swank-sbcl.lisp
  10. +100 −48 swank.lisp
View
@@ -1,3 +1,26 @@
+2008-08-03 Helmut Eller <heller@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@freebits.de>
* slime.el: Make code related to temp buffers more consistent.
View
@@ -2337,7 +2337,9 @@ Debugged requests are ignored."
(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."
View
@@ -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))
View
@@ -36,6 +36,7 @@
#:emacs-inspect
#:label-value-line
#:label-value-line*
+
#:with-struct
))
@@ -1020,6 +1021,9 @@ at a time, but that thread may hold it more than once."
(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:
View
@@ -667,6 +667,10 @@ Execute BODY with NAME's function slot set to FUNCTION."
#+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)
View
@@ -2110,6 +2110,19 @@ The `symbol-value' of each element is a type tag.")
(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
View
@@ -744,7 +744,20 @@ function names like \(SETF GET)."
(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))
View
@@ -959,12 +959,20 @@ out IDs for.")
(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))
View
@@ -1295,6 +1295,18 @@ stack."
(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
Oops, something went wrong.

0 comments on commit 1812184

Please sign in to comment.