run-gc-finalizers: Avoid deadlock in this GC daemon.

If a GC interrupts a finalizer operation that is holding the
finalizer's lock, it will deadlock in the GC daemon unless it can
punt.

diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm
index d783e3cdebd6e108c73c0838de58e94a7f1c87b9..c57882e9446436500caabe762d63769acd1a1fa7 100644 (file)
--- a/src/runtime/gcfinal.scm
+++ b/src/runtime/gcfinal.scm
@@ -205,20 +205,25 @@ USA.
    (lambda ()
      (walk-gc-finalizers-list/unsafe
       (lambda (finalizer)
-       (with-finalizer-lock finalizer
+       (with-thread-mutex-try-lock
+           (gc-finalizer-mutex finalizer)
          (lambda ()
-           (let ((procedure (gc-finalizer-procedure finalizer)))
-             (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
-               (if (pair? items)
-                   (if (weak-pair/car? (car items))
-                       (loop (cdr items) items)
-                       (let ((context (weak-cdr (car items)))
-                             (next (cdr items)))
-                         (if prev
-                             (set-cdr! prev next)
-                             (set-gc-finalizer-items! finalizer next))
-                         (procedure context)
-                         (loop next prev)))))))))))
+           (without-interruption
+            (lambda ()
+              (let ((procedure (gc-finalizer-procedure finalizer)))
+                (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+                  (if (pair? items)
+                      (if (weak-pair/car? (car items))
+                          (loop (cdr items) items)
+                          (let ((context (weak-cdr (car items)))
+                                (next (cdr items)))
+                            (if prev
+                                (set-cdr! prev next)
+                                (set-gc-finalizer-items! finalizer next))
+                            (procedure context)
+                            (loop next prev)))))))))
+         (lambda ()
+           unspecific)))))
    (lambda ()
      unspecific)))