From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 2 Feb 2016 23:53:08 +0000 (-0700)
Subject: run-gc-finalizers: Avoid deadlock in this GC daemon.
X-Git-Tag: mit-scheme-pucked-9.2.12~371^2~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d70d3ea70363fce36dbb920484673ecffec64ff4;p=mit-scheme.git

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 d783e3cde..c57882e94 100644
--- 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)))