Here another attempt at a finalizer API, allowing adding
finalized objects to an existing finalizer after it was
created.
felix
From 89b181be98685943425aae646ee724e9d59a2bec Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Fri, 7 Jul 2023 10:40:58 +0200
Subject: [PATCH] Added thread-safe finalization method ("make-finalizer")
---
NEWS | 2 ++
library.scm | 35 ++++++++++++++++++++++++++++++++--
manual/Module (chicken gc) | 38 ++++++++++++++++++++++++++++++++++---
srfi-4.scm | 18 +++++++++---------
tests/test-finalizers-2.scm | 18 ++++++++++++++++++
types.db | 2 ++
6 files changed, 99 insertions(+), 14 deletions(-)
diff --git a/NEWS b/NEWS
index 68940ef5..40866cb5 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 989f421f..67520e36 100644
--- a/library.scm
+++ b/library.scm
@@ -6152,7 +6152,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)
@@ -6186,7 +6187,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)
@@ -6216,6 +6217,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 48653e3a..ed3a077e 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,6 +53,38 @@ 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 that
+the finalizer will '''not''' be called while interrupts are disabled.
+
+=== 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.
+
+=== 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
diff --git a/srfi-4.scm b/srfi-4.scm
index 0d908f0c..f2dee993 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -303,7 +303,7 @@ EOF
(set! make-s8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector 1 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -315,7 +315,7 @@ EOF
(set! make-u16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector 2 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -327,7 +327,7 @@ EOF
(set! make-s16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector 2 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -339,7 +339,7 @@ EOF
(set! make-u32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector 4 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -351,7 +351,7 @@ EOF
(set! make-u64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 'u64vector (alloc 'make-u64vector 8 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -363,7 +363,7 @@ EOF
(set! make-s32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector 4 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -375,7 +375,7 @@ EOF
(set! make-s64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 's64vector (alloc 'make-s64vector 8 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -387,7 +387,7 @@ EOF
(set! make-f32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector 4 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
@@ -401,7 +401,7 @@ EOF
(set! make-f64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
(let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector 8 len
ext?))))
- (when (and ext? fin?) (set-finalizer! v ext-free))
+ (when (and ext? fin?) (##sys#init-finalizer v ext-free))
(if (not init)
v
(begin
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 0e7cb859..8cc82a2a 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))
--
2.33.0
