~ chicken-core (chicken-5) 2274f2d428567b0697df5252e8f80397f7fe7ac4

commit 2274f2d428567b0697df5252e8f80397f7fe7ac4
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 7 10:40:58 2023 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Tue Jul 18 08:26:34 2023 +0200

    Added thread-safe finalization method ("make-finalizer")
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/NEWS b/NEWS
index a371ff8e..19d2f30e 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,8 @@
     the first non-runtime option or after "-:", whichever comes first.
 
 - Core libraries
+  - Added "make-finalizer" to execute finalizers in a thread-safe
+    manner.
   - Added weak pairs to (chicken base), with similar behaviour to Chez Scheme.
   - Added "locative-index", kindly contributed by John Croisant.
   - Added "fp*+" (fused multiply-add) to "chicken.flonum" module
diff --git a/library.scm b/library.scm
index 9b5a8ff7..f7d3c01d 100644
--- a/library.scm
+++ b/library.scm
@@ -6153,7 +6153,8 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
 
 
 (module chicken.gc
-    (current-gc-milliseconds gc memory-statistics set-finalizer!
+    (current-gc-milliseconds gc memory-statistics 
+     set-finalizer! make-finalizer add-to-finalizer
      set-gc-report! force-finalizers)
 
 (import scheme)
@@ -6187,7 +6188,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
 
 (define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))
 
-(define set-finalizer! 
+(define ##sys#init-finalizer
   (let ((string-append string-append))
     (lambda (x y)
       (when (fx>= (##core#inline "C_i_live_finalizer_count") _max_pending_finalizers)
@@ -6217,6 +6218,36 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
 	       (##sys#force-finalizers) ) ) )
       (##sys#set-finalizer! x y) ) ) )
 
+(define set-finalizer! ##sys#init-finalizer)
+
+(define finalizer-tag (vector 'finalizer))
+
+(define (finalizer? x)
+  (and (pair? x) (eq? finalizer-tag (##sys#slot x 0))) )
+
+(define (make-finalizer . objects)
+  (let ((q (##sys#make-event-queue)))
+    (define (handler o) (##sys#add-event-to-queue! q o))
+    (define (handle o) (##sys#init-finalizer o handler))
+    (for-each handle objects)
+    (##sys#decorate-lambda
+       (lambda (#!optional mode)
+         (if mode
+             (##sys#wait-for-next-event q)
+             (##sys#get-next-event q)))
+       finalizer?
+       (lambda (proc i)
+         (##sys#setslot proc i (cons finalizer-tag handle))
+         proc))))
+
+(define (add-to-finalizer f . objects)
+  (let ((af (and (procedure? f)
+                 (##sys#lambda-decoration f finalizer?))))
+    (unless af
+      (error 'add-to-finalizer "bad argument type - not a finalizer procedure" 
+             f))
+    (for-each (cdr af) objects)))
+
 (define ##sys#run-pending-finalizers
   (let ((vector-fill! vector-fill!)
 	(string-append string-append)
diff --git a/manual/Module (chicken gc) b/manual/Module (chicken gc)
index 25a29373..c20613da 100644
--- a/manual/Module (chicken gc)	
+++ b/manual/Module (chicken gc)	
@@ -40,11 +40,11 @@ because CHICKEN uses a copying semi-space collector.
 Registers a procedure of one argument {{PROC}}, that will be
 called as soon as the non-immediate data object {{X}} is about to
 be garbage-collected (with that object as its argument). Note that
-the finalizer will '''not''' be called while interrupts are disabled.
 This procedure returns {{X}}.
 
-Finalizers are invoked asynchronously, in the thread that happens
-to be currently running. Finalizers for data that has become garbage
+Finalizers installed using {{set-finalizer!}} are invoked asynchronously, 
+in the thread that happens to be currently running.
+Finalizers for data that has become garbage
 are called on normal program exit. Finalizers are not run on
 abnormal program exit. A normal program exit does not run finalizers
 that are still reachable from global data. 
@@ -53,13 +53,49 @@ Multiple finalizers can be registered for the same object. The order
 in which the finalizers run is undefined. Execution of finalizers
 may be nested.
 
-NOTE: When a finalizable object has any weak references (i.e., weak
+NOTE 1: The finalizer will '''not''' be called while interrupts are disabled.
+
+NOTE 2: When a finalizable object has any weak references (i.e., weak
 locatives or weak pairs) to objects that are only reachable through it
 or other finalizable objects, those references will be broken like
 when the objects had already been collected.  This is done in order to
 avoid user code from accessing objects that are possibly in an
 invalid state.
 
+
+=== make-finalizer
+
+<procedure>(make-finalizer OBJECT ...)</procedure>
+
+Registers the set of non-immediate argument objects for finalization and 
+returns a procedure of zero or one arguments. Invoking this procedure
+will return the first object from the set that
+is not referenced from any other globally reachable data and can be
+garbage collected.
+Non-immediate objects are anything that is not a small integer ("fixnum"),
+a character, a boolean, the empty list, the undefined value, the end-of-file
+value ({{#!eof}}) or the broken-weak-pair object ({{#!bwp}}).
+
+Note that you can pass procedures created by {{make-finalizer}} to
+{{make-finalizer}} itself, implying that a finalizer procedure is finalized
+when all associated objects are.
+
+The procedure returned by {{make-finalizer}} behaves differently
+depending on the argument given: If the argument is missing or {{#f}},
+then it returns {{#f}} when no object has as yet been finalized.
+When the argument is {{#t}}, execution of the current thread suspends until a finalization
+occurs. If no other threads are executing then execution pauses for eternity.
+
+The same caveat regarding weak references applies to finalizers
+registered with {{make-finalizer}}.  See {{NOTE 2}} in {{set-finalizer!}}.
+
+=== add-to-finalizer
+
+<procedure>(add-to-finalizer FINALIZER OBJECT ...)</procedure>
+
+Add further objects to the finalization procedure {{FINALIZER}}, in
+addition to the objects already supplied when invoking {{make-finalizer}}.
+
 === force-finalizers
 
 <parameter>(force-finalizers)</parameter>
diff --git a/tests/test-finalizers-2.scm b/tests/test-finalizers-2.scm
index 7d244f9e..cd9c2028 100644
--- a/tests/test-finalizers-2.scm
+++ b/tests/test-finalizers-2.scm
@@ -63,3 +63,21 @@ freef(void *r)
   (print "forcing remaining")
   (##sys#force-finalizers)
   (assert (= *n* *count*)))
+
+;;; new finalizer API
+
+(define c1 (list *count*))
+(define f1 (make-finalizer c1))
+(add-to-finalizer f1 (make-vector 10))
+(define f2 (make-finalizer f1))
+(gc #t)
+(assert (vector? (f1)))
+(assert (not (f1)))
+(set! c1 #f)
+(gc #t)
+(assert (equal? (f1) (list *count*)))
+(assert (not (f1)))
+(set! f1 #f)
+(gc #t)
+(assert (procedure? (f2)))
+(assert (not (f2)))
diff --git a/types.db b/types.db
index b2594112..62d98126 100644
--- a/types.db
+++ b/types.db
@@ -1395,6 +1395,8 @@
 (chicken.gc#gc (#(procedure #:clean) chicken.gc#gc (#!optional *) fixnum))
 (chicken.gc#memory-statistics (#(procedure #:clean) chicken.gc#memory-statistics () (vector-of fixnum)))
 (chicken.gc#set-finalizer! (#(procedure #:clean #:enforce) chicken.gc#set-finalizer! (* (procedure (*) . *)) *))
+(chicken.gc#make-finalizer (#(procedure #:clean #:enforce) chicken.gc#make-finalizer (#!rest *) (procedure (#!optional boolean) *)))
+(chicken.gc#add-to-finalizer (#(procedure #:clean #:enforce) chicken.gc#add-to-finalizer (procedure #!rest *) undefined))
 (chicken.gc#set-gc-report! (#(procedure #:clean) chicken.gc#set-gc-report! (*) undefined))
 
 (chicken.repl#repl (#(procedure #:enforce) chicken.repl#repl (#!optional (procedure (*) . *)) undefined))