[Openmcl-devel] Using defcallback

[Gary Byers]

On Wed, 17 Mar 2004, [ISO-8859-1] Stéphane Letz wrote:

> Hi,
>
> We are experimenting the use of "defcallback" to define Lisp callback
> to be called by native code (inside real-time MIDI  interrupts, using
> MidiShare www.grame.fr/MidiShare)
>
> Evrything works really well, Lisp code is called by the native side
> without any special problem.
>
> But there is problem when quitting OpenMCL.
> Actually OpenMCL can not be quitted anymore (the lisp (quit) function
> seems to wait for something and the OpenMCL process never quits)
>
> Is thre anything special to do when using defcallback to be able to
> quit properly?
>
> Thanks
>
> Stephane  Letz

If the callbacks are being made from "foreign threads" (threads that weren't
created from lisp code), the problem may be that those threads aren't
initialized correctly.  ("initializing" a foreign thread involves setting
up dynamic bindings for things like *CURRENT-PROCESS* and other special
variables.   The way that special/dynamic binding works changed about
6 months ago, but the function CCL::%INITIALIZE-FOREIGN-THREAD didn't
change at that time.  It should have.)

I believe that the enclosed patch fixes this problem.
-------------- next part --------------
Index: ppc-threads-utils.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14/ccl/level-1/ppc-threads-utils.lisp,v
retrieving revision 1.2
diff -u -r1.2 ppc-threads-utils.lisp
--- ppc-threads-utils.lisp	20 Dec 2003 08:40:45 -0000	1.2
+++ ppc-threads-utils.lisp	17 Mar 2004 14:19:50 -0000
@@ -159,15 +159,22 @@
   (let* ((bsp (%saved-bindings-address))
 	 (initial-bindings (%fixnum-ref bsp )))
     (declare (fixnum bsp))
-    (flet ((save-binding (value symbol prev)
-	     (setf (%fixnum-ref bsp -4) value
-		   (%fixnum-ref bsp -8) symbol
-		   (%fixnum-ref bsp -12) prev
-		   bsp (- bsp 3))))
-      (save-binding nil '*current-lisp-thread* 0)
-      (save-binding nil '*current-process* bsp)
+    ;; Um, this is a little more complicated now that we use
+    ;; thread-local shallow binding
+    (flet ((save-binding (new-value svar prev)
+             (let* ((idx (%svref svar target::svar.idx-cell))
+                    (byte-idx (ash idx target::fixnum-shift))
+                    (binding-vector (%fixnum-ref (%current-tcr) target::tcr.tlb-pointer))
+                    (old-value (%fixnum-ref  binding-vector byte-idx)))
+	     (setf (%fixnum-ref binding-vector byte-idx) new-value
+                   (%fixnum-ref bsp (ash -1 target::word-shift)) old-value
+		   (%fixnum-ref bsp (ash -2 target::word-shift)) idx
+		   (%fixnum-ref bsp (ash -3 target::word-shift)) prev
+		   bsp (- bsp 3)))))
+      (save-binding nil (ensure-svar '*current-lisp-thread*) 0)
+      (save-binding nil (ensure-svar '*current-process*) bsp)
       (dolist (pair initial-bindings)
-	(save-binding (funcall (cdr pair)) (car pair) bsp))
+	(save-binding (funcall (cdr pair)) (ensure-svar (car pair)) bsp))
       (setf (%fixnum-ref (%current-tcr) ppc32::tcr.db-link) bsp)
       ;; Ensure that pending unwind-protects (for WITHOUT-INTERRUPTS
       ;; on the callback) don't try to unwind the binding stack beyond
@@ -175,7 +182,7 @@
       (let* ((top-catch (%fixnum-ref (%current-tcr) ppc32::tcr.catch-top)))
         (unless (eql 0 top-catch)
           (setf (%fixnum-ref top-catch ppc32::catch-frame.db-link) bsp)))))
-  (let* ((thread (new-lisp-thread-from-tcr (%current-tcr) nil)))
+  (let* ((thread (new-lisp-thread-from-tcr (%current-tcr) "foreign")))
     (setq *current-lisp-thread* thread
 	  *current-process*
 	  (make-process "foreign" :thread thread))