diff --git a/libguile/gc.c b/libguile/gc.c index 48944de73..04b0b5a56 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -40,13 +40,13 @@ #include "gen-scmconfig.h" #include "gsubr.h" #include "hashtab.h" -#include "hooks.h" #include "init.h" #include "list.h" #include "modules.h" #include "numbers.h" #include "pairs.h" #include "ports.h" +#include "procs.h" #include "simpos.h" #include "smob.h" #include "stackchk.h" @@ -106,8 +106,7 @@ scm_t_c_hook scm_before_sweep_c_hook; scm_t_c_hook scm_after_sweep_c_hook; scm_t_c_hook scm_after_gc_c_hook; -SCM scm_after_gc_hook; - +static SCM after_gc_thunks = SCM_EOL; static SCM after_gc_async_cell; /* This counter is decremented at each off-heap allocation. When it @@ -195,9 +194,7 @@ scm_gc_event_listener_restarting_mutators (void *data) /* If there are Scheme hooks and we have a current Guile thread, enqueue those to be run on the current thread. */ scm_thread *t = SCM_I_CURRENT_THREAD; - if (t && scm_initialized_p && - scm_is_false (SCM_CDR (after_gc_async_cell)) && - scm_is_false (scm_hook_empty_p (scm_after_gc_hook))) + if (t && !scm_is_null (after_gc_thunks)) { SCM_SETCDR (after_gc_async_cell, t->pending_asyncs); t->pending_asyncs = after_gc_async_cell; @@ -381,6 +378,32 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, #undef FUNC_NAME +SCM_DEFINE_STATIC (scm_add_after_gc_callback_x, "add-after-gc-callback!", + 1, 0, 0, (SCM thunk), + "Add @var{thunk} to the set of functions that will be " + "called after GC, by the thread that caused GC.") +#define FUNC_NAME s_scm_add_after_gc_callback_x +{ + SCM_VALIDATE_THUNK (1, thunk); + after_gc_thunks = scm_cons (thunk, after_gc_thunks); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE_STATIC (scm_remove_after_gc_callback_x, "remove-after-gc-callback!", + 1, 0, 0, (SCM thunk), + "Remove @var{thunk} from the set of functions that will be " + "called after GC.") +#define FUNC_NAME s_scm_remove_after_gc_callback_x +{ + SCM_VALIDATE_THUNK (1, thunk); + after_gc_thunks = scm_delq1_x (thunk, after_gc_thunks); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0, (void), "Dump information about the garbage collector's internal data " @@ -672,8 +695,8 @@ scm_gc_register_allocation (size_t size) static SCM after_gc_async_thunk (void) { - /* Fun, no? Hook-run *and* run-hook? */ - scm_c_run_hook (scm_after_gc_hook, SCM_EOL); + for (SCM ls = after_gc_thunks; !scm_is_null (ls); ls = scm_cdr (ls)) + scm_call_0 (scm_car (ls)); return SCM_UNSPECIFIED; } @@ -681,9 +704,6 @@ after_gc_async_thunk (void) void scm_init_gc () { - scm_after_gc_hook = scm_make_hook (SCM_INUM0); - scm_c_define ("after-gc-hook", scm_after_gc_hook); - /* When the async is to run, the cdr of the gc_async pair gets set to the asyncs queue of the current thread. */ after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0, diff --git a/libguile/gc.h b/libguile/gc.h index cd6d8ae2c..62505691b 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -88,8 +88,6 @@ typedef struct scm_t_cell SCM_API unsigned long scm_gc_ports_collected; -SCM_API SCM scm_after_gc_hook; - SCM_API scm_t_c_hook scm_before_gc_c_hook; SCM_API scm_t_c_hook scm_before_mark_c_hook; SCM_API scm_t_c_hook scm_before_sweep_c_hook; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 82522b57a..98c1df27e 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -174,8 +174,8 @@ signal_delivery_thread (void *data) block indefinitely waiting for a signal to arrive. For example it can happen that the garbage collector is triggered while marking the signal handler for future execution. Due to the - way the after-gc-hook is designed, without a call to - scm_async_tick, the after-gc-hook will not be triggered. */ + way the after-gc callback is designed, without a call to + scm_async_tick, the after-gc callback will not be triggered. */ scm_async_tick (); scm_without_guile (read_signal_pipe_data, &sigdata); diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm index 7a2a7f1de..2c384bf26 100644 --- a/module/ice-9/sandbox.scm +++ b/module/ice-9/sandbox.scm @@ -139,7 +139,7 @@ the allocation limit." (lambda () (dynamic-wind (lambda () - (add-hook! after-gc-hook check-allocation)) + (add-after-gc-callback! check-allocation)) (lambda () (call-with-stack-overflow-handler ;; The limit is in "words", which used to be 4 or 8 but now @@ -148,7 +148,7 @@ the allocation limit." thunk (lambda () (abort-to-prompt tag)))) (lambda () - (remove-hook! after-gc-hook check-allocation)))) + (remove-after-gc-callback! check-allocation)))) (lambda (k) (limit-reached))))) diff --git a/module/statprof.scm b/module/statprof.scm index e18be4842..ad740a835 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -1,7 +1,7 @@ ;;;; (statprof) -- a statistical profiler for Guile ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2013-2018, 2020 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2013-2018, 2020, 2025 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001 Rob Browning ;;;; @@ -888,14 +888,14 @@ times." (set-profile-level! state 1) (set-last-start-time! state (get-internal-run-time)) (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken)) - (add-hook! after-gc-hook gc-callback)) + (add-after-gc-callback! gc-callback)) (lambda () (let lp ((i loop)) (unless (zero? i) (call-thunk thunk) (lp (1- i))))) (lambda () - (remove-hook! after-gc-hook gc-callback) + (remove-after-gc-callback! gc-callback) (set-gc-time-taken! state (- (assq-ref (gc-stats) 'gc-time-taken) (gc-time-taken state))) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 380690733..34e0286f6 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -63,12 +63,12 @@ (with-test-prefix "gc" - (pass-if "after-gc-hook gets called" + (pass-if "after-gc callback gets called" (let* ((foo #f) (thunk (lambda () (set! foo #t)))) - (add-hook! after-gc-hook thunk) + (add-after-gc-callback! thunk) (gc) - (remove-hook! after-gc-hook thunk) + (remove-after-gc-callback! thunk) foo)) (pass-if "Unused modules are removed"