[cl-debian] Bug#344415: cl-mcclim: is incompatible with recent SBCL's threading API

[René van Bevern]

Package: cl-mcclim
Severity: normal
Tags: patch etch sid

Since SBCL 0.9.3, there is a new API for threading. The McClim version
in Debian Unstable and Testing still uses the old API and therefore fails
being compiled by recent SBCL versions in these Debian distributions:

; /var/cache/common-lisp-controller/rvb/sbcl/mcclim/Lisp-Dep/mp-sbcl.fasl written
; compilation finished in 0:00:01
WARNING:
   COMPILE-FILE warned while performing #<COMPILE-OP NIL {B825DD9}> on
   #<CL-SOURCE-FILE "mp-sbcl" {B6FD599}>.

debugger invoked on a ASDF:COMPILE-FAILED in thread
#<THREAD "initial thread" {AA83491}>:
  erred while invoking #<COMPILE-OP NIL {B825DD9}> on
  #<CL-SOURCE-FILE "mp-sbcl" {B6FD599}>

Type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL.

restarts (invokable by number or by possibly-abbreviated name):
  0: [RETRY ] Retry performing #<ASDF:COMPILE-OP NIL {B825DD9}> on
              #<ASDF:CL-SOURCE-FILE "mp-sbcl" {B6FD599}>.
  1: [ACCEPT] Continue, treating #<ASDF:COMPILE-OP NIL {B825DD9}> on
              #<ASDF:CL-SOURCE-FILE "mp-sbcl" {B6FD599}> as having been
              successful.
  2: [ABORT ] Exit debugger, returning to top level.

The current CVS version of McClim contains updates for the new SBCL threading API.
I am attaching the extracted patch and hereby report that applying these patches
makes SBCL compile McClim cleanly.

Thank you for considering,
	René van Bevern
-------------- next part --------------
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mcclim/Lisp-Dep/mp-sbcl.lisp	2005/07/01 14:53:42	1.7
+++ mcclim/Lisp-Dep/mp-sbcl.lisp	2005/07/15 16:36:58	1.8
@@ -56,9 +56,14 @@
 (defvar *all-processes-lock*
   (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))
 
+;; we implement disable-process by making the disablee attempt to lock
+;; *permanent-queue*, which is already locked because we locked it
+;; here.  enable-process just interrupts the lock attempt.
+
 (defvar *permanent-queue*
-  (sb-thread:make-mutex :name "Lock for disabled threads"
-			:data :permanently-queued))
+  (sb-thread:make-mutex :name "Lock for disabled threads"))
+(unless (sb-thread:mutex-value *permanent-queue*)
+  (sb-thread:get-mutex *permanent-queue* :locked nil))
 
 (defun make-process (function &key name)
   (let ((p (%make-process :name name :function function)))
@@ -146,16 +151,15 @@
 (defmacro without-scheduling (&body body)
   `(progn , at body))
 
-(defparameter *atomic-queue*
-  #+xlib xlib::*conditional-store-queue*
-  #-xlib (sb-thread:make-waitqueue :name "atomic incf/decf"))
+(defparameter *atomic-lock*
+  (sb-thread:make-mutex :name "atomic incf/decf"))
 
 (defmacro atomic-incf (place)
-  `(sb-thread::with-spinlock (*atomic-queue*)
+  `(sb-thread:with-mutex (*atomic-lock*)
     (incf ,place)))
 
 (defmacro atomic-decf (place) 
-  `(sb-thread::with-spinlock (*atomic-queue*)
+  `(sb-thread:with-mutex (*atomic-lock*)
     (decf ,place)))
 
 ;;; 32.3 Locks
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- mcclim/Lisp-Dep/mp-sbcl.lisp	2004/02/23 10:48:28	1.6
+++ mcclim/Lisp-Dep/mp-sbcl.lisp	2005/07/01 14:53:42	1.7
@@ -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))