From 28c79faf7d9a08d6f3d8c242ec8873bd433e22d7 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 9 Jul 2015 19:20:22 -0700
Subject: [PATCH] gcfinal: Assume GC daemon is running concurrently with other
 threads.

---
 src/runtime/gcfinal.scm | 69 +++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 34 deletions(-)

diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm
index a62c04dd6..5a0325395 100644
--- a/src/runtime/gcfinal.scm
+++ b/src/runtime/gcfinal.scm
@@ -189,43 +189,44 @@ USA.
 (define gc-finalizers-mutex)
 
 (define (reset-gc-finalizers)
-  (walk-gc-finalizers-list
+  (walk-gc-finalizers-list/unsafe
    (lambda (finalizer)
-     (with-thread-mutex-lock (gc-finalizer-mutex finalizer)
-       (lambda ()
-	 (set-gc-finalizer-items! finalizer '()))))))
+     (set-gc-finalizer-items! finalizer '()))))
 
 (define (run-gc-finalizers)
-  (walk-gc-finalizers-list
-   (lambda (finalizer)
-     (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)))))))))
-
-(define (walk-gc-finalizers-list procedure)
-  (with-thread-mutex-lock gc-finalizers-mutex
-    (lambda ()
-      (let loop ((finalizers gc-finalizers) (prev #f))
-	(if (weak-pair? finalizers)
-	    (let ((finalizer (weak-car finalizers)))
-	      (if finalizer
-		  (begin
-		    (procedure finalizer)
-		    (loop (weak-cdr finalizers) finalizers))
-		  (let ((next (weak-cdr finalizers)))
-		    (if prev
-			(weak-set-cdr! prev next)
-			(set! gc-finalizers next))
-		    (loop next prev)))))))))
+  (with-thread-mutex-try-lock
+   gc-finalizers-mutex
+   (lambda ()
+     (walk-gc-finalizers-list/unsafe
+      (lambda (finalizer)
+	(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)))
+
+(define (walk-gc-finalizers-list/unsafe procedure)
+  (let loop ((finalizers gc-finalizers) (prev #f))
+    (if (weak-pair? finalizers)
+	(let ((finalizer (weak-car finalizers)))
+	  (if finalizer
+	      (begin
+		(procedure finalizer)
+		(loop (weak-cdr finalizers) finalizers))
+	      (let ((next (weak-cdr finalizers)))
+		(if prev
+		    (weak-set-cdr! prev next)
+		    (set! gc-finalizers next))
+		(loop next prev)))))))
 
 (define (initialize-package!)
   (set! gc-finalizers '())
-- 
2.25.1