summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile.h1
-rw-r--r--libguile/Makefile.am12
-rw-r--r--libguile/ephemerons.c12
-rw-r--r--libguile/ephemerons.h4
-rw-r--r--libguile/evalext.c1
-rw-r--r--libguile/hash.c1
-rw-r--r--libguile/init.c2
-rw-r--r--libguile/ioext.c33
-rw-r--r--libguile/ports-internal.h9
-rw-r--r--libguile/ports.c57
-rw-r--r--libguile/ports.h5
-rw-r--r--libguile/print.c4
-rw-r--r--libguile/scm.h2
-rw-r--r--libguile/symbols.c254
-rw-r--r--libguile/weak-set.c873
-rw-r--r--libguile/weak-set.h62
-rw-r--r--module/ice-9/guardians.scm2
-rw-r--r--module/language/cps/compile-bytecode.scm1
-rw-r--r--module/system/base/types.scm2
-rw-r--r--module/system/base/types/internal.scm3
-rw-r--r--module/system/vm/assembler.scm1
21 files changed, 194 insertions, 1147 deletions
diff --git a/libguile.h b/libguile.h
index 9bcc32402..b5594a4d8 100644
--- a/libguile.h
+++ b/libguile.h
@@ -113,7 +113,6 @@ extern "C" {
#include "libguile/version.h"
#include "libguile/vm.h"
#include "libguile/vports.h"
-#include "libguile/weak-set.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stacks.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 68bda9160..403444f64 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -236,8 +236,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
vectors.c \
version.c \
vm.c \
- vports.c \
- weak-set.c
+ vports.c
if ENABLE_JIT
libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES += $(lightening_c_files)
@@ -345,8 +344,7 @@ DOT_X_FILES = \
variable.x \
vectors.x \
version.x \
- vm.x \
- weak-set.x
+ vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
@@ -442,8 +440,7 @@ DOT_DOC_FILES = \
variable.doc \
vectors.doc \
version.doc \
- vports.doc \
- weak-set.doc
+ vports.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
@@ -702,8 +699,7 @@ modinclude_HEADERS = \
vm-builtins.h \
vm-expand.h \
vm.h \
- vports.h \
- weak-set.h
+ vports.h
nodist_modinclude_HEADERS = version.h scmconfig.h
diff --git a/libguile/ephemerons.c b/libguile/ephemerons.c
index 9995d8e79..f8b7ecf54 100644
--- a/libguile/ephemerons.c
+++ b/libguile/ephemerons.c
@@ -126,6 +126,18 @@ scm_c_ephemeron_next (struct gc_ephemeron *e)
return gc_ephemeron_chain_next (e);
}
+struct gc_ephemeron*
+scm_c_ephemeron_load (struct gc_ephemeron **loc)
+{
+ return gc_ephemeron_chain_head (loc);
+}
+
+void
+scm_c_ephemeron_push (struct gc_ephemeron **loc, struct gc_ephemeron *e)
+{
+ gc_ephemeron_chain_push (loc, e);
+}
+
diff --git a/libguile/ephemerons.h b/libguile/ephemerons.h
index d1eb9e548..9f1fb8eb5 100644
--- a/libguile/ephemerons.h
+++ b/libguile/ephemerons.h
@@ -39,6 +39,10 @@ SCM_INTERNAL int scm_i_print_ephemeron (SCM exp, SCM port,
SCM_INTERNAL struct gc_ephemeron* scm_to_ephemeron (SCM e);
SCM_INTERNAL SCM scm_from_ephemeron (struct gc_ephemeron *e);
+SCM_INTERNAL struct gc_ephemeron* scm_c_ephemeron_load (struct gc_ephemeron **loc);
+SCM_INTERNAL void scm_c_ephemeron_push (struct gc_ephemeron **loc,
+ struct gc_ephemeron *e);
+
SCM_INTERNAL struct scm_ephemeron_table* scm_c_make_ephemeron_table (size_t count);
SCM_INTERNAL size_t scm_c_ephemeron_table_length (struct scm_ephemeron_table *et);
SCM_INTERNAL struct gc_ephemeron*
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 07c9a0239..a816623f8 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -79,7 +79,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_vector:
case scm_tc7_pointer:
case scm_tc7_hashtable:
- case scm_tc7_weak_set:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
diff --git a/libguile/hash.c b/libguile/hash.c
index b30d7750e..17e978c6e 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -346,7 +346,6 @@ scm_raw_ihash (SCM obj, size_t depth)
case scm_tc7_atomic_box:
case scm_tc7_program:
case scm_tc7_vm_cont:
- case scm_tc7_weak_set:
case scm_tc7_port:
return scm_raw_ihashq (SCM_UNPACK (obj));
diff --git a/libguile/init.c b/libguile/init.c
index 7348a9916..7a00024a3 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -145,7 +145,6 @@
#include "vectors.h"
#include "version.h"
#include "vm.h"
-#include "weak-set.h"
#include "init.h"
@@ -451,7 +450,6 @@ scm_i_init_guile (struct gc_stack_addr base)
scm_init_exceptions ();
scm_init_throw (); /* Requires smob_prehistory */
scm_init_version ();
- scm_init_weak_set ();
scm_init_standard_ports (); /* Requires fports */
scm_init_expand (); /* Requires structs */
scm_init_memoize (); /* Requires smob_prehistory */
diff --git a/libguile/ioext.c b/libguile/ioext.c
index 8f5691184..9a057c812 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2001,2003,2006,2011,2014,2018
+/* Copyright 1995-2001,2003,2006,2011,2014,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -47,7 +47,6 @@
#include "ports.h"
#include "strings.h"
#include "syscalls.h"
-#include "weak-set.h"
#include "version.h"
#include "ioext.h"
@@ -282,15 +281,19 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
}
#undef FUNC_NAME
-static SCM
-get_matching_port (void *closure, SCM port, SCM result)
+struct scm_fdes_to_ports_data
{
- int fd = * (int *) closure;
-
- if (SCM_OPFPORTP (port) && SCM_FSTREAM (port)->fdes == fd)
- result = scm_cons (port, result);
+ SCM ports;
+ int fd;
+};
- return result;
+static void
+collect_matching_ports (void *closure, SCM port)
+{
+ struct scm_fdes_to_ports_data *data = closure;
+
+ if (SCM_OPFPORTP (port) && SCM_FSTREAM (port)->fdes == data->fd)
+ data->ports = scm_cons (port, data->ports);
}
/* Return a list of ports using a given file descriptor. */
@@ -301,13 +304,13 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
"counts.")
#define FUNC_NAME s_scm_fdes_to_ports
{
- SCM result = SCM_EOL;
- int int_fd = scm_to_int (fd);
+ struct scm_fdes_to_ports_data data;
+ data.ports = SCM_EOL;
+ data.fd = scm_to_int (fd);
+
+ scm_c_port_for_each (collect_matching_ports, &data);
- result = scm_c_weak_set_fold (get_matching_port,
- (void*) &int_fd, result,
- scm_i_port_weak_set);
- return result;
+ return data.ports;
}
#undef FUNC_NAME
diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h
index 4e0a72f95..8433c5903 100644
--- a/libguile/ports-internal.h
+++ b/libguile/ports-internal.h
@@ -1,6 +1,6 @@
/* ports-internal.h - internal-only declarations for ports.
- Copyright 2013,2018
+ Copyright 2013,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -27,6 +27,7 @@
#include <string.h>
#include "libguile/bytevectors.h"
+#include "libguile/ephemerons.h"
#include "libguile/list.h"
#include "libguile/pairs.h"
#include "libguile/ports.h"
@@ -361,6 +362,12 @@ struct scm_t_port
iconv_t input_cd; /* with iconv_lock */
iconv_t output_cd; /* with iconv_lock */
+ /* If the port needs to be closed when it becomes unreachable, it is
+ put on a global ephemeron chain, so that we can explicitly flush
+ all ports. If the port is later closed manually, we can mark that
+ chain link as dead, and it will be collected on the next GC. */
+ struct gc_ephemeron *close_handle;
+
/* Port properties. */
SCM alist;
};
diff --git a/libguile/ports.c b/libguile/ports.c
index e979edada..83634eccc 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -78,7 +78,6 @@
#include "variable.h"
#include "vectors.h"
#include "version.h"
-#include "weak-set.h"
#include "ports.h"
@@ -159,6 +158,13 @@ release_port (SCM port)
if (cur > 1)
return;
+ struct gc_ephemeron *e = pt->close_handle;
+ if (e)
+ {
+ pt->close_handle = NULL;
+ scm_c_ephemeron_mark_dead_x (e);
+ }
+
/* FIXME: `catch' around the close call? It could throw an exception,
and in that case we'd leak the iconv descriptors, if any. */
if (SCM_PORT_TYPE (port)->close)
@@ -701,11 +707,24 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
-/* The port table --- a weak set of all ports.
+/* The port list --- a weak list of all ports.
We need a global registry of ports to flush them all at exit, and to
get all the ports matching a file descriptor. */
-SCM scm_i_port_weak_set;
+static struct gc_ephemeron *all_ports_needing_close = NULL;
+
+static void
+for_each_port_needing_close (void (*proc)(void *data, SCM p), void *data)
+{
+ for (struct gc_ephemeron *e = scm_c_ephemeron_load (&all_ports_needing_close);
+ e;
+ e = scm_c_ephemeron_next (e))
+ {
+ SCM port = scm_c_ephemeron_key (e);
+ if (!scm_is_false (port))
+ proc (data, port);
+ }
+}
@@ -798,7 +817,8 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits,
if (SCM_PORT_TYPE (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
{
scm_i_add_port_finalizer (SCM_I_CURRENT_THREAD, ret);
- scm_weak_set_add_x (scm_i_port_weak_set, ret);
+ pt->close_handle = scm_c_make_ephemeron (ret, SCM_BOOL_T);
+ scm_c_ephemeron_push (&all_ports_needing_close, pt->close_handle);
}
initialize_port_buffers (ret);
@@ -901,9 +921,6 @@ close_port (SCM port, int explicit)
SCM_CLR_PORT_OPEN_FLAG (port);
- if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
- scm_weak_set_remove_x (scm_i_port_weak_set, port);
-
release_port (port);
return SCM_BOOL_T;
@@ -4059,32 +4076,10 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
/* Iterating over all ports. */
-struct for_each_data
-{
- void (*proc) (void *data, SCM p);
- void *data;
-};
-
-static SCM
-for_each_trampoline (void *data, SCM port, SCM result)
-{
- struct for_each_data *d = data;
-
- d->proc (d->data, port);
-
- return result;
-}
-
void
scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
{
- struct for_each_data d;
-
- d.proc = proc;
- d.data = data;
-
- scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
- scm_i_port_weak_set);
+ for_each_port_needing_close (proc, data);
}
static void
@@ -4230,8 +4225,6 @@ scm_init_ports (void)
scm_void_port_type = scm_make_port_type ("void", void_port_read,
void_port_write);
- scm_i_port_weak_set = scm_c_make_weak_set (31);
-
cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid ();
diff --git a/libguile/ports.h b/libguile/ports.h
index 055e5b6b9..362236310 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -29,11 +29,6 @@
-SCM_INTERNAL SCM scm_i_port_weak_set;
-
-
-
-
#define SCM_EOF_OBJECT_P(x) (scm_is_eq ((x), SCM_EOF_VAL))
/* A port's first word contains its tag, which is a tc7 value. Above
diff --git a/libguile/print.c b/libguile/print.c
index 98150ff8c..ab4abb8d9 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -68,7 +68,6 @@
#include "variable.h"
#include "vectors.h"
#include "vm.h"
-#include "weak-set.h"
#include "print.h"
@@ -721,9 +720,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
- case scm_tc7_weak_set:
- scm_i_weak_set_print (exp, port, pstate);
- break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
diff --git a/libguile/scm.h b/libguile/scm.h
index fde767174..2f657f0e1 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -494,7 +494,7 @@ typedef uintptr_t scm_t_bits;
#define scm_tc7_vm_cont 0x47
#define scm_tc7_bytevector 0x4d
#define scm_tc7_thread 0x4f
-#define scm_tc7_weak_set 0x55
+#define scm_tc7_unused_55 0x55
#define scm_tc7_unused_57 0x57
#define scm_tc7_array 0x5d
#define scm_tc7_bitvector 0x5f
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 292941e9d..1cec76f26 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009,2011,2013,2015,2018,2022,2023
+/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009,2011,2013,2015,2018,2022,2023,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -29,6 +29,7 @@
#include "alist.h"
#include "boolean.h"
#include "chars.h"
+#include "ephemerons.h"
#include "eval.h"
#include "fluids.h"
#include "gsubr.h"
@@ -46,14 +47,13 @@
#include "threads.h"
#include "variable.h"
#include "vectors.h"
-#include "weak-set.h"
#include "symbols.h"
-static SCM symbols;
+static struct scm_ephemeron_table *symbols;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
@@ -61,7 +61,7 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
"Return the system symbol obarray.")
#define FUNC_NAME s_scm_sys_symbols
{
- return symbols;
+ return scm_from_ephemeron_table (symbols);
}
#undef FUNC_NAME
#endif
@@ -77,187 +77,171 @@ scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
return scm_i_symbol_hash (obj) % n;
}
-struct string_lookup_data
-{
- SCM string;
- unsigned long string_hash;
-};
-
static int
-string_lookup_predicate_fn (SCM sym, void *closure)
+symbol_equals_string (SCM sym, SCM str, size_t len, unsigned long hash)
{
- struct string_lookup_data *data = closure;
-
- if (scm_i_symbol_hash (sym) == data->string_hash
- && scm_i_symbol_length (sym) == scm_i_string_length (data->string))
- {
- size_t n = scm_i_symbol_length (sym);
- while (n--)
- if (scm_i_symbol_ref (sym, n) != scm_i_string_ref (data->string, n))
- return 0;
- return 1;
- }
- else
+ if (scm_i_symbol_hash (sym) != hash)
+ return 0;
+ if (scm_i_symbol_length (sym) != len)
return 0;
-}
-
-static SCM
-lookup_interned_symbol (SCM name, unsigned long raw_hash)
-{
- struct string_lookup_data data;
-
- data.string = name;
- data.string_hash = raw_hash;
- return scm_c_weak_set_lookup (symbols, raw_hash,
- string_lookup_predicate_fn,
- &data, SCM_BOOL_F);
-}
+ for (size_t i = 0; i < len; i++)
+ if (scm_i_symbol_ref (sym, i) != scm_i_string_ref (str, i))
+ return 0;
-struct latin1_lookup_data
-{
- const char *str;
- size_t len;
- unsigned long string_hash;
-};
+ return 1;
+}
static int
-latin1_lookup_predicate_fn (SCM sym, void *closure)
+symbol_equals_latin1_string (SCM sym, const char *str, size_t len,
+ unsigned long hash)
{
- struct latin1_lookup_data *data = closure;
-
- return scm_i_symbol_hash (sym) == data->string_hash
- && scm_i_is_narrow_symbol (sym)
- && scm_i_symbol_length (sym) == data->len
- && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0;
+ if (scm_i_symbol_hash (sym) != hash)
+ return 0;
+ if (scm_i_symbol_length (sym) != len)
+ return 0;
+ if (!scm_i_is_narrow_symbol (sym))
+ return 0;
+
+ return strncmp (scm_i_symbol_chars (sym), str, len) == 0;
}
static SCM
lookup_interned_latin1_symbol (const char *str, size_t len,
unsigned long raw_hash)
{
- struct latin1_lookup_data data;
-
- data.str = str;
- data.len = len;
- data.string_hash = raw_hash;
-
- return scm_c_weak_set_lookup (symbols, raw_hash,
- latin1_lookup_predicate_fn,
- &data, SCM_BOOL_F);
+ size_t bucket = raw_hash % scm_c_ephemeron_table_length (symbols);
+ for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (symbols, bucket);
+ e;
+ e = scm_c_ephemeron_next (e))
+ {
+ SCM sym = scm_c_ephemeron_key (e);
+ if (scm_is_true (sym)
+ && symbol_equals_latin1_string (sym, str, len, raw_hash))
+ return sym;
+ }
+ return SCM_BOOL_F;
}
-struct utf8_lookup_data
+static int
+utf8_string_equals_narrow_string (const uint8_t *utf8, size_t ulen,
+ const char *narrow)
{
- const char *str;
- size_t len;
- unsigned long string_hash;
-};
+ /* Precondition: utf8,ulen is valid UTF-8. */
+ size_t byte_idx = 0;
+
+ while (byte_idx < ulen)
+ {
+ ucs4_t c = -1;
+ byte_idx += u8_mbtoucr (&c, utf8 + byte_idx, ulen - byte_idx);
+ if (c != *narrow)
+ return 0;
+ narrow++;
+ }
+
+ return 1;
+}
static int
-utf8_string_equals_wide_string (const uint8_t *narrow, size_t nlen,
- const scm_t_wchar *wide, size_t wlen)
+utf8_string_equals_wide_string (const uint8_t *utf8, size_t ulen,
+ const scm_t_wchar *wide)
{
- size_t byte_idx = 0, char_idx = 0;
+ /* Precondition: utf8,ulen is valid UTF-8. */
+ size_t byte_idx = 0;
- while (byte_idx < nlen && char_idx < wlen)
+ while (byte_idx < ulen)
{
- ucs4_t c;
- int nbytes;
-
- nbytes = u8_mbtoucr (&c, narrow + byte_idx, nlen - byte_idx);
- if (nbytes == 0)
- break;
- else if (nbytes < 0)
- /* Bad UTF-8. */
- return 0;
- else if (c != wide[char_idx])
+ ucs4_t c = -1;
+ byte_idx += u8_mbtoucr (&c, utf8 + byte_idx, ulen - byte_idx);
+ if (c != *wide)
return 0;
-
- byte_idx += nbytes;
- char_idx++;
+ wide++;
}
- return byte_idx == nlen && char_idx == wlen;
+ return 1;
}
static int
-utf8_lookup_predicate_fn (SCM sym, void *closure)
+symbol_equals_utf8_string (SCM sym, const uint8_t *str, size_t len,
+ unsigned long hash, int codepoint_count)
{
- struct utf8_lookup_data *data = closure;
-
- if (scm_i_symbol_hash (sym) != data->string_hash)
+ if (scm_i_symbol_hash (sym) != hash)
+ return 0;
+ if (scm_i_symbol_length (sym) != codepoint_count)
return 0;
if (scm_i_is_narrow_symbol (sym))
- return (scm_i_symbol_length (sym) == data->len
- && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0);
+ return utf8_string_equals_narrow_string (str, len,
+ scm_i_symbol_chars (sym));
else
- return utf8_string_equals_wide_string ((const uint8_t *) data->str,
- data->len,
- scm_i_symbol_wide_chars (sym),
- scm_i_symbol_length (sym));
+ return utf8_string_equals_wide_string (str, len,
+ scm_i_symbol_wide_chars (sym));
}
static SCM
-lookup_interned_utf8_symbol (const char *str, size_t len,
+lookup_interned_utf8_symbol (const uint8_t *str, size_t len,
unsigned long raw_hash)
{
- struct utf8_lookup_data data;
-
- data.str = str;
- data.len = len;
- data.string_hash = raw_hash;
-
- return scm_c_weak_set_lookup (symbols, raw_hash,
- utf8_lookup_predicate_fn,
- &data, SCM_BOOL_F);
-}
+ int codepoint_count = u8_mbsnlen (str, len);
+ if (codepoint_count == -1)
+ /* Bad UTF-8. */
+ return SCM_BOOL_F;
-static int
-symbol_lookup_predicate_fn (SCM sym, void *closure)
-{
- SCM other = SCM_PACK_POINTER (closure);
+ if (codepoint_count == len)
+ return lookup_interned_latin1_symbol ((const char *) str, len, raw_hash);
- if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (other)
- && scm_i_symbol_length (sym) == scm_i_symbol_length (other))
+ size_t bucket = raw_hash % scm_c_ephemeron_table_length (symbols);
+ for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (symbols, bucket);
+ e;
+ e = scm_c_ephemeron_next (e))
{
- if (scm_i_is_narrow_symbol (sym))
- return scm_i_is_narrow_symbol (other)
- && (strncmp (scm_i_symbol_chars (sym),
- scm_i_symbol_chars (other),
- scm_i_symbol_length (other)) == 0);
- else
- return scm_is_true
- (scm_string_equal_p (scm_symbol_to_string (sym),
- scm_symbol_to_string (other)));
+ SCM sym = scm_c_ephemeron_key (e);
+ if (scm_is_true (sym)
+ && symbol_equals_utf8_string (sym, str, len, raw_hash,
+ codepoint_count))
+ return sym;
}
- return 0;
+ return SCM_BOOL_F;
}
-
+
static SCM
scm_i_str2symbol (SCM str)
{
- SCM symbol;
unsigned long raw_hash = scm_i_string_hash (str);
+ size_t bucket = raw_hash % scm_c_ephemeron_table_length (symbols);
+ size_t len = scm_i_string_length (str);
- symbol = lookup_interned_symbol (str, raw_hash);
- if (scm_is_true (symbol))
- return symbol;
- else
+ struct gc_ephemeron *chain = scm_c_ephemeron_table_ref (symbols, bucket);
+ /* First see if a symbol with this name is already interned. */
+ for (struct gc_ephemeron *e = chain; e; e = scm_c_ephemeron_next (e))
{
- /* The symbol was not found, create it. */
- symbol = scm_i_make_symbol (str, 0, raw_hash);
-
- /* Might return a different symbol, if another one was interned at
- the same time. */
- return scm_c_weak_set_add_x (symbols, raw_hash,
- symbol_lookup_predicate_fn,
- SCM_UNPACK_POINTER (symbol), symbol);
+ SCM sym = scm_c_ephemeron_key (e);
+ if (scm_is_true (sym) && symbol_equals_string (sym, str, len, raw_hash))
+ return sym;
+ }
+
+ /* The symbol was not found, create it. */
+ SCM sym = scm_i_make_symbol (str, 0, raw_hash);
+ struct gc_ephemeron *link = scm_c_make_ephemeron (sym, SCM_BOOL_T);
+ while (1)
+ {
+ struct gc_ephemeron *prev =
+ scm_c_ephemeron_table_try_push_x (symbols, bucket, link, chain);
+ if (prev == chain)
+ return sym;
+ /* Lost a race, someone else added a symbol in this bucket. Check
+ the chain and try again. */
+ chain = prev;
+ for (struct gc_ephemeron *e = chain; e; e = scm_c_ephemeron_next (e))
+ {
+ SCM sym = scm_c_ephemeron_key (e);
+ if (scm_is_true (sym)
+ && symbol_equals_string (sym, str, len, raw_hash))
+ return sym;
+ }
}
}
-
static SCM
scm_i_str2uninterned_symbol (SCM str)
{
@@ -449,7 +433,7 @@ scm_from_utf8_symboln (const char *sym, size_t len)
len = strlen (sym);
hash = scm_i_utf8_string_hash (sym, len);
- ret = lookup_interned_utf8_symbol (sym, len, hash);
+ ret = lookup_interned_utf8_symbol ((const uint8_t *)sym, len, hash);
if (scm_is_false (ret))
{
SCM str = scm_from_utf8_stringn (sym, len);
@@ -462,7 +446,7 @@ scm_from_utf8_symboln (const char *sym, size_t len)
void
scm_symbols_prehistory ()
{
- symbols = scm_c_make_weak_set (5000);
+ symbols = scm_c_make_ephemeron_table (5000);
}
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
deleted file mode 100644
index ef6a5231d..000000000
--- a/libguile/weak-set.c
+++ /dev/null
@@ -1,873 +0,0 @@
-/* Copyright 2011-2013,2018,2025
- 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/>. */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <assert.h>
-#include <string.h>
-
-#include "bdw-gc.h"
-#include "eval.h"
-#include "finalizers.h"
-#include "hash.h"
-#include "pairs.h"
-#include "ports.h"
-#include "threads.h"
-#include "weak-set.h"
-
-
-/* Weak Sets
-
- This file implements weak sets. One example of a weak set is the
- symbol table, where you want all instances of the `foo' symbol to map
- to one object. So when you load a file and it wants a symbol with
- the characters "foo", you one up in the table, using custom hash and
- equality predicates. Only if one is not found will you bother to
- cons one up and intern it.
-
- Another use case for weak sets is the set of open ports. Guile needs
- to be able to flush them all when the process exits, but the set
- shouldn't prevent the GC from collecting the port (and thus closing
- it).
-
- Weak sets are implemented using an open-addressed hash table.
- Basically this means that there is an array of entries, and the item
- is expected to be found the slot corresponding to its hash code,
- modulo the length of the array.
-
- Collisions are handled using linear probing with the Robin Hood
- technique. See Pedro Celis' paper, "Robin Hood Hashing":
-
- http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
-
- The vector of entries is allocated as an "atomic" piece of memory, so
- that the GC doesn't trace it. When an item is added to the set, a
- disappearing link is registered to its location. If the item is
- collected, then that link will be zeroed out.
-
- An entry is not just an item, though; the hash code is also stored in
- the entry. We munge hash codes so that they are never 0. In this
- way we can detect removed entries (key of zero but nonzero hash
- code), and can then reshuffle elements as needed to maintain the
- robin hood ordering.
-
- Compared to buckets-and-chains hash tables, open addressing has the
- advantage that it is very cache-friendly. It also uses less memory.
-
- Implementation-wise, there are two things to note.
-
- 1. We assume that hash codes are evenly distributed across the
- range of unsigned longs. The actual hash code stored in the
- entry is left-shifted by 1 bit (losing 1 bit of hash precision),
- and then or'd with 1. In this way we ensure that the hash field
- of an occupied entry is nonzero. To map to an index, we
- right-shift the hash by one, divide by the size, and take the
- remainder.
-
- 2. Since the "keys" (the objects in the set) are stored in an
- atomic region with disappearing links, they need to be accessed
- with the GC alloc lock. `copy_weak_entry' will do that for
- you. The hash code itself can be read outside the lock,
- though.
-*/
-
-
-typedef struct {
- unsigned long hash;
- scm_t_bits key;
-} scm_t_weak_entry;
-
-
-struct weak_entry_data {
- scm_t_weak_entry *in;
- scm_t_weak_entry *out;
-};
-
-static void*
-do_copy_weak_entry (void *data)
-{
- struct weak_entry_data *e = data;
-
- e->out->hash = e->in->hash;
- e->out->key = e->in->key;
-
- return NULL;
-}
-
-static void
-copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
-{
- struct weak_entry_data data;
-
- data.in = src;
- data.out = dst;
-
- GC_call_with_alloc_lock (do_copy_weak_entry, &data);
-}
-
-
-typedef struct {
- scm_t_weak_entry *entries; /* the data */
- scm_i_pthread_mutex_t lock; /* the lock */
- unsigned long size; /* total number of slots. */
- unsigned long n_items; /* number of items in set */
- unsigned long lower; /* when to shrink */
- unsigned long upper; /* when to grow */
- int size_index; /* index into hashset_size */
- int min_size_index; /* minimum size_index */
-} scm_t_weak_set;
-
-
-#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
-#define SCM_VALIDATE_WEAK_SET(pos, arg) \
- SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set")
-#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x))
-
-
-static unsigned long
-hash_to_index (unsigned long hash, unsigned long size)
-{
- return (hash >> 1) % size;
-}
-
-static unsigned long
-entry_distance (unsigned long hash, unsigned long k, unsigned long size)
-{
- unsigned long origin = hash_to_index (hash, size);
-
- if (k >= origin)
- return k - origin;
- else
- /* The other key was displaced and wrapped around. */
- return size - origin + k;
-}
-
-#ifndef HAVE_GC_MOVE_DISAPPEARING_LINK
-static void
-GC_move_disappearing_link (void **from, void **to)
-{
- GC_unregister_disappearing_link (from);
- SCM_I_REGISTER_DISAPPEARING_LINK (to, *to);
-}
-#endif
-
-static void
-move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to)
-{
- if (from->hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (from, &copy);
- to->hash = copy.hash;
- to->key = copy.key;
-
- if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
- GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
- }
- else
- {
- to->hash = 0;
- to->key = 0;
- }
-}
-
-static void
-rob_from_rich (scm_t_weak_set *set, unsigned long k)
-{
- unsigned long empty, size;
-
- size = set->size;
-
- /* If we are to free up slot K in the set, we need room to do so. */
- assert (set->n_items < size);
-
- empty = k;
- do
- empty = (empty + 1) % size;
- /* Here we access key outside the lock. Is this a problem? At first
- glance, I wouldn't think so. */
- while (set->entries[empty].key);
-
- do
- {
- unsigned long last = empty ? (empty - 1) : (size - 1);
- move_weak_entry (&set->entries[last], &set->entries[empty]);
- empty = last;
- }
- while (empty != k);
-
- /* Just for sanity. */
- set->entries[empty].hash = 0;
- set->entries[empty].key = 0;
-}
-
-static void
-give_to_poor (scm_t_weak_set *set, unsigned long k)
-{
- /* Slot K was just freed up; possibly shuffle others down. */
- unsigned long size = set->size;
-
- while (1)
- {
- unsigned long next = (k + 1) % size;
- unsigned long hash;
- scm_t_weak_entry copy;
-
- hash = set->entries[next].hash;
-
- if (!hash || hash_to_index (hash, size) == next)
- break;
-
- copy_weak_entry (&set->entries[next], &copy);
-
- if (!copy.key)
- /* Lost weak reference. */
- {
- give_to_poor (set, next);
- set->n_items--;
- continue;
- }
-
- move_weak_entry (&set->entries[next], &set->entries[k]);
-
- k = next;
- }
-
- /* We have shuffled down any entries that should be shuffled down; now
- free the end. */
- set->entries[k].hash = 0;
- set->entries[k].key = 0;
-}
-
-
-
-
-/* Growing or shrinking is triggered when the load factor
- *
- * L = N / S (N: number of items in set, S: bucket vector length)
- *
- * passes an upper limit of 0.9 or a lower limit of 0.2.
- *
- * The implementation stores the upper and lower number of items which
- * trigger a resize in the hashset object.
- *
- * Possible hash set sizes (primes) are stored in the array
- * hashset_size.
- */
-
-static unsigned long hashset_size[] = {
- 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
- 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
- 57524111, 115048217, 230096423
-};
-
-#define HASHSET_SIZE_N (sizeof(hashset_size)/sizeof(unsigned long))
-
-static int
-compute_size_index (scm_t_weak_set *set)
-{
- int i = set->size_index;
-
- if (set->n_items < set->lower)
- {
- /* rehashing is not triggered when i <= min_size */
- do
- --i;
- while (i > set->min_size_index
- && set->n_items < hashset_size[i] / 5);
- }
- else if (set->n_items > set->upper)
- {
- ++i;
- if (i >= HASHSET_SIZE_N)
- /* The biggest size currently is 230096423, which for a 32-bit
- machine will occupy 1.5GB of memory at a load of 80%. There
- is probably something better to do here, but if you have a
- weak map of that size, you are hosed in any case. */
- abort ();
- }
-
- return i;
-}
-
-static int
-is_acceptable_size_index (scm_t_weak_set *set, int size_index)
-{
- int computed = compute_size_index (set);
-
- if (size_index == computed)
- /* We were going to grow or shrink, and allocating the new vector
- didn't change the target size. */
- return 1;
-
- if (size_index == computed + 1)
- {
- /* We were going to enlarge the set, but allocating the new
- vector finalized some objects, making an enlargement
- unnecessary. It might still be a good idea to use the larger
- set, though. (This branch also gets hit if, while allocating
- the vector, some other thread was actively removing items from
- the set. That is less likely, though.) */
- unsigned long new_lower = hashset_size[size_index] / 5;
-
- return set->size > new_lower;
- }
-
- if (size_index == computed - 1)
- {
- /* We were going to shrink the set, but when we dropped the lock
- to allocate the new vector, some other thread added elements to
- the set. */
- return 0;
- }
-
- /* The computed size differs from our newly allocated size by more
- than one size index -- recalculate. */
- return 0;
-}
-
-static void
-resize_set (scm_t_weak_set *set)
-{
- scm_t_weak_entry *old_entries, *new_entries;
- int new_size_index;
- unsigned long old_size, new_size, old_k;
-
- do
- {
- new_size_index = compute_size_index (set);
- if (new_size_index == set->size_index)
- return;
- new_size = hashset_size[new_size_index];
- }
- while (!is_acceptable_size_index (set, new_size_index));
-
- new_entries = scm_gc_malloc_pointerless (new_size * sizeof (scm_t_weak_entry),
- "weak set");
- old_entries = set->entries;
- old_size = set->size;
-
- memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry));
-
- set->size_index = new_size_index;
- set->size = new_size;
- if (new_size_index <= set->min_size_index)
- set->lower = 0;
- else
- set->lower = new_size / 5;
- set->upper = 9 * new_size / 10;
- set->n_items = 0;
- set->entries = new_entries;
-
- for (old_k = 0; old_k < old_size; old_k++)
- {
- scm_t_weak_entry copy;
- unsigned long new_k, distance;
-
- if (!old_entries[old_k].hash)
- continue;
-
- copy_weak_entry (&old_entries[old_k], &copy);
-
- if (!copy.key)
- continue;
-
- new_k = hash_to_index (copy.hash, new_size);
-
- for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
- {
- unsigned long other_hash = new_entries[new_k].hash;
-
- if (!other_hash)
- /* Found an empty entry. */
- break;
-
- /* Displace the entry if our distance is less, otherwise keep
- looking. */
- if (entry_distance (other_hash, new_k, new_size) < distance)
- {
- rob_from_rich (set, new_k);
- break;
- }
- }
-
- set->n_items++;
- new_entries[new_k].hash = copy.hash;
- new_entries[new_k].key = copy.key;
-
- if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
- (void *) new_entries[new_k].key);
- }
-}
-
-/* Run from a finalizer via do_vacuum_weak_set, this function runs over
- the whole table, removing lost weak references, reshuffling the set
- as it goes. It might resize the set if it reaps enough entries. */
-static void
-vacuum_weak_set (scm_t_weak_set *set)
-{
- scm_t_weak_entry *entries = set->entries;
- unsigned long size = set->size;
- unsigned long k;
-
- for (k = 0; k < size; k++)
- {
- unsigned long hash = entries[k].hash;
-
- if (hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (&entries[k], &copy);
-
- if (!copy.key)
- /* Lost weak reference; reshuffle. */
- {
- give_to_poor (set, k);
- set->n_items--;
- }
- }
- }
-
- if (set->n_items < set->lower)
- resize_set (set);
-}
-
-
-
-
-static SCM
-weak_set_lookup (scm_t_weak_set *set, unsigned long hash,
- scm_t_set_predicate_fn pred, void *closure,
- SCM dflt)
-{
- unsigned long k, distance, size;
- scm_t_weak_entry *entries;
-
- size = set->size;
- entries = set->entries;
-
- hash = (hash << 1) | 0x1;
- k = hash_to_index (hash, size);
-
- for (distance = 0; distance < size; distance++, k = (k + 1) % size)
- {
- unsigned long other_hash;
-
- retry:
- other_hash = entries[k].hash;
-
- if (!other_hash)
- /* Not found. */
- return dflt;
-
- if (hash == other_hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (&entries[k], &copy);
-
- if (!copy.key)
- /* Lost weak reference; reshuffle. */
- {
- give_to_poor (set, k);
- set->n_items--;
- goto retry;
- }
-
- if (pred (SCM_PACK (copy.key), closure))
- /* Found. */
- return SCM_PACK (copy.key);
- }
-
- /* If the entry's distance is less, our key is not in the set. */
- if (entry_distance (other_hash, k, size) < distance)
- return dflt;
- }
-
- /* If we got here, then we were unfortunate enough to loop through the
- whole set. Shouldn't happen, but hey. */
- return dflt;
-}
-
-
-static SCM
-weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
- scm_t_set_predicate_fn pred, void *closure,
- SCM obj)
-{
- unsigned long k, distance, size;
- scm_t_weak_entry *entries;
-
- size = set->size;
- entries = set->entries;
-
- hash = (hash << 1) | 0x1;
- k = hash_to_index (hash, size);
-
- for (distance = 0; ; distance++, k = (k + 1) % size)
- {
- unsigned long other_hash;
-
- retry:
- other_hash = entries[k].hash;
-
- if (!other_hash)
- /* Found an empty entry. */
- break;
-
- if (other_hash == hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (&entries[k], &copy);
-
- if (!copy.key)
- /* Lost weak reference; reshuffle. */
- {
- give_to_poor (set, k);
- set->n_items--;
- goto retry;
- }
-
- if (pred (SCM_PACK (copy.key), closure))
- /* Found an entry with this key. */
- return SCM_PACK (copy.key);
- }
-
- if (set->n_items > set->upper)
- /* Full set, time to resize. */
- {
- vacuum_weak_set (set);
- resize_set (set);
- return weak_set_add_x (set, hash >> 1, pred, closure, obj);
- }
-
- /* Displace the entry if our distance is less, otherwise keep
- looking. */
- if (entry_distance (other_hash, k, size) < distance)
- {
- rob_from_rich (set, k);
- break;
- }
- }
-
- set->n_items++;
- entries[k].hash = hash;
- entries[k].key = SCM_UNPACK (obj);
-
- if (SCM_HEAP_OBJECT_P (obj))
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
- (void *) SCM2PTR (obj));
-
- return obj;
-}
-
-
-static void
-weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
- scm_t_set_predicate_fn pred, void *closure)
-{
- unsigned long k, distance, size;
- scm_t_weak_entry *entries;
-
- size = set->size;
- entries = set->entries;
-
- hash = (hash << 1) | 0x1;
- k = hash_to_index (hash, size);
-
- for (distance = 0; distance < size; distance++, k = (k + 1) % size)
- {
- unsigned long other_hash;
-
- retry:
- other_hash = entries[k].hash;
-
- if (!other_hash)
- /* Not found. */
- return;
-
- if (other_hash == hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (&entries[k], &copy);
-
- if (!copy.key)
- /* Lost weak reference; reshuffle. */
- {
- give_to_poor (set, k);
- set->n_items--;
- goto retry;
- }
-
- if (pred (SCM_PACK (copy.key), closure))
- /* Found an entry with this key. */
- {
- entries[k].hash = 0;
- entries[k].key = 0;
-
- if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
- GC_unregister_disappearing_link ((void **) &entries[k].key);
-
- if (--set->n_items < set->lower)
- resize_set (set);
- else
- give_to_poor (set, k);
-
- return;
- }
- }
-
- /* If the entry's distance is less, our key is not in the set. */
- if (entry_distance (other_hash, k, size) < distance)
- return;
- }
-}
-
-
-
-static SCM
-make_weak_set (unsigned long k)
-{
- scm_t_weak_set *set;
-
- int i = 0, n = k ? k : 31;
- while (i + 1 < HASHSET_SIZE_N && n > hashset_size[i])
- ++i;
- n = hashset_size[i];
-
- set = scm_gc_malloc (sizeof (*set), "weak-set");
- set->entries = scm_gc_malloc_pointerless (n * sizeof(scm_t_weak_entry),
- "weak-set");
- memset (set->entries, 0, n * sizeof(scm_t_weak_entry));
- set->n_items = 0;
- set->size = n;
- set->lower = 0;
- set->upper = 9 * n / 10;
- set->size_index = i;
- set->min_size_index = i;
- scm_i_pthread_mutex_init (&set->lock, NULL);
-
- return scm_cell (scm_tc7_weak_set, (scm_t_bits)set);
-}
-
-void
-scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- scm_puts ("#<", port);
- scm_puts ("weak-set ", port);
- scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port);
- scm_putc ('/', port);
- scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port);
- scm_puts (">", port);
-}
-
-SCM
-scm_c_make_weak_set (unsigned long k)
-{
- SCM ret;
-
- ret = make_weak_set (k);
-
- return ret;
-}
-
-SCM
-scm_weak_set_p (SCM obj)
-{
- return scm_from_bool (SCM_WEAK_SET_P (obj));
-}
-
-SCM
-scm_weak_set_clear_x (SCM set)
-{
- scm_t_weak_set *s = SCM_WEAK_SET (set);
-
- scm_i_pthread_mutex_lock (&s->lock);
-
- memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size);
- s->n_items = 0;
-
- scm_i_pthread_mutex_unlock (&s->lock);
-
- return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure, SCM dflt)
-{
- SCM ret;
- scm_t_weak_set *s = SCM_WEAK_SET (set);
-
- scm_i_pthread_mutex_lock (&s->lock);
-
- ret = weak_set_lookup (s, raw_hash, pred, closure, dflt);
-
- scm_i_pthread_mutex_unlock (&s->lock);
-
- return ret;
-}
-
-SCM
-scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure, SCM obj)
-{
- SCM ret;
- scm_t_weak_set *s = SCM_WEAK_SET (set);
-
- scm_i_pthread_mutex_lock (&s->lock);
-
- ret = weak_set_add_x (s, raw_hash, pred, closure, obj);
-
- scm_i_pthread_mutex_unlock (&s->lock);
-
- return ret;
-}
-
-void
-scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure)
-{
- scm_t_weak_set *s = SCM_WEAK_SET (set);
-
- scm_i_pthread_mutex_lock (&s->lock);
-
- weak_set_remove_x (s, raw_hash, pred, closure);
-
- scm_i_pthread_mutex_unlock (&s->lock);
-}
-
-static int
-eq_predicate (SCM x, void *closure)
-{
- return scm_is_eq (x, SCM_PACK_POINTER (closure));
-}
-
-SCM
-scm_weak_set_add_x (SCM set, SCM obj)
-{
- return scm_c_weak_set_add_x (set, scm_ihashq (obj, -1),
- eq_predicate, SCM_UNPACK_POINTER (obj), obj);
-}
-
-SCM
-scm_weak_set_remove_x (SCM set, SCM obj)
-{
- scm_c_weak_set_remove_x (set, scm_ihashq (obj, -1),
- eq_predicate, SCM_UNPACK_POINTER (obj));
-
- return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
- SCM init, SCM set)
-{
- scm_t_weak_set *s;
- scm_t_weak_entry *entries;
- unsigned long k, size;
-
- s = SCM_WEAK_SET (set);
-
- scm_i_pthread_mutex_lock (&s->lock);
-
- size = s->size;
- entries = s->entries;
-
- for (k = 0; k < size; k++)
- {
- if (entries[k].hash)
- {
- scm_t_weak_entry copy;
-
- copy_weak_entry (&entries[k], &copy);
-
- if (copy.key)
- {
- /* Release set lock while we call the function. */
- scm_i_pthread_mutex_unlock (&s->lock);
- init = proc (closure, SCM_PACK (copy.key), init);
- scm_i_pthread_mutex_lock (&s->lock);
- }
- }
- }
-
- scm_i_pthread_mutex_unlock (&s->lock);
-
- return init;
-}
-
-static SCM
-fold_trampoline (void *closure, SCM item, SCM init)
-{
- return scm_call_2 (SCM_PACK_POINTER (closure), item, init);
-}
-
-SCM
-scm_weak_set_fold (SCM proc, SCM init, SCM set)
-{
- return scm_c_weak_set_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, set);
-}
-
-static SCM
-for_each_trampoline (void *closure, SCM item, SCM seed)
-{
- scm_call_1 (SCM_PACK_POINTER (closure), item);
- return seed;
-}
-
-SCM
-scm_weak_set_for_each (SCM proc, SCM set)
-{
- scm_c_weak_set_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, set);
-
- return SCM_UNSPECIFIED;
-}
-
-static SCM
-map_trampoline (void *closure, SCM item, SCM seed)
-{
- return scm_cons (scm_call_1 (SCM_PACK_POINTER (closure), item), seed);
-}
-
-SCM
-scm_weak_set_map_to_list (SCM proc, SCM set)
-{
- return scm_c_weak_set_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, set);
-}
-
-
-void
-scm_init_weak_set ()
-{
-#include "weak-set.x"
-}
diff --git a/libguile/weak-set.h b/libguile/weak-set.h
deleted file mode 100644
index 621bce85f..000000000
--- a/libguile/weak-set.h
+++ /dev/null
@@ -1,62 +0,0 @@
-#ifndef SCM_WEAK_SET_H
-#define SCM_WEAK_SET_H
-
-/* Copyright 2011,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"
-
-
-
-/* The weak set API is currently only used internally. We could make it
- public later, after some API review. */
-
-/* Function that returns nonzero if the given object is the one we are
- looking for. */
-typedef int (*scm_t_set_predicate_fn) (SCM obj, void *closure);
-
-/* Function to fold over the elements of a set. */
-typedef SCM (*scm_t_set_fold_fn) (void *closure, SCM key, SCM result);
-
-SCM_INTERNAL SCM scm_c_make_weak_set (unsigned long k);
-SCM_INTERNAL SCM scm_weak_set_p (SCM h);
-SCM_INTERNAL SCM scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure, SCM dflt);
-SCM_INTERNAL SCM scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure, SCM obj);
-SCM_INTERNAL void scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
- scm_t_set_predicate_fn pred,
- void *closure);
-SCM_INTERNAL SCM scm_weak_set_add_x (SCM set, SCM obj);
-SCM_INTERNAL SCM scm_weak_set_remove_x (SCM set, SCM obj);
-SCM_INTERNAL SCM scm_weak_set_clear_x (SCM set);
-SCM_INTERNAL SCM scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
- SCM init, SCM set);
-SCM_INTERNAL SCM scm_weak_set_fold (SCM proc, SCM init, SCM set);
-SCM_INTERNAL SCM scm_weak_set_for_each (SCM proc, SCM set);
-SCM_INTERNAL SCM scm_weak_set_map_to_list (SCM proc, SCM set);
-
-SCM_INTERNAL void scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate);
-SCM_INTERNAL void scm_init_weak_set (void);
-
-#endif /* SCM_WEAK_SET_H */
diff --git a/module/ice-9/guardians.scm b/module/ice-9/guardians.scm
index ef050475b..34e6537b9 100644
--- a/module/ice-9/guardians.scm
+++ b/module/ice-9/guardians.scm
@@ -88,6 +88,8 @@
(values push! pop!))
(define (make-guardian)
+ "Create a new guardian. A guardian protects a set of objects from
+garbage collection, allowing a program to apply cleanup or other"
(define-values (push! pop!) (make-atomic-fifo))
(define (guard! obj)
(when (heap-object? obj)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 8ff16cfa5..41a359cd3 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -505,7 +505,6 @@
(#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
(#('bytevector? #f (a)) (unary emit-bytevector? a))
(#('thread? #f (a)) (unary emit-thread? a))
- (#('weak-set? #f (a)) (unary emit-weak-set? a))
(#('array? #f (a)) (unary emit-array? a))
(#('bitvector? #f (a)) (unary emit-bitvector? a))
(#('smob? #f (a)) (unary emit-smob? a))
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 9347dcc51..5ecdea4cd 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -461,8 +461,6 @@ using BACKEND."
(cell->object source backend)))
(((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address))
- (((_ & #x7f = %tc7-weak-set))
- (inferior-object 'weak-set address))
(((_ & #x7f = %tc7-array))
(inferior-object 'array address))
(((_ & #x7f = %tc7-bitvector))
diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm
index a0370eddc..8d7f29088 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -51,7 +51,6 @@
%tc7-vm-continuation
%tc7-bytevector
%tc7-thread
- %tc7-weak-set
%tc7-array
%tc7-bitvector
%tc7-port
@@ -147,7 +146,7 @@
(vm-continuation vm-continuation? #b1111111 #b1000111)
(bytevector bytevector? #b1111111 #b1001101)
(thread thread? #b1111111 #b1001111)
- (weak-set weak-set? #b1111111 #b1010101)
+ ;;(unused unused #b1111111 #b1010101)
;;(unused unused #b1111111 #b1010111)
(array array? #b1111111 #b1011101)
(bitvector bitvector? #b1111111 #b1011111)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index d931dcd78..d92399b26 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -132,7 +132,6 @@
emit-vm-continuation?
emit-bytevector?
emit-thread?
- emit-weak-set?
emit-array?
emit-bitvector?
emit-ephemeron?