[slime-cvs] CVS slime
heller
heller at common-lisp.net
Thu Aug 7 07:53:48 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30250
Modified Files:
ChangeLog slime.el swank-allegro.lisp swank-cmucl.lisp
swank-lispworks.lisp swank-scl.lisp
Log Message:
* swank-allegro.lisp:(receive-if): Periodically check for interrupts.
* swank-cmucl.lisp, swank-scl.lisp: ditto.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:39 1.1400
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 07:53:47 1.1401
@@ -1,3 +1,8 @@
+2008-08-07 Helmut Eller <heller at common-lisp.net>
+
+ * swank-allegro.lisp, swank-cmucl.lisp,
+ swank-scl.lisp (receive-if): Periodically check for interrupts.
+
2008-08-06 Nikodemus Siivola <nikodemus at random-state.net>
* swank-sbcl.lisp (handle-notification-condition): resignal
--- /project/slime/cvsroot/slime/slime.el 2008/08/06 19:51:35 1.961
+++ /project/slime/cvsroot/slime/slime.el 2008/08/07 07:53:47 1.962
@@ -6333,7 +6333,8 @@
(lambda (expansion)
(slime-with-output-to-temp-buffer
;; reusep for preserving `undo' functionality.
- ("*SLIME Macroexpansion*" :mode lisp-mode :reusep t :connection t) package
+ ("*SLIME Macroexpansion*" :mode lisp-mode
+ :reusep t :connection t :read-only nil) package
(slime-mode 1)
(slime-macroexpansion-minor-mode 1)
(erase-buffer)
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/04 21:38:07 1.106
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/07 07:53:47 1.107
@@ -661,8 +661,9 @@
(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
(defstruct (mailbox (:conc-name mailbox.))
- (mutex (mp:make-process-lock :name "process mailbox"))
- (queue '() :type list))
+ (lock (mp:make-process-lock :name "process mailbox"))
+ (queue '() :type list)
+ (gate (mp:make-gate)))
(defun mailbox (thread)
"Return THREAD's mailbox."
@@ -672,29 +673,28 @@
(make-mailbox)))))
(defimplementation send (thread message)
- (let* ((mbox (mailbox thread))
- (mutex (mailbox.mutex mbox)))
- (mp:with-process-lock (mutex)
- (setf (mailbox.queue mbox)
- (nconc (mailbox.queue mbox) (list message))))))
+ (let* ((mbox (mailbox thread)))
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:open-gate (mailbox.gate mbox)))))
(defimplementation receive ()
- (let* ((mbox (mailbox mp:*current-process*))
- (mutex (mailbox.mutex mbox)))
- (mp:process-wait "receive" #'mailbox.queue mbox)
- (mp:with-process-lock (mutex)
- (pop (mailbox.queue mbox)))))
+ (receive-if (constantly t)))
(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)))))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (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:close-gate (mailbox.gate mbox))))
+ (mp:process-wait-with-timeout "receive-if" 0.5
+ #'mp:gate-open-p (mailbox.gate mbox)))))
(defimplementation quit-lisp ()
(excl:exit 0 :quiet t))
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/04 20:25:28 1.183
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/07 07:53:47 1.184
@@ -2097,34 +2097,28 @@
(make-mailbox)))))
(defimplementation send (thread message)
+ (check-slime-interrupts)
(let* ((mbox (mailbox thread)))
- (sys:without-interrupts
- (mp:with-lock-held ((mailbox.mutex mbox))
- (setf (mailbox.queue mbox)
- (nconc (mailbox.queue mbox) (list message)))))))
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
(defimplementation receive ()
- (let* ((mbox (mailbox mp:*current-process*)))
- (loop
- (mp:process-wait "receive" #'mailbox.queue mbox)
- (sys:without-interrupts
- (mp:with-lock-held ((mailbox.mutex mbox))
- (when (mailbox.queue mbox)
- (return (pop (mailbox.queue mbox)))))))))
+ (receive-if (constantly t)))
(defimplementation receive-if (test)
(let ((mbox (mailbox mp:*current-process*)))
(loop
- (mp:process-wait "receive-if"
- (lambda () (some test (mailbox.queue mbox))))
- (sys:without-interrupts
- (mp:with-lock-held ((mailbox.mutex mbox))
- (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-held ((mailbox.mutex mbox))
+ (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.5 (lambda () (some test (mailbox.queue mbox)))))))
) ;; #+mp
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/06 19:51:29 1.106
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/07 07:53:47 1.107
@@ -34,7 +34,7 @@
(when (fboundp 'dspec::define-dspec-alias)
(dspec::define-dspec-alias defimplementation (name args &rest body)
- `(defmethod ,name ,args , at body)))
+ `(defun ,name ,args , at body)))
;;; TCP server
@@ -748,14 +748,7 @@
(make-mailbox)))))
(defimplementation receive ()
- (let* ((mbox (mailbox mp:*current-process*))
- (lock (mailbox.mutex mbox)))
- (loop
- (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))))
+ (receive-if (constantly t)))
(defimplementation receive-if (test)
(let* ((mbox (mailbox mp:*current-process*))
--- /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/04 20:25:33 1.20
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/07 07:53:47 1.21
@@ -1969,44 +1969,27 @@
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(lock (mailbox-lock mbox)))
- (sys:without-interrupts
- (thread:with-lock-held (lock "Mailbox Send")
- (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
- (list message)))))
- (mp:process-wakeup thread)
- message))
-
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message))))
+ (mp:process-wakeup thread)))
+
(defimplementation receive ()
- (let* ((mbox (mailbox thread:*thread*))
- (lock (mailbox-lock mbox)))
- (loop
- (mp:process-wait-with-timeout "Mailbox read wait" 1
- #'(lambda () (mailbox-queue mbox)))
- (multiple-value-bind (message winp)
- (sys:without-interrupts
- (mp:with-lock-held (lock "Mailbox read")
- (let ((queue (mailbox-queue mbox)))
- (cond (queue
- (setf (mailbox-queue mbox) (cdr queue))
- (values (car queue) t))
- (t
- (values nil nil))))))
- (when winp
- (return message))))))
+ (receive-if (constantly t)))
(defimplementation receive-if (test)
(let ((mbox (mailbox thread:*thread*)))
(loop
- (mp:process-wait "receive-if"
- (lambda () (some test (mailbox-queue mbox))))
- (sys:without-interrupts
- (mp:with-lock-held ((mailbox-lock mbox))
- (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-held ((mailbox-lock mbox))
+ (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
+ "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
More information about the slime-cvs
mailing list