diff options
-rw-r--r-- | libguile.h | 1 | ||||
-rw-r--r-- | libguile/Makefile.am | 12 | ||||
-rw-r--r-- | libguile/ephemerons.c | 12 | ||||
-rw-r--r-- | libguile/ephemerons.h | 4 | ||||
-rw-r--r-- | libguile/evalext.c | 1 | ||||
-rw-r--r-- | libguile/hash.c | 1 | ||||
-rw-r--r-- | libguile/init.c | 2 | ||||
-rw-r--r-- | libguile/ioext.c | 33 | ||||
-rw-r--r-- | libguile/ports-internal.h | 9 | ||||
-rw-r--r-- | libguile/ports.c | 57 | ||||
-rw-r--r-- | libguile/ports.h | 5 | ||||
-rw-r--r-- | libguile/print.c | 4 | ||||
-rw-r--r-- | libguile/scm.h | 2 | ||||
-rw-r--r-- | libguile/symbols.c | 254 | ||||
-rw-r--r-- | libguile/weak-set.c | 873 | ||||
-rw-r--r-- | libguile/weak-set.h | 62 | ||||
-rw-r--r-- | module/ice-9/guardians.scm | 2 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 1 | ||||
-rw-r--r-- | module/system/base/types.scm | 2 | ||||
-rw-r--r-- | module/system/base/types/internal.scm | 3 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 1 |
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, ©); - 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], ©); - - 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], ©); - - 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], ©); - - 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], ©); - - 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], ©); - - 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], ©); - - 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], ©); - - 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? |