Changeset 15145

Timestamp:

Dec 17, 2011, 9:24:51 PM (13 years ago)

Author:

Gary Byers

Message:

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

File:

• trunk/source/level-1/l1-lisp-threads.lisp (modified) (4 diffs)

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

@@ -1021 +1021 @@
 (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
@@ -1032 +1049 @@
         (population *termination-population*))
     (without-interrupts
+     (register-termination-function function)
      (with-lock-grabbed (*termination-population-lock*)
        (atomic-push-uvector-cell population population.data new-cell)))
@@ -1047 +1065 @@
           (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 function-p))
@@ -1066 +1086 @@
                          (or (null function-p)
                              (eq function f)))
+                (deregister-termination-function f)
                 (if prev
                   (setf (cdr prev) (cdr spine))