[slime-cvs] CVS slime
heller
heller at common-lisp.net
Wed Aug 6 19:51:29 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv15074
Modified Files:
ChangeLog swank-backend.lisp swank-lispworks.lisp
swank-openmcl.lisp swank-sbcl.lisp swank.lisp
Log Message:
Queue interrupts in various places.
* swank-backend.lisp (*pending-slime-interrupts*): New variable.
(check-slime-interrupts): New function.
* swank-lispworks.lisp (receive-if): Use it.
* swank-sbcl.lisp, swank-openmcl.lisp: Ditto.
* swank.lisp (*slime-interrupts-enabled*): New variable.
(with-slime-interrupts, without-slime-interrupts): New macros.
(invoke-or-queue-interrupt): New function.
(interrupt-worker-thread, eval-for-emacs, swank-debugger-hook)
(debug-nth-thread, wait-for-event, read-from-emacs): Use them.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 09:16:54 1.1397
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:29 1.1398
@@ -9,6 +9,23 @@
(call-with-compilation-hooks): STYLE-WARNINGs are WARNINGs, and
don't need a separate handler.
+2008-08-06 Helmut Eller <heller at common-lisp.net>
+
+ Queue interrupts in various places.
+
+ * swank-backend.lisp (*pending-slime-interrupts*): New variable.
+ (check-slime-interrupts): New function.
+
+ * swank-lispworks.lisp (receive-if): Use it.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp: Ditto.
+
+ * swank.lisp (*slime-interrupts-enabled*): New variable.
+ (with-slime-interrupts, without-slime-interrupts): New macros.
+ (invoke-or-queue-interrupt): New function.
+ (interrupt-worker-thread, eval-for-emacs, swank-debugger-hook)
+ (debug-nth-thread, wait-for-event, read-from-emacs): Use them.
+
2008-08-05 Helmut Eller <heller at common-lisp.net>
* slime.el (slime-with-output-to-temp-buffer): Make sure that we
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:49 1.139
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/06 19:51:29 1.140
@@ -32,6 +32,9 @@
#:unbound-slot-filler
#:declaration-arglist
#:type-specifier-arglist
+ ;; interrupt macro for the backend
+ #:*pending-slime-interrupts*
+ #:check-slime-interrupts
;; inspector related symbols
#:emacs-inspect
#:label-value-line
@@ -1009,6 +1012,16 @@
(definterface receive-if (predicate)
"Return the first message satisfiying PREDICATE.")
+(defvar *pending-slime-interrupts*)
+
+(defun check-slime-interrupts ()
+ "Execute pending interrupts if any.
+This should be called periodically in operations which
+can take a long time to complete."
+ (when (and (boundp '*pending-slime-interrupts*)
+ *pending-slime-interrupts*)
+ (funcall (pop *pending-slime-interrupts*))))
+
(definterface toggle-trace (spec)
"Toggle tracing of the function(s) given with SPEC.
SPEC can be:
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/05 17:38:59 1.105
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/06 19:51:29 1.106
@@ -751,32 +751,31 @@
(let* ((mbox (mailbox mp:*current-process*))
(lock (mailbox.mutex mbox)))
(loop
- (mp:process-wait "receive" #'mailbox.queue mbox)
- (mp:without-interrupts
- (mp:with-lock (lock "receive/try" 0.1)
- (when (mailbox.queue mbox)
- (return (pop (mailbox.queue mbox)))))))))
+ (check-slime-interrupts)
+ (mp:with-lock (lock "receive/try")
+ (when (mailbox.queue mbox)
+ (return (pop (mailbox.queue mbox)))))
+ (mp:process-wait-with-timeout "receive" 0.2 #'mailbox.queue mbox))))
(defimplementation receive-if (test)
(let* ((mbox (mailbox mp:*current-process*))
(lock (mailbox.mutex mbox)))
(loop
- (mp:process-wait "receive-if"
- (lambda () (some test (mailbox.queue mbox))))
- (mp:without-interrupts
- (mp:with-lock (lock "receive-if/try" 0.1)
- (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)))))))))
+ (check-slime-interrupts)
+ (mp:with-lock (lock "receive-if/try")
+ (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)))))
+ (mp:process-wait-with-timeout
+ "receive-if" 0.2 (lambda () (some test (mailbox.queue mbox)))))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
- (mp:without-interrupts
- (mp:with-lock ((mailbox.mutex mbox))
- (setf (mailbox.queue mbox)
- (nconc (mailbox.queue mbox) (list message)))))))
+ (mp:with-lock ((mailbox.mutex mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
;;; Some intergration with the lispworks environment
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/04 21:38:07 1.129
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/06 19:51:29 1.130
@@ -961,23 +961,19 @@
(defimplementation receive ()
(receive-if (constantly t)))
-(defvar *in-receive-if* nil)
-
(defimplementation receive-if (test)
(let* ((mbox (mailbox ccl:*current-process*))
(mutex (mailbox.mutex mbox)))
- (loop
+ (loop
+ (check-slime-interrupts)
(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)))
- (when *in-receive-if*
- (ccl:signal-semaphore (mailbox.semaphore mbox)))
(return (car tail)))))
- (let ((*in-receive-if* t))
- (ccl:wait-on-semaphore (mailbox.semaphore mbox))))))
+ (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 0.2))))
(defimplementation quit-lisp ()
(ccl::quit))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 09:16:55 1.206
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 19:51:29 1.207
@@ -1281,27 +1281,22 @@
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive ()
- (let* ((mbox (mailbox (current-thread)))
- (mutex (mailbox.mutex mbox)))
- (sb-thread:with-mutex (mutex)
- (loop
- (let ((q (mailbox.queue mbox)))
- (cond (q (return (pop (mailbox.queue mbox))))
- (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
- mutex))))))))
+ (receive-if (constantly t)))
(defimplementation receive-if (test)
- (let* ((mbox (mailbox (current-thread)))
- (mutex (mailbox.mutex mbox)))
- (sb-thread:with-mutex (mutex)
- (loop
+ (let ((mbox (mailbox (current-thread))))
+ (loop
+ (check-slime-interrupts)
+ (sb-thread:with-mutex ((mailbox.mutex mbox))
(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))))))))
+ (when tail
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail))))
+ (handler-case (sb-ext:with-timeout 0.2
+ (sb-thread:condition-wait (mailbox.waitqueue mbox)
+ mutex))
+ (sb-ext:timeout ()))))))
;; Auto-flush streams
--- /project/slime/cvsroot/slime/swank.lisp 2008/08/05 17:38:53 1.552
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/06 19:51:29 1.553
@@ -849,14 +849,43 @@
(swank-error.backtrace e)))))))
(progn , at body))))))
-(defslimefun simple-break ()
+(defvar *slime-interrupts-enabled*)
+
+(defmacro with-slime-interrupts (&body body)
+ `(progn
+ (check-slime-interrupts)
+ (let ((*slime-interrupts-enabled* t)
+ (*pending-slime-interrupts* '()))
+ (multiple-value-prog1 (progn , at body)
+ (check-slime-interrupts)))))
+
+(defmacro without-slime-interrupts (&body body)
+ `(progn
+ (check-slime-interrupts)
+ (let ((*slime-interrupts-enabled* nil)
+ (*pending-slime-interrupts* '()))
+ (multiple-value-prog1 (progn , at body)
+ (check-slime-interrupts)))))
+
+(defun invoke-or-queue-interrupt (function)
+ (cond ((not (boundp '*slime-interrupts-enabled*))
+ (without-slime-interrupts
+ (funcall function)))
+ (*slime-interrupts-enabled*
+ (funcall function))
+ ((cddr *pending-slime-interrupts*)
+ (simple-break "Two many queued interrupts"))
+ (t
+ (push function *pending-slime-interrupts*))))
+
+(defslimefun simple-break (&optional (message "Interrupt from Emacs"))
(with-simple-restart (continue "Continue from interrupt.")
(call-with-debugger-hook
#'swank-debugger-hook
(lambda ()
(invoke-debugger
- (make-condition 'simple-error
- :format-control "Interrupt from Emacs")))))
+ (make-condition 'simple-error :format-control "~a"
+ :format-arguments (list message))))))
nil)
;;;;;; Thread based communication
@@ -899,7 +928,9 @@
(defun interrupt-worker-thread (id)
(let ((thread (or (find-worker-thread id)
(repl-thread *emacs-connection*))))
- (interrupt-thread thread #'simple-break)))
+ (interrupt-thread thread
+ (lambda ()
+ (invoke-or-queue-interrupt #'simple-break)))))
(defun thread-for-evaluation (id)
"Find or create a thread to evaluate the next request."
@@ -1321,11 +1352,21 @@
(funcall function)))
(defun call-with-thread-description (description thunk)
- (let* ((thread (current-thread))
- (old-description (thread-description thread)))
- (set-thread-description thread description)
- (unwind-protect (funcall thunk)
- (set-thread-description thread old-description))))
+ ;; For `M-x slime-list-threads': Display what threads
+ ;; created by swank are currently doing.
+ (flet ((request-to-string (req)
+ (remove #\Newline
+ (string-trim '(#\Space #\Tab)
+ (prin1-to-string req))))
+ (truncate-string (str n)
+ (format nil "~A..." (subseq str 0 (min (length str) n)))))
+ (let* ((thread (current-thread))
+ (old-description (thread-description thread)))
+ (set-thread-description thread
+ (truncate-string (request-to-string description)
+ 55))
+ (unwind-protect (funcall thunk)
+ (set-thread-description thread old-description)))))
(defmacro with-thread-description (description &body body)
`(call-with-thread-description ,description #'(lambda () , at body)))
@@ -1334,29 +1375,22 @@
(defun read-from-emacs ()
"Read and process a request from Emacs."
- (flet ((request-to-string (req)
- (remove #\Newline
- (string-trim '(#\Space #\Tab)
- (prin1-to-string req))))
- (truncate-string (str n)
- (if (> (length str) n)
- (format nil "~A..." (subseq str 0 n))
- str)))
- (let ((request (funcall (connection.read *emacs-connection*))))
- (if (eq *communication-style* :spawn)
- ;; For `M-x slime-list-threads': Display what threads
- ;; created by swank are currently doing.
- (with-thread-description (truncate-string (request-to-string request) 55)
- (apply #'funcall request))
- (destructure-case request
+ (let ((request (without-slime-interrupts
+ (funcall (connection.read *emacs-connection*)))))
+ (if (eq *communication-style* :spawn)
+ (with-thread-description request
+ (apply #'funcall request))
+ (destructure-case request
((:call &rest args) (apply #'funcall args))
(t (setf *event-queue*
- (nconc *event-queue* (list request)))))))))
+ (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))))
+ (:spawn
+ (without-slime-interrupts
+ (receive-if (lambda (e) (event-match-p e pattern)))))
(t (wait-for-event/event-loop pattern))))
(defun wait-for-event/event-loop (pattern)
@@ -1760,7 +1794,7 @@
(check-type *buffer-readtable* readtable)
;; APPLY would be cleaner than EVAL.
;;(setq result (apply (car form) (cdr form)))
- (setq result (eval form))
+ (setq result (with-slime-interrupts (eval form)))
(run-hook *pre-reply-hook*)
(setq ok t))
(send-to-emacs `(:return ,(current-thread)
@@ -2006,11 +2040,12 @@
then waits to handle further requests from Emacs. Eventually returns
after Emacs causes a restart to be invoked."
(declare (ignore hook))
- (cond (*emacs-connection*
- (debug-in-emacs condition))
- ((default-connection)
- (with-connection ((default-connection))
- (debug-in-emacs condition)))))
+ (without-slime-interrupts
+ (cond (*emacs-connection*
+ (debug-in-emacs condition))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (debug-in-emacs condition))))))
(defvar *global-debugger* t
"Non-nil means the Swank debugger hook will be installed globally.")
@@ -2991,8 +3026,10 @@
(let ((connection *emacs-connection*))
(interrupt-thread (nth-thread index)
(lambda ()
- (with-connection (connection)
- (simple-break))))))
+ (invoke-or-queue-interrupt
+ (lambda ()
+ (with-connection (connection)
+ (simple-break))))))))
(defslimefun kill-nth-thread (index)
(kill-thread (nth-thread index)))
More information about the slime-cvs
mailing list