diff --git a/am/bootstrap.am b/am/bootstrap.am index 96023d83d..345b10ffc 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -1,4 +1,4 @@ -## Copyright (C) 2009-2024 Free Software Foundation, Inc. +## Copyright (C) 2009-2025 Free Software Foundation, Inc. ## ## This file is part of GNU Guile. ## @@ -366,6 +366,7 @@ SOURCES = \ system/base/types/internal.scm \ system/base/ck.scm \ \ + system/finalizers.scm \ system/foreign.scm \ system/foreign-library.scm \ system/foreign-object.scm \ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 308052026..e8be11227 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -281,6 +281,7 @@ DOT_X_FILES = \ fdes-finalizers.x \ feature.x \ filesys.x \ + finalizers.x \ fluids.x \ foreign.x \ fports.x \ diff --git a/libguile/finalizers.c b/libguile/finalizers.c index 231e8c723..36159488f 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -32,12 +32,16 @@ #include #include "async.h" +#include "atomics-internal.h" #include "bdw-gc.h" +#include "eval.h" +#include "extensions.h" #include "gc.h" #include "gsubr.h" #include "init.h" +#include "numbers.h" #include "threads.h" -#include "atomics-internal.h" +#include "version.h" #include "finalizers.h" @@ -53,6 +57,13 @@ static SCM run_finalizers_subr; +enum finalizer_priority + { + FINALIZER_PRIORITY_GUARDIAN, + FINALIZER_PRIORITY_DEFAULT + }; + + void scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data) { @@ -139,6 +150,29 @@ scm_i_add_finalizer (void *obj, scm_t_finalizer_proc proc, void *data) shuffle_resuscitators_to_front (chained_data); } +static void +invoke_finalizer (void *obj, void *data) +{ + scm_call_1 (PTR2SCM (data), PTR2SCM (obj)); +} + +SCM_DEFINE_STATIC(scm_sys_add_finalizer, "%add-finalizer!", 3, 0, 0, + (SCM obj, SCM proc, SCM priority), + "Add a finalizer @var{proc} to object @var{obj}, with " + "priority @var{priority}. Return the finalizer object.") +#define FUNC_NAME s_scm_sys_add_finalizer +{ + SCM_MAKE_VALIDATE (1, obj, HEAP_OBJECT_P); + SCM_VALIDATE_PROC (2, proc); + size_t c_priority = scm_to_unsigned_integer (priority, + FINALIZER_PRIORITY_GUARDIAN, + FINALIZER_PRIORITY_DEFAULT); + + (void) c_priority; + scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (proc)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME @@ -447,6 +481,17 @@ scm_run_finalizers (void) +static void scm_init_finalizers_module (void); + +void +scm_register_finalizers (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_finalizers_module", + (scm_t_extension_init_func)scm_init_finalizers_module, + NULL); +} + void scm_init_finalizers (void) { @@ -459,6 +504,14 @@ scm_init_finalizers (void) GC_set_finalizer_notifier (queue_finalizer_async); } +static void +scm_init_finalizers_module (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "finalizers.x" +#endif +} + void scm_init_finalizer_thread (void) { diff --git a/libguile/finalizers.h b/libguile/finalizers.h index a92a74be1..f173dc7a9 100644 --- a/libguile/finalizers.h +++ b/libguile/finalizers.h @@ -48,6 +48,7 @@ SCM_INTERNAL int scm_i_is_finalizer_thread (struct scm_thread *thread); SCM_API int scm_set_automatic_finalization_enabled (int enabled_p); SCM_API int scm_run_finalizers (void); +SCM_INTERNAL void scm_register_finalizers (void); SCM_INTERNAL void scm_init_finalizers (void); SCM_INTERNAL void scm_init_finalizer_thread (void); diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c index 21dc2c007..95cc0bfee 100644 --- a/libguile/foreign-object.c +++ b/libguile/foreign-object.c @@ -1,4 +1,4 @@ -/* Copyright 2014,2017-2018 +/* Copyright 2014,2017-2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -25,10 +25,8 @@ #endif #include "eval.h" -#include "extensions.h" #include "finalizers.h" #include "goops.h" -#include "gsubr.h" #include "list.h" #include "modules.h" #include "numbers.h" @@ -196,37 +194,3 @@ scm_foreign_object_set_x (SCM obj, size_t n, void *val) scm_t_bits bits = (scm_t_bits) val; scm_foreign_object_unsigned_set_x (obj, n, bits); } - -static void -invoke_finalizer (void *obj, void *data) -{ - scm_call_1 (PTR2SCM (data), PTR2SCM (obj)); -} - -static SCM -sys_add_finalizer_x (SCM obj, SCM finalizer) -#define FUNC_NAME "%add-finalizer!" -{ - SCM_VALIDATE_PROC (SCM_ARG2, finalizer); - - scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer)); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -static void -scm_init_foreign_object (void) -{ - scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0, - (scm_t_subr) sys_add_finalizer_x); -} - -void -scm_register_foreign_object (void) -{ - scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, - "scm_init_foreign_object", - (scm_t_extension_init_func)scm_init_foreign_object, - NULL); -} diff --git a/libguile/foreign-object.h b/libguile/foreign-object.h index d6ca94512..9ee952d10 100644 --- a/libguile/foreign-object.h +++ b/libguile/foreign-object.h @@ -1,7 +1,7 @@ #ifndef SCM_FOREIGN_OBJECT_H #define SCM_FOREIGN_OBJECT_H -/* Copyright 2014,2018 +/* Copyright 2014,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -56,7 +56,5 @@ SCM_API scm_t_signed_bits scm_foreign_object_signed_ref (SCM obj, size_t n); SCM_API void scm_foreign_object_signed_set_x (SCM obj, size_t n, scm_t_signed_bits val); -SCM_INTERNAL void scm_register_foreign_object (void); - #endif /* SCM_FOREIGN_OBJECT_H */ diff --git a/libguile/init.c b/libguile/init.c index 179f8dea5..12a0c6671 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -370,8 +370,8 @@ scm_i_init_guile (struct gc_stack_addr base) scm_register_atomic (); scm_register_custom_ports (); scm_register_fdes_finalizers (); + scm_register_finalizers (); scm_register_foreign (); - scm_register_foreign_object (); scm_register_srfi_60 (); scm_register_poll (); diff --git a/module/system/finalizers.scm b/module/system/finalizers.scm new file mode 100644 index 000000000..1193439e5 --- /dev/null +++ b/module/system/finalizers.scm @@ -0,0 +1,34 @@ +;;; Copyright (C) 2025 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + + +(define-module (system finalizers) + #:export (add-finalizer! + %guardian-finalizer-priority + %default-finalizer-priority)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_finalizers_module")) + +(define %guardian-finalizer-priority 1) +(define %default-finalizer-priority 0) + +(define* (add-finalizer! obj proc + #:optional (priority %default-finalizer-priority)) + "Add a finalizer @var{proc} to object @var{obj}, with priority +@var{priority}. Return the finalizer object." + (%add-finalizer! obj proc priority)) diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm index 3f05ccaad..2e613d406 100644 --- a/module/system/foreign-object.scm +++ b/module/system/foreign-object.scm @@ -1,6 +1,6 @@ ;;; Wrapping foreign objects in Scheme -;;; Copyright (C) 2014, 2015, 2024 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2024, 2025 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -24,13 +24,10 @@ (define-module (system foreign-object) #:use-module (oop goops) + #:use-module (system finalizers) #:export (make-foreign-object-type define-foreign-object-type)) -(eval-when (eval load expand) - (load-extension (string-append "libguile-" (effective-version)) - "scm_init_foreign_object")) - (define-class ()) (define-class () @@ -42,7 +39,7 @@ (let ((instance (next-method)) (finalizer (finalizer class))) (when finalizer - (%add-finalizer! instance finalizer)) + (add-finalizer! instance finalizer)) instance)) (define* (make-foreign-object-type name slots #:key finalizer