From 89b181be98685943425aae646ee724e9d59a2bec Mon Sep 17 00:00:00 2001 From: felix 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 + +(make-finalizer OBJECT ...) + +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 + +(add-to-finalizer FINALIZER OBJECT ...) + +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