[slime-cvs] CVS slime

[CVS User mevenson]

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

Modified Files:
	ChangeLog swank-abcl.lisp 
Log Message:
Add multithreading code for abcl-0.16. (Tobias Rittweiler)
 
  * swank-abcl.lisp: A multithread implementation taking advantage
    		     of the new synchronization primitives in abcl-0.16.  


--- /project/slime/cvsroot/slime/ChangeLog	2009/08/18 09:51:12	1.1840
+++ /project/slime/cvsroot/slime/ChangeLog	2009/08/18 10:42:07	1.1841
@@ -1,5 +1,10 @@
 2009-08-18  Mark Evenson  <evenson at panix.com>
 
+	Add multithreading code for abcl-0.16. (Tobias Rittweiler)
+
+	* swank-abcl.lisp: A multithread implementation taking advantage
+	of the new synchronization primitives in abcl-0.16.  
+
 	Restore working with abcl-0.15.
 
 	* swank-abcl.lisp: Remove the warm initialization code for
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2009/08/18 09:51:12	1.66
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2009/08/18 10:42:07	1.67
@@ -119,7 +119,11 @@
 
 
 (defimplementation preferred-communication-style ()
-  nil)
+#+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
+  :spawn
+#-#.(cl:if (cl:find-package :threads) '(:and) '(:or))
+  nil
+)
 
 (defimplementation create-socket (host port)
   (ext:make-server-socket port))
@@ -483,87 +487,97 @@
 
 ;;;; Multithreading
 
-(defimplementation startup-multiprocessing ()
-  #+nil(mp:start-scheduler))
-
-(defimplementation spawn (fn &key name)
-  (ext:make-thread (lambda () (funcall fn)) :name name))
-
-(defvar *thread-props-lock* (ext:make-thread-lock))
-
-(defvar *thread-props* (make-hash-table) ; should be a weak table
-  "A hashtable mapping threads to a plist.")
-
-(defvar *thread-id-counter* 0)
-
-(defimplementation thread-id (thread)
-  (ext:with-thread-lock (*thread-props-lock*)
-    (or (getf (gethash thread *thread-props*) 'id)
-        (setf (getf (gethash thread *thread-props*) 'id)
+#+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
+(progn
+  (defimplementation spawn (fn &key name)
+    (threads:make-thread (lambda () (funcall fn)) :name name))
+
+  (defvar *thread-plists* (make-hash-table) ; should be a weak table
+    "A hashtable mapping threads to a plist.")
+
+  (defvar *thread-id-counter* 0)
+
+  (defimplementation thread-id (thread)
+    (threads:synchronized-on *thread-plists*
+      (or (getf (gethash thread *thread-plists*) 'id)
+          (setf (getf (gethash thread *thread-plists*) 'id)
               (incf *thread-id-counter*)))))
 
-(defimplementation find-thread (id)
-  (find id (all-threads) 
+  (defimplementation find-thread (id)
+    (find id (all-threads) 
         :key (lambda (thread)
-                (getf (gethash thread *thread-props*) 'id))))
+                (getf (gethash thread *thread-plists*) 'id))))
 
-(defimplementation thread-name (thread)
-  (ext:thread-name thread))
+  (defimplementation thread-name (thread)
+    (threads:thread-name thread))
 
-(defimplementation thread-status (thread)
-  (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
+  (defimplementation thread-status (thread)
+    (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
 
-(defimplementation make-lock (&key name)
-  (ext:make-thread-lock))
-
-(defimplementation call-with-lock-held (lock function)
-  (ext:with-thread-lock (lock) (funcall function)))
-
-(defimplementation current-thread ()
-  (ext:current-thread))
-
-(defimplementation all-threads ()
-  (copy-list (ext:mapcar-threads #'identity)))
-
-(defimplementation interrupt-thread (thread fn)
-  (ext:interrupt-thread thread fn))
-
-(defimplementation kill-thread (thread)
-  (ext:destroy-thread thread))
-
-(defstruct mailbox 
-  (mutex (ext:make-mutex))
-  (queue '()))
-
-(defun mailbox (thread)
-  "Return THREAD's mailbox."
-  (ext:with-thread-lock (*thread-props-lock*)
-    (or (getf (gethash thread *thread-props*) 'mailbox)
-        (setf (getf (gethash thread *thread-props*) 'mailbox)
-              (make-mailbox)))))
-
-(defimplementation send (thread object)
-  (let ((mbox (mailbox thread)))
-    (ext:with-mutex ((mailbox-mutex mbox))
-      (setf (mailbox-queue mbox) 
-            (nconc (mailbox-queue mbox) (list message))))))
-
-#+(or)
-(defimplementation receive-if (thread &optional timeout)
-  (let* ((mbox (mailbox (current-thread))))
-    (assert (or (not timeout) (eq timeout t)))
-    (loop
-     (check-slime-interrupts)
-     (ext:with-mutex ((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))))
-       (when (eq timeout t) (return (values nil t)))
-       ;;(java:jcall (java:jmethod "java.lang.Object" "wait") 
-       ;;            (mailbox-mutex mbox) 1000)
-       ))))
+  ;; XXX should be a weak hash table
+  (defparameter *thread-description-map* (make-hash-table)) 
+
+  (defimplementation thread-description (thread) 
+    (synchronized-on *thread-description-map*
+      (or (gethash thread *thread-description-map*)
+          "No description available.")))
+
+  (defimplementation set-thread-description (thread description) 
+    (synchronized-on *thread-description-map*
+      (setf (gethash thread *thread-description-map*) description)))
+
+  (defimplementation make-lock (&key name)
+    (declare (ignore name))
+    (threads:make-thread-lock))
+
+  (defimplementation call-with-lock-held (lock function)
+    (threads:with-thread-lock (lock) (funcall function)))
+
+  (defimplementation current-thread ()
+    (threads:current-thread))
+
+  (defimplementation all-threads ()
+    (copy-list (threads:mapcar-threads #'identity)))
+
+  (defimplementation thread-alive-p (thread)
+    (member thread (all-threads)))
+
+  (defimplementation interrupt-thread (thread fn)
+    (threads:interrupt-thread thread fn)) 
+
+  (defimplementation kill-thread (thread)
+    (threads:destroy-thread thread))
+
+  (defstruct mailbox 
+    (queue '()))
+
+  (defun mailbox (thread)
+    "Return THREAD's mailbox."
+    (threads:synchronized-on *thread-plists*
+      (or (getf (gethash thread *thread-plists*) 'mailbox)
+          (setf (getf (gethash thread *thread-plists*) 'mailbox)
+                (make-mailbox)))))
+
+  (defimplementation send (thread message)
+    (let ((mbox (mailbox thread)))
+      (threads:synchronized-on mbox
+        (setf (mailbox-queue mbox) 
+              (nconc (mailbox-queue mbox) (list message)))
+        (threads:object-notify-all mbox))))
+
+  (defimplementation receive-if (test &optional timeout)
+    (let* ((mbox (mailbox (current-thread))))
+      (assert (or (not timeout) (eq timeout t)))
+      (loop
+       (check-slime-interrupts)
+       (threads:synchronized-on 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)))
+         (when (eq timeout t) (return (values nil t)))
+         (threads:object-wait mbox 0.3)))))))
 
 (defimplementation quit-lisp ()
   (ext:exit))