[Openmcl-cvs-notifications] r15145 - /trunk/source/level-1/l1-lisp-threads.lisp

[gb at clozure.com]

Author: gb
Date: Sat Dec 17 23:24:51 2011
New Revision: 15145

Log:
Try to address ticket:896 (at least the parts that aren't "this isn't
Smalltalk.")  For the time being, do so by holding strong references
to termination functions while they're on the finalization alist; it
might be preferable to do this in the GC, but this approach is better
than forcing the user to do it themselves.

It's now the case that if a  termination function (transitively) refers
to the associated object the object won't be terminated (or even GCed.)

Modified:
    trunk/source/level-1/l1-lisp-threads.lisp

Modified: trunk/source/level-1/l1-lisp-threads.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-lisp-threads.lisp (original)
+++ trunk/source/level-1/l1-lisp-threads.lisp Sat Dec 17 23:24:51 2011
@@ -1020,6 +1020,23 @@
 =

 (defvar *enable-automatic-termination* t)
 =

+(defstatic  *termination-functions-lock* (make-lock))
+(defstatic *termination-functions* (make-hash-table :test #'eq :lock-free =
nil))
+
+(defun register-termination-function (f)
+  (with-lock-grabbed (*termination-functions-lock*)
+    (without-interrupts
+     (incf (gethash f *termination-functions* 0)))))
+
+(defun deregister-termination-function (f) =

+  (with-lock-grabbed (*termination-functions-lock*)
+    (without-interrupts
+     (let* ((count (gethash f *termination-functions*)))
+       (when count
+         (if (eql 0 (decf count))
+           (remhash f *termination-functions*)
+           (setf (gethash f *termination-functions*) count)))))))
+
 (defun terminate-when-unreachable (object &optional (function 'terminate))
   "The termination mechanism is a way to have the garbage collector run a
 function right before an object is about to become garbage. It is very
@@ -1031,6 +1048,7 @@
   (let ((new-cell (cons object function))
         (population *termination-population*))
     (without-interrupts
+     (register-termination-function function)
      (with-lock-grabbed (*termination-population-lock*)
        (atomic-push-uvector-cell population population.data new-cell)))
     function))
@@ -1046,7 +1064,9 @@
             (atomic-pop-uvector-cell population population.termination-lis=
t)
           (if (not existed)
             (return)
-          (funcall (cdr cell) (car cell))))))))
+            (let* ((f (cdr cell)))
+              (deregister-termination-function f)
+              (funcall f (car cell)))))))))
 =

 (defun cancel-terminate-when-unreachable (object &optional (function nil f=
unction-p))
   (let* ((found nil))
@@ -1065,6 +1085,7 @@
               (when (and (eq o object)
                          (or (null function-p)
                              (eq function f)))
+                (deregister-termination-function f)
                 (if prev
                   (setf (cdr prev) (cdr spine))
                   (setf (population.data population) (cdr spine)))