This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch wip-whippet
in repository guile.
The following commit(s) were added to refs/heads/wip-whippet by this push:
new 66f9815c3 Reimplement guardians in Scheme
66f9815c3 is described below
commit 66f9815c3f391f3f8deaf36b3311a636ccc0e8f5
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Sun May 4 20:41:16 2025 +0200
Reimplement guardians in Scheme
Also, shunt them off to a module, and deprecate the C interface.
* module/ice-9/guardians.scm: New file.
* am/bootstrap.am (SOURCES): Add new file.
* libguile.h: Remove guardians.h include.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES):
(DOT_DOC_FILES):
(modinclude_HEADERS): Remove guardians.[ch] files.
* libguile/init.c (scm_i_init_guile): Remove guardians.
* libguile/deprecated.h:
* libguile/deprecated.c (scm_make_guardian): Deprecate.
* module/ice-9/deprecated.scm: Add make-guardian shim.
* module/oop/goops.scm (<guardian>): Remove class; they no longer have a
tc16.
* module/ice-9/popen.scm: Add guardians module.
* test-suite/tests/eval.test:
* test-suite/tests/fluids.test:
* test-suite/tests/gc.test:
* test-suite/tests/guardians.test:
* test-suite/tests/threads.test:
* test-suite/tests/types.test: Use the guardians module.
---
am/bootstrap.am | 1 +
libguile.h | 3 +-
libguile/Makefile.am | 4 -
libguile/deprecated.c | 27 +++
libguile/deprecated.h | 1 +
libguile/finalizers.c | 1 -
libguile/guardians.c | 381 ----------------------------------------
libguile/guardians.h | 35 ----
libguile/init.c | 2 -
module/ice-9/deprecated.scm | 21 +--
module/ice-9/guardians.scm | 103 +++++++++++
module/ice-9/popen.scm | 3 +-
module/oop/goops.scm | 3 +-
test-suite/tests/eval.test | 3 +-
test-suite/tests/fluids.test | 3 +-
test-suite/tests/gc.test | 4 +-
test-suite/tests/guardians.test | 3 +-
test-suite/tests/threads.test | 3 +-
test-suite/tests/types.test | 3 +-
19 files changed, 156 insertions(+), 448 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 345b10ffc..66d91a165 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -147,6 +147,7 @@ SOURCES = \
ice-9/futures.scm \
ice-9/gap-buffer.scm \
ice-9/getopt-long.scm \
+ ice-9/guardians.scm \
ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/history.scm \
diff --git a/libguile.h b/libguile.h
index 6b76abe29..75554c0c1 100644
--- a/libguile.h
+++ b/libguile.h
@@ -1,7 +1,7 @@
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright 1995-1998,2000-2004,2006,2008-2014,2018,2020-2021
+/* Copyright 1995-1998,2000-2004,2006,2008-2014,2018,2020-2021,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -61,7 +61,6 @@ extern "C" {
#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
-#include "libguile/guardians.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index e8be11227..03e204941 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -173,7 +173,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =
\
generalized-vectors.c \
goops.c \
gsubr.c \
- guardians.c \
hash.c \
hashtab.c \
hooks.c \
@@ -292,7 +291,6 @@ DOT_X_FILES = \
generalized-vectors.x \
goops.x \
gsubr.x \
- guardians.x \
hash.x \
hashtab.x \
hooks.x \
@@ -397,7 +395,6 @@ DOT_DOC_FILES = \
generalized-vectors.doc \
goops.doc \
gsubr.doc \
- guardians.doc \
hash.doc \
hashtab.doc \
hooks.doc \
@@ -644,7 +641,6 @@ modinclude_HEADERS = \
generalized-vectors.h \
goops.h \
gsubr.h \
- guardians.h \
hash.h \
hashtab.h \
hooks.h \
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 7329e3b5e..c3ba0a9eb 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -23,6 +23,13 @@
#define SCM_BUILDING_DEPRECATED_CODE
+#include "deprecation.h"
+#include "eval.h"
+#include "gsubr.h"
+#include "modules.h"
+#include "threads.h"
+#include "variable.h"
+
#include "deprecated.h"
#if (SCM_ENABLE_DEPRECATED == 1)
@@ -30,6 +37,26 @@
/* Deprecated functions go here. */
+static SCM make_guardian_var;
+
+static void
+init_make_guardian_var (void)
+{
+ make_guardian_var = scm_c_public_lookup ("ice-9 guardians", "make-guardian");
+}
+
+SCM
+scm_make_guardian (void)
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_make_guardian_var);
+
+ scm_c_issue_deprecation_warning
+ ("The scm_make_guardian C interface is deprecated. Invoke the Scheme "
+ "make-guardian procedure from (ice-9 guardians) instead.");
+
+ return scm_call_0 (scm_variable_ref (make_guardian_var));
+}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index f1a76baa2..dbe2e4ce2 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -24,6 +24,7 @@
#if (SCM_ENABLE_DEPRECATED == 1)
+SCM_DEPRECATED SCM scm_make_guardian (void);
/* Deprecated declarations go here. */
void scm_i_init_deprecated (void);
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index 07335a970..44648fe13 100644
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@@ -39,7 +39,6 @@
#include "foreign.h"
#include "gc-internal.h"
#include "gsubr.h"
-#include "guardians.h"
#include "init.h"
#include "numbers.h"
#include "ports.h"
diff --git a/libguile/guardians.c b/libguile/guardians.c
deleted file mode 100644
index fa8c8b8f7..000000000
--- a/libguile/guardians.c
+++ /dev/null
@@ -1,381 +0,0 @@
-/* Copyright 1998-2001,2006,2008-2009,2011-2013,2018-2019
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile 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.
-
- Guile 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 Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-/* This is an implementation of guardians as described in
- * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
- * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
- * Programming Language Design and Implementation, June 1993
- * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
- *
- * Original design: Mikael Djurfeldt
- * Original implementation: Michael Livshin
- * Hacked on since by: everybody
- *
- * By this point, the semantics are actually quite different from
- * those described in the abovementioned paper. The semantic changes
- * are there to improve safety and intuitiveness. The interface is
- * still (mostly) the one described by the paper, however.
- *
- * Boiled down again: Marius Vollmer
- *
- * Now they should again behave like those described in the paper.
- * Scheme guardians should be simple and friendly, not like the greedy
- * monsters we had...
- *
- * Rewritten for the Boehm-Demers-Weiser GC by Ludovic Court�s.
- */
-
-/* Uncomment the following line to debug guardian finalization. */
-/* #define DEBUG_GUARDIANS 1 */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "bdw-gc.h"
-#include "boolean.h"
-#include "deprecation.h"
-#include "eval.h"
-#include "gsubr.h"
-#include "hashtab.h"
-#include "list.h"
-#include "numbers.h"
-#include "pairs.h"
-#include "ports.h"
-#include "print.h"
-#include "smob.h"
-#include "threads.h"
-#include "weak-vector.h"
-
-#include "guardians.h"
-
-
-static scm_t_bits tc16_guardian;
-
-typedef struct t_guardian
-{
- scm_i_pthread_mutex_t mutex;
- unsigned long live;
- SCM zombies;
- struct t_guardian *next;
-} t_guardian;
-
-#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
-#define GUARDIAN_DATA(x) ((t_guardian *) SCM_SMOB_DATA_1 (x))
-
-
-
-
-static int
-guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- t_guardian *g = GUARDIAN_DATA (guardian);
-
- scm_puts ("#<guardian ", port);
- scm_uintprint ((scm_t_bits) g, 16, port);
-
- scm_puts (" (reachable: ", port);
- scm_display (scm_from_ulong (g->live), port);
- scm_puts (" unreachable: ", port);
- scm_display (scm_length (g->zombies), port);
- scm_puts (")", port);
-
- scm_puts (">", port);
-
- return 1;
-}
-
-/* Handle finalization of OBJ which is guarded by the guardians listed in
- GUARDIAN_LIST. */
-static void
-finalize_guarded (void *ptr, void *finalizer_data)
-{
- SCM cell_pool;
- SCM obj, guardian_list, proxied_finalizer;
-
- obj = SCM_PACK_POINTER (ptr);
- guardian_list = SCM_CDR (SCM_PACK_POINTER (finalizer_data));
- proxied_finalizer = SCM_CAR (SCM_PACK_POINTER (finalizer_data));
-
-#ifdef DEBUG_GUARDIANS
- printf ("finalizing guarded %p (%u guardians)\n",
- ptr, scm_to_uint (scm_length (guardian_list)));
-#endif
-
- /* Preallocate a bunch of cells so that we can make sure that no garbage
- collection (and, thus, nested calls to `finalize_guarded ()') occurs
- while executing the following loop. This is quite inefficient (call to
- `scm_length ()') but that shouldn't be a problem in most cases. */
- cell_pool = scm_make_list (scm_length (guardian_list), SCM_UNSPECIFIED);
-
- /* Tell each guardian interested in OBJ that OBJ is no longer
- reachable. */
- for (;
- !scm_is_null (guardian_list);
- guardian_list = SCM_CDR (guardian_list))
- {
- SCM zombies;
- SCM guardian;
- t_guardian *g;
-
- guardian = scm_c_weak_vector_ref (scm_car (guardian_list), 0);
-
- if (scm_is_false (guardian))
- {
- /* The guardian itself vanished in the meantime. */
-#ifdef DEBUG_GUARDIANS
- printf (" guardian for %p vanished\n", ptr);
-#endif
- continue;
- }
-
- g = GUARDIAN_DATA (guardian);
-
- scm_i_pthread_mutex_lock (&g->mutex);
-
- if (g->live == 0)
- abort ();
-
- /* Get a fresh cell from CELL_POOL. */
- zombies = cell_pool;
- cell_pool = SCM_CDR (cell_pool);
-
- /* Compute and update G's zombie list. */
- SCM_SETCAR (zombies, obj);
- SCM_SETCDR (zombies, g->zombies);
- g->zombies = zombies;
-
- g->live--;
-
- scm_i_pthread_mutex_unlock (&g->mutex);
- }
-
- if (scm_is_true (proxied_finalizer))
- {
- /* Re-register the finalizer that was in place before we installed this
- one. */
- GC_finalization_proc finalizer, prev_finalizer;
- void *finalizer_data, *prev_finalizer_data;
-
- finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR
(proxied_finalizer));
- finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer));
-
- if (finalizer == NULL)
- abort ();
-
- GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data,
- &prev_finalizer, &prev_finalizer_data);
-
-#ifdef DEBUG_GUARDIANS
- printf (" reinstalled proxied finalizer %p for %p\n", finalizer, ptr);
-#endif
- }
-
-#ifdef DEBUG_GUARDIANS
- printf ("end of finalize (%p)\n", ptr);
-#endif
-}
-
-/* Add OBJ as a guarded object of GUARDIAN. */
-static void
-scm_i_guard (SCM guardian, SCM obj)
-{
- t_guardian *g = GUARDIAN_DATA (guardian);
-
- if (SCM_HEAP_OBJECT_P (obj))
- {
- /* Register a finalizer and pass a pair as the ``client data''
- argument. The pair contains in its car `#f' or a pair describing a
- ``proxied'' finalizer (see below); its cdr contains a list of
- guardians interested in OBJ.
-
- A ``proxied'' finalizer is a finalizer that was registered for OBJ
- before OBJ became guarded (e.g., a SMOB `free' function). We are
- assuming here that finalizers are only used internally, either at
- the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
- or by this function. */
- GC_finalization_proc prev_finalizer;
- void *prev_data;
- SCM guardians_for_obj, finalizer_data;
-
- scm_i_pthread_mutex_lock (&g->mutex);
-
- g->live++;
-
- /* Note: GUARDIANS_FOR_OBJ holds weak references to guardians so
- that a guardian can be collected before the objects it guards
- (see `guardians.test'). */
- guardians_for_obj = scm_cons (scm_make_weak_vector (SCM_INUM1, guardian),
- SCM_EOL);
- finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);
-
- GC_REGISTER_FINALIZER_NO_ORDER (SCM_UNPACK_POINTER (obj),
finalize_guarded,
- SCM_UNPACK_POINTER (finalizer_data),
- &prev_finalizer, &prev_data);
-
- if (prev_finalizer == finalize_guarded)
- {
- /* OBJ is already guarded by another guardian: add GUARDIAN to its
- list of guardians. */
- SCM prev_guardian_list, prev_finalizer_data;
-
- if (prev_data == NULL)
- abort ();
-
- prev_finalizer_data = SCM_PACK_POINTER (prev_data);
- if (!scm_is_pair (prev_finalizer_data))
- abort ();
-
- prev_guardian_list = SCM_CDR (prev_finalizer_data);
- SCM_SETCDR (guardians_for_obj, prev_guardian_list);
-
- /* Also copy information about proxied finalizers. */
- SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data));
- }
- else if (prev_finalizer != NULL)
- {
- /* There was already a finalizer registered for OBJ so we will
- ``proxy'' it, i.e., record it so that we can re-register it once
- `finalize_guarded ()' has finished. */
- SCM proxied_finalizer;
-
- proxied_finalizer = scm_cons (SCM_PACK_POINTER (prev_finalizer),
- SCM_PACK_POINTER (prev_data));
- SCM_SETCAR (finalizer_data, proxied_finalizer);
- }
-
- scm_i_pthread_mutex_unlock (&g->mutex);
- }
-}
-
-static SCM
-scm_i_get_one_zombie (SCM guardian)
-{
- t_guardian *g = GUARDIAN_DATA (guardian);
- SCM res = SCM_BOOL_F;
-
- scm_i_pthread_mutex_lock (&g->mutex);
-
- if (!scm_is_null (g->zombies))
- {
- /* Note: We return zombies in reverse order. */
- res = SCM_CAR (g->zombies);
- g->zombies = SCM_CDR (g->zombies);
- }
-
- scm_i_pthread_mutex_unlock (&g->mutex);
-
- return res;
-}
-
-/* This is the Scheme entry point for each guardian: If OBJ is an
- * object, it's added to the guardian's live list. If OBJ is unbound,
- * the next available unreachable object (or #f if none) is returned.
- *
- * If the second optional argument THROW_P is true (the default), then
- * an error is raised if GUARDIAN is greedy and OBJ is already greedily
- * guarded. If THROW_P is false, #f is returned instead of raising the
- * error, and #t is returned if everything is fine.
- */
-static SCM
-guardian_apply (SCM guardian, SCM obj, SCM throw_p)
-{
- if (!SCM_UNBNDP (obj))
- {
- scm_i_guard (guardian, obj);
- return SCM_UNSPECIFIED;
- }
- else
- return scm_i_get_one_zombie (guardian);
-}
-
-SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
- (),
-"Create a new guardian. A guardian protects a set of objects from\n"
-"garbage collection, allowing a program to apply cleanup or other\n"
-"actions.\n"
-"\n"
-"@code{make-guardian} returns a procedure representing the guardian.\n"
-"Calling the guardian procedure with an argument adds the argument to\n"
-"the guardian's set of protected objects. Calling the guardian\n"
-"procedure without an argument returns one of the protected objects\n"
-"which are ready for garbage collection, or @code{#f} if no such object\n"
-"is available. Objects which are returned in this way are removed from\n"
-"the guardian.\n"
-"\n"
-"You can put a single object into a guardian more than once and you can\n"
-"put a single object into more than one guardian. The object will then\n"
-"be returned multiple times by the guardian procedures.\n"
-"\n"
-"An object is eligible to be returned from a guardian when it is no\n"
-"longer referenced from outside any guardian.\n"
-"\n"
-"There is no guarantee about the order in which objects are returned\n"
-"from a guardian. If you want to impose an order on finalization\n"
-"actions, for example, you can do that by keeping objects alive in some\n"
-"global data structure until they are no longer needed for finalizing\n"
-"other objects.\n"
-"\n"
-"Being an element in a weak vector, a key in a hash table with weak\n"
-"keys, or a value in a hash table with weak value does not prevent an\n"
-"object from being returned by a guardian. But as long as an object\n"
-"can be returned from a guardian it will not be removed from such a\n"
-"weak vector or hash table. In other words, a weak link does not\n"
-"prevent an object from being considered collectable, but being inside\n"
-"a guardian prevents a weak link from being broken.\n"
-"\n"
-"A key in a weak key hash table can be though of as having a strong\n"
-"reference to its associated value as long as the key is accessible.\n"
-"Consequently, when the key only accessible from within a guardian, the\n"
-"reference from the key to the value is also considered to be coming\n"
-"from within a guardian. Thus, if there is no other reference to the\n"
- "value, it is eligible to be returned from a guardian.\n")
-#define FUNC_NAME s_scm_make_guardian
-{
- t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
- SCM z;
-
- scm_i_pthread_mutex_init (&g->mutex, NULL);
-
- /* A tconc starts out with one tail pair. */
- g->live = 0;
- g->zombies = SCM_EOL;
-
- g->next = NULL;
-
- SCM_NEWSMOB (z, tc16_guardian, g);
-
- return z;
-}
-#undef FUNC_NAME
-
-void
-scm_init_guardians ()
-{
- /* We use unordered finalization `a la Java. */
- GC_set_java_finalization (1);
-
- tc16_guardian = scm_make_smob_type ("guardian", 0);
-
- scm_set_smob_print (tc16_guardian, guardian_print);
- scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
-
-#include "guardians.x"
-}
diff --git a/libguile/guardians.h b/libguile/guardians.h
deleted file mode 100644
index 7a081bd5c..000000000
--- a/libguile/guardians.h
+++ /dev/null
@@ -1,35 +0,0 @@
-#ifndef SCM_GUARDIANS_H
-#define SCM_GUARDIANS_H
-
-/* Copyright 1998,2000-2001,2006,2008,2018
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile 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.
-
- Guile 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 Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-
-#include "libguile/scm.h"
-
-SCM_API SCM scm_make_guardian (void);
-
-SCM_INTERNAL void scm_i_init_guardians_for_gc (void);
-SCM_INTERNAL void scm_i_identify_inaccessible_guardeds (void);
-SCM_INTERNAL int scm_i_mark_inaccessible_guardeds (void);
-
-SCM_INTERNAL void scm_init_guardians (void);
-
-#endif /* SCM_GUARDIANS_H */
diff --git a/libguile/init.c b/libguile/init.c
index 32ff25cc6..592024d01 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -80,7 +80,6 @@
#include "gettext.h"
#include "goops.h"
#include "gsubr.h"
-#include "guardians.h"
#include "hash.h"
#include "hashtab.h"
#include "hooks.h"
@@ -460,7 +459,6 @@ scm_i_init_guile (struct gc_stack_addr base)
scm_init_weak_set ();
scm_init_weak_table ();
scm_init_weak_vectors ();
- scm_init_guardians (); /* requires smob_prehistory */
scm_init_standard_ports (); /* Requires fports */
scm_init_expand (); /* Requires structs */
scm_init_memoize (); /* Requires smob_prehistory */
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 4c4a484ca..4d87e8fb3 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2017, 2020 Free Software Foundation, Inc.
+;;;; 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
@@ -16,9 +16,10 @@
;;;;
(define-module (ice-9 deprecated)
- #:use-module (ice-9 copy-tree)
- #:export ((copy-tree* . copy-tree)))
+ #:use-module (ice-9 guardians)
+ #:export ((make-guardian* . make-guardian)))
+#;
(define-syntax-rule (define-deprecated name message exp)
(begin
(define-syntax rule
@@ -28,14 +29,8 @@
exp)))
(export rule)))
-(define %allow-legacy-syntax-objects? (make-parameter #f))
-(define-deprecated allow-legacy-syntax-objects?
- "allow-legacy-syntax-objects? is deprecated and has no effect. Guile
-3.0 has no legacy syntax objects."
- %allow-legacy-syntax-objects?)
-
-(define (copy-tree* x)
+(define (make-guardian*)
(issue-deprecation-warning
- "copy-tree in the default environment is deprecated. Import it
-from (ice-9 copy-tree) instead.")
- (copy-tree x))
+ "make-guardian in the default environment is deprecated. Import it
+from (ice-9 guardians) instead.")
+ (make-guardian))
diff --git a/module/ice-9/guardians.scm b/module/ice-9/guardians.scm
new file mode 100644
index 000000000..2531c6e8f
--- /dev/null
+++ b/module/ice-9/guardians.scm
@@ -0,0 +1,103 @@
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This is an implementation of guardians as described in:
+;;;
+;;; R. Kent Dybvig, Carl Bruggeman, and David Eby. "Guardians in a
+;;; Generation-Based Garbage Collector." PLDI 1993.
+;;; https://dl.acm.org/doi/abs/10.1145/173262.155110
+;;;
+;;; Our implementation is terms of Whippet's multi-priority finalizers:
+;;;
https://wingolog.org/archives/2024/07/22/finalizers-guardians-phantom-references-et-cetera
+;;;
+;;; Specifically, all guardian finalizers will run before any "normal"
+;;; finalizer runs, so guarded objects that are returned to Scheme
+;;; aren't finalized yet.
+;;;
+;;; Code:
+
+
+(define-module (ice-9 guardians)
+ #:use-module (srfi srfi-9)
+ #:use-module (system finalizers)
+ #:use-module (ice-9 atomic)
+ #:use-module (ice-9 match)
+ #:replace (make-guardian))
+
+(define (immediate? x)
+ (cond
+ ((exact-integer? x) (<= most-negative-fixnum x most-positive-fixnum))
+ ((char? x) #t)
+ ((eq? x #f) #t)
+ ((eq? x #nil) #t)
+ ((eq? x '()) #t)
+ ((eq? x #t) #t)
+ ((unspecified? x) #t)
+ ((eof-object? x) #t)
+ (else #f)))
+
+(define (heap-object? x)
+ (not (immediate? x)))
+
+(define (make-atomic-fifo)
+ (define inbox (make-atomic-box '()))
+ (define outbox (make-atomic-box '()))
+ (define (push! x)
+ (let lp ((in (atomic-box-ref inbox)))
+ (let ((prev (atomic-box-compare-and-swap! inbox in (cons x in))))
+ (if (eq? prev in)
+ (values)
+ (lp prev)))))
+ (define (transfer! in out)
+ (match in
+ (() (values))
+ ((x . in*)
+ (let* ((out* (cons x out))
+ (out** (atomic-box-compare-and-swap! outbox out out*)))
+ (if (eq? out out**)
+ (transfer! in* out*)
+ (transfer! in out**))))))
+ (define (pop!)
+ (let lp ((out (atomic-box-ref outbox)))
+ (match out
+ ((head . tail)
+ (let ((prev (atomic-box-compare-and-swap! outbox out tail)))
+ (if (eq? prev out)
+ head
+ (lp prev))))
+ (()
+ (match (atomic-box-swap! inbox '())
+ (() #f)
+ (in
+ (transfer! in '())
+ (pop!)))))))
+ (values push! pop!))
+
+(define (make-guardian)
+ (define-values (push! pop!) (make-atomic-fifo))
+ (define (guard! obj)
+ (when (heap-object? obj)
+ (add-finalizer! obj push!)))
+ (define guardian
+ (case-lambda
+ (()
+ (pop!))
+ ((obj)
+ (guard! obj)
+ (values))))
+ guardian)
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 957cde0aa..befa528ab 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -1,6 +1,6 @@
;; popen emulation, for non-stdio based ports.
-;;;; Copyright (C) 1998-2001, 2003, 2006, 2010-2013, 2019
+;;;; Copyright (C) 1998-2001, 2003, 2006, 2010-2013, 2019, 2025
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -20,6 +20,7 @@
(define-module (ice-9 popen)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 guardians)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 1d05225e9..caa4bc3fe 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -85,7 +85,7 @@
<promise> <mutex> <condition-variable>
<regexp> <hook> <random-state>
<directory> <array> <character-set>
- <dynamic-object> <guardian> <macro>
+ <dynamic-object> <macro>
;; Modules.
<module>
@@ -3537,7 +3537,6 @@ var{initargs}."
(define <directory> (find-subclass <top> '<directory>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
-(define <guardian> (find-subclass <applicable> '<guardian>))
(define <macro> (find-subclass <top> '<macro>))
;; <dynamic-object> used to be a SMOB type, albeit not exported even to
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 5bd2ac21a..968c78d12 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000-2001,2003-2015,2017,2019,2020
+;;;; Copyright (C) 2000-2001,2003-2015,2017,2019,2020,2025
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -23,6 +23,7 @@
:use-module ((system vm frame) :select (frame-call-representation))
:use-module (ice-9 documentation)
:use-module (ice-9 exceptions)
+ :use-module (ice-9 guardians)
:use-module (ice-9 local-eval))
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 5026c2f30..9269c48bd 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; fluids.test --- test suite for fluid values
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 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
@@ -18,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-fluids)
+ #:use-module (ice-9 guardians)
#:use-module (ice-9 threads)
#:use-module (test-suite lib)
#:use-module (system base compile))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 1827599a4..ab710f28d 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,6 +1,6 @@
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
-;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013, 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
@@ -18,6 +18,7 @@
(define-module (tests gc)
#:use-module (ice-9 documentation)
+ #:use-module (ice-9 guardians)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)))
@@ -93,6 +94,7 @@
(pass-if "Lexical vars are collectable"
(let ((l (compile
'(begin
+ (use-modules (ice-9 guardians))
(define guardian (make-guardian))
(let ((f (list 'foo)))
(guardian f))
diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test
index fc4c9d861..002f3829d 100644
--- a/test-suite/tests/guardians.test
+++ b/test-suite/tests/guardians.test
@@ -1,7 +1,7 @@
;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*-
;;;; Jim Blandy <j...@red-bean.com> --- July 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2006, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2014, 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
@@ -37,6 +37,7 @@
(define-module (test-guardians)
:use-module (test-suite lib)
:use-module (ice-9 documentation)
+ :use-module (ice-9 guardians)
:use-module (ice-9 weak-vector))
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index fa89deeb2..d0a7412b2 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,7 +1,7 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
-;;;; 2014 Free Software Foundation, Inc.
+;;;; 2014, 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
@@ -18,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-threads)
+ #:use-module (ice-9 guardians)
#:use-module (ice-9 threads)
#:use-module (system base compile)
#:use-module (test-suite lib))
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
index 9a9cdf73d..03dbea83a 100644
--- a/test-suite/tests/types.test
+++ b/test-suite/tests/types.test
@@ -1,6 +1,6 @@
;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2014, 2015, 2018, 2025 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
@@ -97,7 +97,6 @@
(with-test-prefix "opaque objects"
(test-inferior-objects
- ((make-guardian) smob (? integer?))
((%make-void-port "w") port (? inferior-object?))
((open-input-string "hello") port (? inferior-object?))
((lambda () #t) program _)
