Index: /trunk/source/level-1/l1-lisp-threads.lisp
===================================================================
--- /trunk/source/level-1/l1-lisp-threads.lisp	(revision 15144)
+++ /trunk/source/level-1/l1-lisp-threads.lisp	(revision 15145)
@@ -1021,4 +1021,21 @@
 (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,4 +1049,5 @@
         (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,5 +1065,7 @@
           (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,4 +1086,5 @@
                          (or (null function-p)
                              (eq function f)))
+                (deregister-termination-function f)
                 (if prev
                   (setf (cdr prev) (cdr spine))