[mcclim-cvs] CVS update: mcclim/Lisp-Dep/mp-sbcl.lisp

[Christophe Rhodes]

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep
In directory common-lisp.net:/tmp/cvs-serv507

Modified Files:
	mp-sbcl.lisp 
Log Message:
Support new thread-object sbcl API (as well as backwards-compatible 
#+#. cruft to be deleted when no-one cares about 0.9.2)

Date: Fri Jul  1 16:53:42 2005
Author: crhodes

Index: mcclim/Lisp-Dep/mp-sbcl.lisp
diff -u mcclim/Lisp-Dep/mp-sbcl.lisp:1.6 mcclim/Lisp-Dep/mp-sbcl.lisp:1.7
--- mcclim/Lisp-Dep/mp-sbcl.lisp:1.6	Mon Feb 23 11:48:28 2004
+++ mcclim/Lisp-Dep/mp-sbcl.lisp	Fri Jul  1 16:53:42 2005
@@ -40,41 +40,54 @@
   state
   whostate
   function
-  id)
+  thread)
 
 (defvar *current-process*
-  (%make-process :name "initial process" :function nil :id (sb-thread:current-thread-id)))
+  (%make-process
+   :name "initial process" :function nil
+   :thread
+   #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
+   sb-thread:*current-thread*
+   #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
+   (sb-thread:current-thread-id)))
 
 (defvar *all-processes* (list *current-process*))
 
+(defvar *all-processes-lock*
+  (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))
+
 (defvar *permanent-queue*
   (sb-thread:make-mutex :name "Lock for disabled threads"
 			:data :permanently-queued))
 
 (defun make-process (function &key name)
-  (let ((p (%make-process :name name
-			  :function function)))
-    (pushnew p *all-processes*)
+  (let ((p (%make-process :name name :function function)))
+    (sb-thread:with-mutex (*all-processes-lock*)
+      (pushnew p *all-processes*))
     (restart-process p)))
 
 (defun restart-process (p)
   (labels ((boing ()
 	     (let ((*current-process* p))
 	       (funcall (process-function p) ))))
-    (when (process-id p) (sb-thread:terminate-thread p))
-    (when (setf (process-id p) (sb-thread:make-thread #'boing))
+    (when (process-thread p) (sb-thread:terminate-thread p))
+    (when (setf (process-thread p) (sb-thread:make-thread #'boing))
       p)))
 
 (defun destroy-process (process)
-  ;;; ew threadsafety
-  (setf *all-processes* (delete process *all-processes*))
-  (sb-thread:terminate-thread (process-id process)))
+  (sb-thread:with-mutex (*all-processes-lock*)
+    (setf *all-processes* (delete process *all-processes*)))
+  (sb-thread:terminate-thread (process-thread process)))
 
 (defun current-process ()
   *current-process*)
 
 (defun all-processes ()
-  *all-processes*)
+  ;; we're calling DELETE on *ALL-PROCESSES*.  If we look up the value
+  ;; while that delete is executing, we could end up with nonsense.
+  ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS).
+  (sb-thread:with-mutex (*all-processes-lock*)
+    *all-processes*))
 
 ;;; people should be shot for using these, honestly.  Use a queue!
 (declaim (inline yield))
@@ -113,17 +126,17 @@
       (setf (process-whostate *current-process*) old-state))))
 
 (defun process-interrupt (process function)
-  (sb-thread:interrupt-thread (process-id process) function))
+  (sb-thread:interrupt-thread (process-thread process) function))
 
 (defun disable-process (process)
   (sb-thread:interrupt-thread
-   (process-id process)
+   (process-thread process)
    (lambda ()
      (catch 'interrupted-wait (sb-thread:get-mutex *permanent-queue*)))))
 
 (defun enable-process (process)
   (sb-thread:interrupt-thread
-   (process-id process) (lambda () (throw 'interrupted-wait nil))))
+   (process-thread process) (lambda () (throw 'interrupted-wait nil))))
 
 (defun process-yield ()
   (sleep .1))