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

[gb at clozure.com]

Author: gb
Date: Wed Oct 21 22:34:30 2009
New Revision: 13078

Log:
CANCEL-TERMINATE-WHEN-UNREACHABLE: it seems that this can be much
simpler than it has been; notably, avoid the use of WITH-DEFERRED-GC,
since that may lead to missed suspend signals.

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 Wed Oct 21 22:34:30 2009
@@ -987,29 +987,26 @@
 (defun cancel-terminate-when-unreachable (object &optional (function nil f=
unction-p))
   (let* ((found nil))
     (with-lock-grabbed (*termination-population-lock*)
-      ;; Have to defer GCing, e.g., defer responding to a GC
-      ;; suspend request here (that also defers interrupts)
-      ;; We absolutely, positively can't take an exception
-      ;; in here, so don't even bother to typecheck on =

-      ;; car/cdr etc.
-      (with-deferred-gc
-          (do ((spine (population-data *termination-population*) (cdr spin=
e))
-               (prev nil spine))
-              ((null spine))
-            (declare (optimize (speed 3) (safety 0)))
-            (let* ((head (car spine))
-                   (tail (cdr spine))
-                   (o (car head))
-                   (f (cdr head)))
+      ;; We don't really need to be very paranoid here.  Nothing can
+      ;; be added to the termination queue while we hold the lock,
+      ;; and the GC can't splice anything out of the list while
+      ;; we hold a strong reference to that list.
+      (let* ((population *termination-population*)
+             (queue (population.data population)))
+        (do* ((prev nil spine)
+              (spine queue (cdr spine)))
+             ((null tail))
+          (let* ((entry (car spine)))
+            (destructuring-bind (o . f) entry
               (when (and (eq o object)
                          (or (null function-p)
                              (eq function f)))
                 (if prev
-                  (setf (cdr prev) tail)
-                  (setf (population-data *termination-population*) tail))
+                  (setf (cdr prev) (cdr spine))
+                  (setf (population.data population) (cdr spine)))
                 (setq found t)
                 (return)))))
-      found)))
+      found))))
 =

 =

 (defun termination-function (object)