[slime-cvs] CVS slime

[CVS User trittweiler]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv7771

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
	* swank-sbcl.lisp (condition-timed-wait): New helper. Use
	WITH-DEADLINE rather than WITH-TIMEOUT because the latter conses a
	new timer, and this function is called _a lot_.
	(receive-if): Use it.


--- /project/slime/cvsroot/slime/ChangeLog	2010/04/20 09:31:10	1.2071
+++ /project/slime/cvsroot/slime/ChangeLog	2010/04/20 09:48:19	1.2072
@@ -1,3 +1,10 @@
+2010-04-20  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-sbcl.lisp (condition-timed-wait): New helper. Use
+	WITH-DEADLINE rather than WITH-TIMEOUT because the latter conses a
+	new timer, and this function is called _a lot_.
+	(receive-if): Use it.
+
 2010-04-20  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-update-threads-buffer): Save point position
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/03/02 14:36:48	1.269
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/04/20 09:48:19	1.270
@@ -1450,10 +1450,25 @@
         (setf (mailbox.queue mbox)
               (nconc (mailbox.queue mbox) (list message)))
         (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
-
+  #-sb-lutex
+  (defun condition-timed-wait (waitqueue mutex timeout)
+    (handler-case 
+        (let ((*break-on-signals* nil))
+          (sb-sys:with-deadline (:seconds timeout :override t)
+            (sb-thread:condition-wait waitqueue mutex) t))
+      (sb-ext:timeout ()
+        nil)))
+
+  ;; FIXME: with-timeout doesn't work properly on Darwin
+  #+sb-lutex
+  (defun condition-timed-wait (waitqueue mutex timeout)
+    (declare (ignore timeout))
+    (sb-thread:condition-wait waitqueue mutex))
+  
   (defimplementation receive-if (test &optional timeout)
     (let* ((mbox (mailbox (current-thread)))
-           (mutex (mailbox.mutex mbox)))
+           (mutex (mailbox.mutex mbox))
+           (waitq (mailbox.waitqueue mbox)))
       (assert (or (not timeout) (eq timeout t)))
       (loop
        (check-slime-interrupts)
@@ -1464,17 +1479,7 @@
              (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
              (return (car tail))))
          (when (eq timeout t) (return (values nil t)))
-         ;; FIXME: with-timeout doesn't work properly on Darwin
-         #+linux
-         (handler-case 
-             (let ((*break-on-signals* nil))
-               (sb-ext:with-timeout 0.2
-                 (sb-thread:condition-wait (mailbox.waitqueue mbox)
-                                           mutex)))
-           (sb-ext:timeout ()))
-         #-linux  
-         (sb-thread:condition-wait (mailbox.waitqueue mbox)
-                                   mutex)))))
+         (condition-timed-wait waitq mutex 0.2)))))
   )
 
 (defimplementation quit-lisp ()