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))