Hello! Here’s an updated patch set (tested on top of 1008ea315483d1fb41b2a8c10680e511238836d0).
Let me know if things still go wrong. Thanks, Ludo’.
>From a301af4f03377c6eabf663df8eeabf6db5e3950a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org> Date: Sat, 21 Oct 2017 16:18:39 -0600 Subject: [PATCH 1/2] Remove weak tables and revert to weak hash tables. This removes weak-tables.[ch] and reintroduces weak hash tables as implemented in Guile 2.0 into hashtab.[ch]. This reduces wall-clock time by more than 15% on some GC-intensive benchmarks (compiling code) where big weak hash tables are in use, such as source properties. For more details on the rationale, see <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>. * libguile/weak-table.c, libguile/weak-table.h: Remove. * libguile.h: Don't include "weak-table.h". * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES) (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Remove weak-table.* files. * libguile/evalext.c (scm_self_evaluating_p): Remove reference to scm_tc7_weak_table. * libguile/hashtab.c (SCM_HASHTABLEF_WEAK_CAR) (SCM_HASHTABLEF_WEAK_CDR): New macros. * libguile/hashtab.c (scm_fixup_weak_alist, vacuum_weak_hash_table) (do_weak_bucket_fixup, weak_bucket_assoc) (weak_bucket_assoc_by_hash): New function. (make_hash_table, scm_make_hash_table): Add support for weak hash tables. (weak_gc_callback, weak_gc_hook, weak_gc_finalizer) (scm_c_register_weak_gc_callback, scm_make_weak_key_hash_table) (scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table): New functions. (SCM_WEAK_TABLE_P): Remove. (scm_weak_key_hash_table_p, scm_weak_value_hash_table_p) (scm_doubly_weak_hash_table_p, scm_hash_fn_get_handle_by_hash): New functions. (scm_hash_fn_create_handle_x): Add support for weak hash tables. (get_weak_cdr, weak_pair_cdr): New functions. (scm_hash_fn_set_x): Add support for weak hash tables. (scm_hash_fn_remove_x): Likewise. (scm_hashq_get_handle, scm_hashq_create_handle_x): Likewise. (scm_hashv_get_handle, scm_hashv_create_handle_x): Likewise. (scm_hashq_ref, scm_hashq_set_x, scm_hashq_remove_x): Remove special cases for 'SCM_WEAK_TABLE_P'. (scm_hashv_ref, scm_hashv_set_x, scm_hashv_remove_x): Likewise. (scm_hash_ref, scm_hash_set_x, scm_hash_remove_x): Likewise. (scm_hashx_ref, scm_hashx_set_x, scm_hashx_remove_x): Likewise. (assv_predicate, assoc_predicate, assx_predicate): Remove. (scm_hash_map_to_list, scm_internal_hash_fold): Likewise, and check for deleted entries. (scm_internal_hash_for_each_handle): Likewise. (scm_t_ihashx_closure): Remove 'key' field. (wcar_pair_descr, wcdr_pair_descr): New variables. (scm_weak_car_pair, scm_weak_cdr_pair, scm_doubly_weak_pair): New functions. (scm_weak_table_refq, scm_weak_table_putq_x, scm_c_make_weak_table) (scm_c_weak_table_fold): Rewrite in terms of the hash-table API. (scm_init_hashtab): Initialize 'wcar_pair_descr' and 'wcdr_pair_descr'. * libguile/hashtab.h (scm_t_weak_table_kind): New type. (SCM_HASHTABLE, SCM_HASHTABLE_FLAGS, SCM_HASHTABLE_WEAK_KEY_P) (SCM_HASHTABLE_WEAK_VALUE_P, SCM_HASHTABLE_DOUBLY_WEAK_P): New macros. (scm_t_hash_predicate_fn): New type. (scm_t_hashtable)[flags]: New field. (scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table) (scm_make_weak_key_hash_table, scm_c_make_weak_table) (scm_c_weak_table_fold, scm_weak_table_refq) (scm_weak_table_putq_x): New declarations. * libguile/init.c (scm_i_init_guile): Remove calls to 'scm_weak_table_prehistory' and 'scm_init_weak_table'. (iprin1): Remove reference to scm_tc7_weak_table. * libguile/procprop.c: Include "hashtab.h". * libguile/tags.h (scm_tc7_weak_table): Remove. * libguile/weak-list.h (scm_weak_car_pair, scm_weak_cdr_pair) (scm_doubly_weak_pair): New declarations. (SCM_WEAK_PAIR_DELETED_P, SCM_WEAK_PAIR_WORD_DELETED_P) (SCM_WEAK_PAIR_CAR_DELETED_P, SCM_WEAK_PAIR_CDR_DELETED_P) (SCM_WEAK_PAIR_WORD, SCM_WEAK_PAIR_CAR, SCM_WEAK_PAIR_CDR): New macros. * module/system/base/types.scm (%tc7-weak-table): Mark as obsolete. * test-suite/tests/types.test ("opaque objects"): Replace references to 'weak-table' with 'hash-table'. Add 'make-hash-table' test. --- libguile.h | 3 +- libguile/Makefile.am | 6 +- libguile/evalext.c | 3 +- libguile/hashtab.c | 878 +++++++++++++++++++++++++------ libguile/hashtab.h | 47 +- libguile/init.c | 4 +- libguile/print.c | 3 - libguile/procprop.c | 4 +- libguile/tags.h | 3 +- libguile/weak-list.h | 32 +- libguile/weak-table.c | 1180 ------------------------------------------ libguile/weak-table.h | 94 ---- module/system/base/types.scm | 2 +- test-suite/tests/types.test | 9 +- 14 files changed, 807 insertions(+), 1461 deletions(-) delete mode 100644 libguile/weak-table.c delete mode 100644 libguile/weak-table.h diff --git a/libguile.h b/libguile.h index 3f7f0b791..90326844b 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -117,7 +117,6 @@ extern "C" { #include "libguile/version.h" #include "libguile/vports.h" #include "libguile/weak-set.h" -#include "libguile/weak-table.h" #include "libguile/weak-vector.h" #include "libguile/backtrace.h" #include "libguile/debug.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2214a4aa3..6420d0f48 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -225,7 +225,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ vm.c \ vports.c \ weak-set.c \ - weak-table.c \ weak-vector.c DOT_X_FILES = \ @@ -330,7 +329,6 @@ DOT_X_FILES = \ vm.x \ vports.x \ weak-set.x \ - weak-table.x \ weak-vector.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ @@ -432,7 +430,6 @@ DOT_DOC_FILES = \ version.doc \ vports.doc \ weak-set.doc \ - weak-table.doc \ weak-vector.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -685,7 +682,6 @@ modinclude_HEADERS = \ vm.h \ vports.h \ weak-set.h \ - weak-table.h \ weak-vector.h nodist_modinclude_HEADERS = version.h scmconfig.h diff --git a/libguile/evalext.c b/libguile/evalext.c index 33205a2ca..e381daa65 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -77,7 +77,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_pointer: case scm_tc7_hashtable: case scm_tc7_weak_set: - case scm_tc7_weak_table: case scm_tc7_fluid: case scm_tc7_dynamic_state: case scm_tc7_frame: diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 8920e08a6..86b9ca386 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006, - * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2012, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -38,9 +38,18 @@ #include "libguile/validate.h" #include "libguile/hashtab.h" +#include <gc/gc_mark.h> +#include <gc/gc_typed.h> + +/* Map the 2.0 names (on the left) to the new enum values. */ +#define SCM_HASHTABLEF_WEAK_CAR SCM_WEAK_TABLE_KIND_KEY +#define SCM_HASHTABLEF_WEAK_CDR SCM_WEAK_TABLE_KIND_VALUE + + + /* A hash table is a cell containing a vector of association lists. * * Growing or shrinking, with following rehashing, is triggered when @@ -53,6 +62,9 @@ * The implementation stores the upper and lower number of items which * trigger a resize in the hashtable object. * + * Weak hash tables use weak pairs in the bucket lists rather than + * normal pairs. + * * Possible hash table sizes (primes) are stored in the array * hashtable_size. */ @@ -72,8 +84,213 @@ static unsigned long hashtable_size[] = { static char *s_hashtable = "hashtable"; + + +/* Helper functions and macros to deal with weak pairs. + + Weak pairs need to be accessed very carefully since their components can + be nullified by the GC when the object they refer to becomes unreachable. + Hence the macros and functions below that detect such weak pairs within + buckets and remove them. */ + + +/* Remove nullified weak pairs from ALIST such that the result contains only + valid pairs. Set REMOVED_ITEMS to the number of pairs that have been + deleted. */ static SCM -make_hash_table (unsigned long k, const char *func_name) +scm_fixup_weak_alist (SCM alist, size_t *removed_items) +{ + SCM result; + SCM prev = SCM_EOL; + + *removed_items = 0; + for (result = alist; + scm_is_pair (alist); + alist = SCM_CDR (alist)) + { + SCM pair = SCM_CAR (alist); + + if (SCM_WEAK_PAIR_DELETED_P (pair)) + { + /* Remove from ALIST weak pair PAIR whose car/cdr has been + nullified by the GC. */ + if (scm_is_null (prev)) + result = SCM_CDR (alist); + else + SCM_SETCDR (prev, SCM_CDR (alist)); + + (*removed_items)++; + + /* Leave PREV unchanged. */ + } + else + prev = alist; + } + + return result; +} + +static void +vacuum_weak_hash_table (SCM table) +{ + SCM buckets = SCM_HASHTABLE_VECTOR (table); + unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets); + size_t len = SCM_HASHTABLE_N_ITEMS (table); + + while (k--) + { + size_t removed; + SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + alist = scm_fixup_weak_alist (alist, &removed); + if (removed <= len) + len -= removed; + else + { + /* The move to BDW-GC with Guile 2.0 introduced some bugs + related to weak hash tables, threads, memory usage, and the + alloc lock. We were unable to fix these issues + satisfactorily in 2.0 but have addressed them via a rewrite + in 2.2. If you see this message often, you probably want + to upgrade to 2.2. */ + fprintf (stderr, "guile: warning: weak hash table corruption " + "(https://bugs.gnu.org/19180)\n"); + len = 0; + } + SCM_SIMPLE_VECTOR_SET (buckets, k, alist); + } + + SCM_SET_HASHTABLE_N_ITEMS (table, len); +} + + +/* Packed arguments for `do_weak_bucket_fixup'. */ +struct t_fixup_args +{ + SCM bucket; + SCM *bucket_copy; + size_t removed_items; +}; + +static void * +do_weak_bucket_fixup (void *data) +{ + struct t_fixup_args *args; + SCM pair, *copy; + + args = (struct t_fixup_args *) data; + + args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items); + + for (pair = args->bucket, copy = args->bucket_copy; + scm_is_pair (pair); + pair = SCM_CDR (pair), copy += 2) + { + /* At this point, all weak pairs have been removed. */ + assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair))); + + /* Copy the key and value. */ + copy[0] = SCM_CAAR (pair); + copy[1] = SCM_CDAR (pair); + } + + return args; +} + +/* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched + for in the alist that is the BUCKET_INDEXth element of BUCKETS. + Optionally update TABLE and rehash it. */ +static SCM +weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index, + scm_t_hash_fn hash_fn, + scm_t_assoc_fn assoc, SCM object, void *closure) +{ + SCM result; + SCM bucket, *strong_refs; + struct t_fixup_args args; + + bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index); + + /* Prepare STRONG_REFS as an array large enough to hold all the keys + and values in BUCKET. */ + strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM)); + + args.bucket = bucket; + args.bucket_copy = strong_refs; + + /* Fixup BUCKET. Do that with the allocation lock held to avoid + seeing disappearing links pointing to objects that have already + been reclaimed (this happens when the disappearing links that point + to it haven't yet been cleared.) + + The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy + of BUCKET's entries after it's been fixed up. Thus, all the + entries kept in BUCKET are still reachable when ASSOC sees + them. */ + GC_call_with_alloc_lock (do_weak_bucket_fixup, &args); + + bucket = args.bucket; + SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket); + + result = assoc (object, bucket, closure); + + /* If we got a result, it should not have NULL fields. */ + if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result)) + abort (); + + scm_remember_upto_here_1 (strong_refs); + + if (args.removed_items > 0) + { + /* Update TABLE's item count and optionally trigger a rehash. */ + size_t remaining; + + assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items); + + remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items; + SCM_SET_HASHTABLE_N_ITEMS (table, remaining); + + if (remaining < SCM_HASHTABLE_LOWER (table)) + scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc"); + } + + return result; +} + + +/* Packed arguments for `weak_bucket_assoc_by_hash'. */ +struct assoc_by_hash_data +{ + SCM alist; + SCM ret; + scm_t_hash_predicate_fn predicate; + void *closure; +}; + +/* See scm_hash_fn_get_handle_by_hash below. */ +static void* +weak_bucket_assoc_by_hash (void *args) +{ + struct assoc_by_hash_data *data = args; + SCM alist = data->alist; + + for (; scm_is_pair (alist); alist = SCM_CDR (alist)) + { + SCM pair = SCM_CAR (alist); + + if (!SCM_WEAK_PAIR_DELETED_P (pair) + && data->predicate (SCM_CAR (pair), data->closure)) + { + data->ret = pair; + break; + } + } + return args; +} + + + +static SCM +make_hash_table (int flags, unsigned long k, const char *func_name) { SCM vector; scm_t_hashtable *t; @@ -82,6 +299,9 @@ make_hash_table (unsigned long k, const char *func_name) ++i; n = hashtable_size[i]; + /* In both cases, i.e., regardless of whether we are creating a weak hash + table, we return a non-weak vector. This is because the vector itself + is not weak in the case of a weak hash table: the alist pairs are. */ vector = scm_c_make_vector (n, SCM_EOL); t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable); @@ -89,6 +309,8 @@ make_hash_table (unsigned long k, const char *func_name) t->n_items = 0; t->lower = 0; t->upper = 9 * n / 10; + t->flags = flags; + t->hash_fn = NULL; /* FIXME: we just need two words of storage, not three */ return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector), @@ -121,6 +343,13 @@ scm_i_rehash (SCM table, if (i >= HASHTABLE_SIZE_N) /* don't rehash */ return; + + /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE + is not needed since CLOSURE can not be guaranteed to be valid + after this function returns. + */ + if (closure == NULL) + SCM_HASHTABLE (table)->hash_fn = hash_fn; } SCM_HASHTABLE (table)->size_index = i; @@ -134,6 +363,13 @@ scm_i_rehash (SCM table, new_buckets = scm_c_make_vector (new_size, SCM_EOL); + /* When this is a weak hashtable, running the GC might change it. + We need to cope with this while rehashing its elements. We do + this by first installing the new, empty bucket vector. Then we + remove the elements from the old bucket vector and insert them + into the new one. + */ + SCM_SET_HASHTABLE_VECTOR (table, new_buckets); SCM_SET_HASHTABLE_N_ITEMS (table, 0); @@ -153,6 +389,10 @@ scm_i_rehash (SCM table, handle = SCM_CAR (cell); ls = SCM_CDR (ls); + if (SCM_WEAK_PAIR_DELETED_P (handle)) + /* HANDLE is a nullified weak pair: skip it. */ + continue; + h = hash_fn (SCM_CAR (handle), new_size, closure); if (h >= new_size) scm_out_of_range (func_name, scm_from_ulong (h)); @@ -167,7 +407,14 @@ scm_i_rehash (SCM table, void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts ("#<hash-table ", port); + scm_puts ("#<", port); + if (SCM_HASHTABLE_WEAK_KEY_P (exp)) + scm_puts ("weak-key-", port); + else if (SCM_HASHTABLE_WEAK_VALUE_P (exp)) + scm_puts ("weak-value-", port); + else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp)) + scm_puts ("doubly-weak-", port); + scm_puts ("hash-table ", port); scm_uintprint (SCM_UNPACK (exp), 16, port); scm_putc (' ', port); scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port); @@ -181,7 +428,7 @@ scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate) SCM scm_c_make_hash_table (unsigned long k) { - return make_hash_table (k, "scm_c_make_hash_table"); + return make_hash_table (0, k, "scm_c_make_hash_table"); } SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, @@ -189,18 +436,171 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, "Make a new abstract hash table object with minimum number of buckets @var{n}\n") #define FUNC_NAME s_scm_make_hash_table { - return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME); + if (SCM_UNBNDP (n)) + return make_hash_table (0, 0, FUNC_NAME); + else + return make_hash_table (0, scm_to_ulong (n), FUNC_NAME); +} +#undef FUNC_NAME + +/* The before-gc C hook only runs if GC_set_start_callback is available, + so if not, fall back on a finalizer-based implementation. */ +static int +weak_gc_callback (void **weak) +{ + void *val = weak[0]; + void (*callback) (SCM) = weak[1]; + + if (!val) + return 0; + + callback (PTR2SCM (val)); + + return 1; +} + +#ifdef HAVE_GC_SET_START_CALLBACK +static void* +weak_gc_hook (void *hook_data, void *fn_data, void *data) +{ + if (!weak_gc_callback (fn_data)) + scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data); + + return NULL; +} +#else +static void +weak_gc_finalizer (void *ptr, void *data) +{ + if (weak_gc_callback (ptr)) + GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL); +} +#endif + +static void +scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) +{ + void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); + + weak[0] = SCM2PTR (obj); + weak[1] = (void*)callback; + GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); + +#ifdef HAVE_GC_SET_START_CALLBACK + scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0); +#else + GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL); +#endif +} + +SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, + (SCM n), + "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" + "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" + "Return a weak hash table with @var{size} buckets.\n" + "\n" + "You can modify weak hash tables in exactly the same way you\n" + "would modify regular hash tables. (@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_weak_key_hash_table +{ + SCM ret; + + if (SCM_UNBNDP (n)) + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); + else + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, + (SCM n), + "Return a hash table with weak values with @var{size} buckets.\n" + "(@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_weak_value_hash_table +{ + SCM ret; + + if (SCM_UNBNDP (n)) + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); + else + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 0, + (SCM n), + "Return a hash table with weak keys and values with @var{size}\n" + "buckets. (@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_doubly_weak_hash_table +{ + SCM ret; + + if (SCM_UNBNDP (n)) + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, + 0, FUNC_NAME); + else + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; } #undef FUNC_NAME -#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x))) SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is an abstract hash table object.") #define FUNC_NAME s_scm_hash_table_p { - return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj)); + return scm_from_bool (SCM_HASHTABLE_P (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, + (SCM obj), + "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" + "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n" + "Return @code{#t} if @var{obj} is the specified weak hash\n" + "table. Note that a doubly weak hash table is neither a weak key\n" + "nor a weak value hash table.") +#define FUNC_NAME s_scm_weak_key_hash_table_p +{ + return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a weak value hash table.") +#define FUNC_NAME s_scm_weak_value_hash_table_p +{ + return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a doubly weak hash table.") +#define FUNC_NAME s_scm_doubly_weak_hash_table_p +{ + return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj)); } #undef FUNC_NAME @@ -226,7 +626,69 @@ scm_hash_fn_get_handle (SCM table, SCM obj, if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range (FUNC_NAME, scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + if (SCM_HASHTABLE_WEAK_P (table)) + h = weak_bucket_assoc (table, buckets, k, hash_fn, + assoc_fn, obj, closure); + else + h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + + return h; +} +#undef FUNC_NAME + + +/* This procedure implements three optimizations, with respect to the + raw get_handle(): + + 1. For weak tables, it's assumed that calling the predicate in the + allocation lock is safe. In practice this means that the predicate + cannot call arbitrary scheme functions. + + 2. We don't check for overflow / underflow and rehash. + + 3. We don't actually have to allocate a key -- instead we get the + hash value directly. This is useful for, for example, looking up + strings in the symbol table. + */ +SCM +scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash, + scm_t_hash_predicate_fn predicate_fn, + void *closure) +#define FUNC_NAME "scm_hash_fn_ref_by_hash" +{ + unsigned long k; + SCM buckets, alist, h = SCM_BOOL_F; + + SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); + buckets = SCM_HASHTABLE_VECTOR (table); + + if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) + return SCM_BOOL_F; + + k = raw_hash % SCM_SIMPLE_VECTOR_LENGTH (buckets); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + + if (SCM_HASHTABLE_WEAK_P (table)) + { + struct assoc_by_hash_data args; + + args.alist = alist; + args.ret = SCM_BOOL_F; + args.predicate = predicate_fn; + args.closure = closure; + GC_call_with_alloc_lock (weak_bucket_assoc_by_hash, &args); + h = args.ret; + } + else + for (; scm_is_pair (alist); alist = SCM_CDR (alist)) + { + SCM pair = SCM_CAR (alist); + if (predicate_fn (SCM_CAR (pair), closure)) + { + h = pair; + break; + } + } return h; } @@ -252,7 +714,11 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k)); - it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + if (SCM_HASHTABLE_WEAK_P (table)) + it = weak_bucket_assoc (table, buckets, k, hash_fn, + assoc_fn, obj, closure); + else + it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); if (scm_is_pair (it)) return it; @@ -260,9 +726,29 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, scm_wrong_type_arg_msg (NULL, 0, it, "a pair"); else { + /* When this is a weak hashtable, running the GC can change it. + Thus, we must allocate the new cells first and can only then + access BUCKETS. Also, we need to fetch the bucket vector + again since the hashtable might have been rehashed. This + necessitates a new hash value as well. + */ SCM handle, new_bucket; - handle = scm_cons (obj, init); + if (SCM_HASHTABLE_WEAK_P (table)) + { + /* FIXME: We don't support weak alist vectors. */ + /* Use a weak cell. */ + if (SCM_HASHTABLE_DOUBLY_WEAK_P (table)) + handle = scm_doubly_weak_pair (obj, init); + else if (SCM_HASHTABLE_WEAK_KEY_P (table)) + handle = scm_weak_car_pair (obj, init); + else + handle = scm_weak_cdr_pair (obj, init); + } + else + /* Use a regular, non-weak cell. */ + handle = scm_cons (obj, init); + new_bucket = scm_cons (handle, SCM_EOL); if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets)) @@ -298,6 +784,36 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, return dflt; } +struct weak_cdr_data +{ + SCM pair; + SCM cdr; +}; + +static void* +get_weak_cdr (void *data) +{ + struct weak_cdr_data *d = data; + + if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair)) + d->cdr = SCM_BOOL_F; + else + d->cdr = SCM_CDR (d->pair); + + return NULL; +} + +static SCM +weak_pair_cdr (SCM x) +{ + struct weak_cdr_data data; + + data.pair = x; + GC_call_with_alloc_lock (get_weak_cdr, &data); + + return data.cdr; +} + SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, @@ -309,7 +825,24 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, hash_fn, assoc_fn, closure); if (!scm_is_eq (SCM_CDR (pair), val)) - SCM_SETCDR (pair, val); + { + if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table))) + { + /* If the former value was on the heap, we need to unregister + the weak link. */ + SCM prev = weak_pair_cdr (pair); + + SCM_SETCDR (pair, val); + + if (SCM_NIMP (prev) && !SCM_NIMP (val)) + GC_unregister_disappearing_link ((void **) SCM_CDRLOC (pair)); + else + SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair), + SCM2PTR (val)); + } + else + SCM_SETCDR (pair, val); + } return val; } @@ -336,7 +869,11 @@ scm_hash_fn_remove_x (SCM table, SCM obj, if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range (FUNC_NAME, scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + if (SCM_HASHTABLE_WEAK_P (table)) + h = weak_bucket_assoc (table, buckets, k, hash_fn, + assoc_fn, obj, closure); + else + h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); if (scm_is_true (h)) { @@ -355,12 +892,6 @@ SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, "Remove all items from @var{table} (without triggering a resize).") #define FUNC_NAME s_scm_hash_clear_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_weak_table_clear_x (table); - return SCM_UNSPECIFIED; - } - SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL); @@ -380,6 +911,9 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, "Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_get_handle { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -395,6 +929,9 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hashq_create_handle_x { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -413,10 +950,6 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - - if (SCM_WEAK_TABLE_P (table)) - return scm_weak_table_refq (table, key, dflt); - return scm_hash_fn_ref (table, key, dflt, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -432,12 +965,6 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, "store @var{val} there. Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_set_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_weak_table_putq_x (table, key, val); - return val; - } - return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -453,16 +980,6 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, "@var{table}. Uses @code{eq?} for equality tests.") #define FUNC_NAME s_scm_hashq_remove_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_weak_table_remq_x (table, key); - /* This return value is for historical compatibility with - hash-remove!, which returns either the "handle" corresponding - to the entry, or #f. Since weak tables don't have handles, we - have to return #f. */ - return SCM_BOOL_F; - } - return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -481,6 +998,9 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, "Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_get_handle { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -496,6 +1016,9 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hashv_create_handle_x { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -504,12 +1027,6 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, #undef FUNC_NAME -static int -assv_predicate (SCM k, SCM v, void *closure) -{ - return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure))); -} - SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, (SCM table, SCM key, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" @@ -520,12 +1037,6 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - - if (SCM_WEAK_TABLE_P (table)) - return scm_c_weak_table_ref (table, scm_ihashv (key, -1), - assv_predicate, - (void *) SCM_UNPACK (key), dflt); - return scm_hash_fn_ref (table, key, dflt, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -541,14 +1052,6 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, "store @var{value} there. Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_set_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_c_weak_table_put_x (table, scm_ihashv (key, -1), - assv_predicate, (void *) SCM_UNPACK (key), - key, val); - return val; - } - return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -563,14 +1066,6 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, "@var{table}. Uses @code{eqv?} for equality tests.") #define FUNC_NAME s_scm_hashv_remove_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_c_weak_table_remove_x (table, scm_ihashv (key, -1), - assv_predicate, (void *) SCM_UNPACK (key)); - /* See note in hashq-remove!. */ - return SCM_BOOL_F; - } - return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -588,6 +1083,9 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, "Uses @code{equal?} for equality testing.") #define FUNC_NAME s_scm_hash_get_handle { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -603,6 +1101,9 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hash_create_handle_x { + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -611,12 +1112,6 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, #undef FUNC_NAME -static int -assoc_predicate (SCM k, SCM v, void *closure) -{ - return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure))); -} - SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, (SCM table, SCM key, SCM dflt), "Look up @var{key} in the hash table @var{table}, and return the\n" @@ -627,12 +1122,6 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, { if (SCM_UNBNDP (dflt)) dflt = SCM_BOOL_F; - - if (SCM_WEAK_TABLE_P (table)) - return scm_c_weak_table_ref (table, scm_ihash (key, -1), - assoc_predicate, - (void *) SCM_UNPACK (key), dflt); - return scm_hash_fn_ref (table, key, dflt, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -649,14 +1138,6 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, "testing.") #define FUNC_NAME s_scm_hash_set_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_c_weak_table_put_x (table, scm_ihash (key, -1), - assoc_predicate, (void *) SCM_UNPACK (key), - key, val); - return val; - } - return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -672,14 +1153,6 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, "@var{table}. Uses @code{equal?} for equality tests.") #define FUNC_NAME s_scm_hash_remove_x { - if (SCM_WEAK_TABLE_P (table)) - { - scm_c_weak_table_remove_x (table, scm_ihash (key, -1), - assoc_predicate, (void *) SCM_UNPACK (key)); - /* See note in hashq-remove!. */ - return SCM_BOOL_F; - } - return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -694,9 +1167,10 @@ typedef struct scm_t_ihashx_closure { SCM hash; SCM assoc; - SCM key; } scm_t_ihashx_closure; + + static unsigned long scm_ihashx (SCM obj, unsigned long n, void *arg) { @@ -706,6 +1180,8 @@ scm_ihashx (SCM obj, unsigned long n, void *arg) return scm_to_ulong (answer); } + + static SCM scm_sloppy_assx (SCM obj, SCM alist, void *arg) { @@ -713,20 +1189,6 @@ scm_sloppy_assx (SCM obj, SCM alist, void *arg) return scm_call_2 (closure->assoc, obj, alist); } -static int -assx_predicate (SCM k, SCM v, void *closure) -{ - scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure; - - /* FIXME: The hashx interface is crazy. Hash tables have nothing to - do with alists in principle. Instead of getting an assoc proc, - hashx functions should use an equality predicate. Perhaps we can - change this before 2.2, but until then, add a terrible, terrible - hack. */ - - return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL))); -} - SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, (SCM hash, SCM assoc, SCM table, SCM key), @@ -741,7 +1203,9 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - closure.key = key; + + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, (void *) &closure); @@ -762,7 +1226,9 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - closure.key = key; + + if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); @@ -789,15 +1255,6 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, dflt = SCM_BOOL_F; closure.hash = hash; closure.assoc = assoc; - closure.key = key; - - if (SCM_WEAK_TABLE_P (table)) - { - unsigned long h = scm_to_ulong (scm_call_2 (hash, key, - scm_from_ulong (-1))); - return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt); - } - return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure); } @@ -822,16 +1279,6 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - closure.key = key; - - if (SCM_WEAK_TABLE_P (table)) - { - unsigned long h = scm_to_ulong (scm_call_2 (hash, key, - scm_from_ulong (-1))); - scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val); - return val; - } - return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); } @@ -853,17 +1300,6 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - closure.key = obj; - - if (SCM_WEAK_TABLE_P (table)) - { - unsigned long h = scm_to_ulong (scm_call_2 (hash, obj, - scm_from_ulong (-1))); - scm_c_weak_table_remove_x (table, h, assx_predicate, &closure); - /* See note in hashq-remove!. */ - return SCM_BOOL_F; - } - return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, (void *) &closure); } @@ -884,10 +1320,6 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, #define FUNC_NAME s_scm_hash_fold { SCM_VALIDATE_PROC (1, proc); - - if (SCM_WEAK_TABLE_P (table)) - return scm_weak_table_fold (proc, init, table); - SCM_VALIDATE_HASHTABLE (3, table); return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3, (void *) SCM_UNPACK (proc), init, table); @@ -909,13 +1341,6 @@ SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, #define FUNC_NAME s_scm_hash_for_each { SCM_VALIDATE_PROC (1, proc); - - if (SCM_WEAK_TABLE_P (table)) - { - scm_weak_table_for_each (proc, table); - return SCM_UNSPECIFIED; - } - SCM_VALIDATE_HASHTABLE (2, table); scm_internal_hash_for_each_handle (for_each_proc, @@ -934,6 +1359,9 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME); SCM_VALIDATE_HASHTABLE (2, table); + if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table))) + SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1, (void *) SCM_UNPACK (proc), table); @@ -956,10 +1384,6 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, #define FUNC_NAME s_scm_hash_map_to_list { SCM_VALIDATE_PROC (1, proc); - - if (SCM_WEAK_TABLE_P (table)) - return scm_weak_table_map_to_list (proc, table); - SCM_VALIDATE_HASHTABLE (2, table); return scm_internal_hash_fold (map_proc, (void *) SCM_UNPACK (proc), @@ -1005,9 +1429,6 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, long i, n; SCM buckets, result = init; - if (SCM_WEAK_TABLE_P (table)) - return scm_c_weak_table_fold (fn, closure, init, table); - SCM_VALIDATE_HASHTABLE (0, table); buckets = SCM_HASHTABLE_VECTOR (table); @@ -1020,7 +1441,14 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, ls = SCM_CDR (ls)) { handle = SCM_CAR (ls); - result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); + + if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle)) + /* Don't try to unlink this weak pair, as we're not within + the allocation lock. Instead rely on + vacuum_weak_hash_table to do its job. */ + continue; + else + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); } } @@ -1056,7 +1484,9 @@ scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure, handle = SCM_CAR (ls); if (!scm_is_pair (handle)) SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); - fn (closure, handle); + if (!SCM_HASHTABLE_WEAK_P (table) + || !SCM_WEAK_PAIR_DELETED_P (handle)) + fn (closure, handle); ls = SCM_CDR (ls); } } @@ -1064,11 +1494,137 @@ scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure, #undef FUNC_NAME +/* Weak pairs for use in weak alist vectors and weak hash tables. + + We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak + pairs, the weak component(s) are not scanned for pointers and are + registered as disapperaring links; therefore, the weak component may be + set to NULL by the garbage collector when no other reference to that word + exist. Thus, users should only access weak pairs via the + `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in + `hashtab.c'. */ + +/* Type descriptors for weak-c[ad]r pairs. */ +static GC_descr wcar_pair_descr, wcdr_pair_descr; + + +SCM +scm_weak_car_pair (SCM car, SCM cdr) +{ + scm_t_cell *cell; + + cell = (scm_t_cell *) GC_malloc_explicitly_typed (sizeof (*cell), + wcar_pair_descr); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (car)) + /* Weak car cells make sense iff the car is non-immediate. */ + SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car)); + + return SCM_PACK (cell); +} + +SCM +scm_weak_cdr_pair (SCM car, SCM cdr) +{ + scm_t_cell *cell; + + cell = (scm_t_cell *) GC_malloc_explicitly_typed (sizeof (*cell), + wcdr_pair_descr); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (cdr)) + /* Weak cdr cells make sense iff the cdr is non-immediate. */ + SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr)); + + return SCM_PACK (cell); +} + +SCM +scm_doubly_weak_pair (SCM car, SCM cdr) +{ + /* Doubly weak cells shall not be scanned at all for pointers. */ + scm_t_cell *cell = (scm_t_cell *) scm_gc_malloc_pointerless (sizeof (*cell), + "weak cell"); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (car)) + SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car)); + if (SCM_NIMP (cdr)) + SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr)); + + return SCM_PACK (cell); +} + + +/* Backward-compatibility with the former internal weak-table API. */ + +SCM +scm_weak_table_refq (SCM table, SCM key, SCM dflt) +{ + return scm_hash_fn_ref (table, key, dflt, + (scm_t_hash_fn) scm_ihashq, + (scm_t_assoc_fn) scm_sloppy_assq, + 0); +} + +void +scm_weak_table_putq_x (SCM table, SCM key, SCM value) +{ + (void) scm_hashq_set_x (table, key, value); +} + +SCM +scm_c_make_weak_table (unsigned long size, scm_t_weak_table_kind kind) +{ + switch (kind) + { + case SCM_WEAK_TABLE_KIND_KEY: + return scm_make_weak_key_hash_table (scm_from_ulong (size)); + case SCM_WEAK_TABLE_KIND_VALUE: + return scm_make_weak_value_hash_table (scm_from_ulong (size)); + case SCM_WEAK_TABLE_KIND_BOTH: + return scm_make_doubly_weak_hash_table (scm_from_ulong (size)); + default: + abort (); + } +} + +SCM +scm_c_weak_table_fold (scm_t_hash_fold_fn fn, void *closure, + SCM init, SCM table) +{ + return scm_internal_hash_fold (fn, closure, init, table); +} + + void scm_init_hashtab () { + /* Initialize weak pairs. */ + GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 }; + GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 }; + + /* In a weak-car pair, only the second word must be scanned for + pointers. */ + GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1)); + wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap, + GC_WORD_LEN (scm_t_cell)); + + /* Conversely, in a weak-cdr pair, only the first word must be scanned for + pointers. */ + GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0)); + wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap, + GC_WORD_LEN (scm_t_cell)); + #include "libguile/hashtab.x" } diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 82ed22e66..8f422b0b5 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -3,7 +3,7 @@ #ifndef SCM_HASHTAB_H #define SCM_HASHTAB_H -/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -25,14 +25,33 @@ #include "libguile/__scm.h" +#include "libguile/weak-list.h" + #define SCM_HASHTABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_hashtable)) + +/* Types of weak hash tables. */ +typedef enum { + SCM_WEAK_TABLE_KIND_KEY, + SCM_WEAK_TABLE_KIND_VALUE, + SCM_WEAK_TABLE_KIND_BOTH +} scm_t_weak_table_kind; + #define SCM_VALIDATE_HASHTABLE(pos, arg) \ SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table") #define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h) #define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 ((x), (v)) #define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x)) +#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags) +#define SCM_HASHTABLE_WEAK_KEY_P(x) \ + (SCM_HASHTABLE_FLAGS (x) == SCM_WEAK_TABLE_KIND_KEY) +#define SCM_HASHTABLE_WEAK_VALUE_P(x) \ + (SCM_HASHTABLE_FLAGS (x) == SCM_WEAK_TABLE_KIND_VALUE) +#define SCM_HASHTABLE_DOUBLY_WEAK_P(x) \ + (SCM_HASHTABLE_FLAGS (x) == SCM_WEAK_TABLE_KIND_BOTH) + +#define SCM_HASHTABLE_WEAK_P(x) SCM_HASHTABLE_FLAGS (x) #define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items) #define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n) #define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++) @@ -55,6 +74,10 @@ typedef unsigned long (*scm_t_hash_fn) (SCM obj, unsigned long max, some equality predicate. */ typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure); +/* Function that returns true if the given object is the one we are + looking for, for scm_hash_fn_ref_by_hash. */ +typedef int (*scm_t_hash_predicate_fn) (SCM obj, void *closure); + /* Function to fold over the entries of a hash table. */ typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value, SCM result); @@ -64,6 +87,7 @@ typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value, typedef SCM (*scm_t_hash_handle_fn) (void *closure, SCM handle); typedef struct scm_t_hashtable { + scm_t_weak_table_kind flags; /* properties of table */ unsigned long n_items; /* number of items in table */ unsigned long lower; /* when to shrink */ unsigned long upper; /* when to grow */ @@ -77,8 +101,14 @@ typedef struct scm_t_hashtable { SCM_API SCM scm_vector_to_hash_table (SCM vector); SCM_API SCM scm_c_make_hash_table (unsigned long k); SCM_API SCM scm_make_hash_table (SCM n); +SCM_API SCM scm_make_weak_key_hash_table (SCM k); +SCM_API SCM scm_make_weak_value_hash_table (SCM k); +SCM_API SCM scm_make_doubly_weak_hash_table (SCM k); SCM_API SCM scm_hash_table_p (SCM h); +SCM_API SCM scm_weak_key_hash_table_p (SCM h); +SCM_API SCM scm_weak_value_hash_table_p (SCM h); +SCM_API SCM scm_doubly_weak_hash_table_p (SCM h); SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn, void *closure, const char *func_name); @@ -88,6 +118,10 @@ SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, void *closure); +SCM_INTERNAL +SCM scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash, + scm_t_hash_predicate_fn predicate_fn, + void *closure); SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, @@ -138,6 +172,17 @@ SCM_API SCM scm_hash_count (SCM hash, SCM pred); SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate); SCM_INTERNAL void scm_init_hashtab (void); + +/* Guile 2.2.x (x <= 2) weak-table API. */ + +SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k, + scm_t_weak_table_kind kind); +SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_hash_fold_fn proc, void *closure, + SCM init, SCM table); +SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt); +SCM_INTERNAL void scm_weak_table_putq_x (SCM table, SCM key, SCM value); + + #endif /* SCM_HASHTAB_H */ /* diff --git a/libguile/init.c b/libguile/init.c index b046685d4..64d3f8d63 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2004, 2006, 2009-2014 Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2006, 2009-2014, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -387,7 +387,6 @@ scm_i_init_guile (void *base) scm_storage_prehistory (); scm_threads_prehistory (base); /* requires storage_prehistory */ - scm_weak_table_prehistory (); /* requires storage_prehistory */ #ifdef GUILE_DEBUG_MALLOC scm_debug_malloc_prehistory (); #endif @@ -495,7 +494,6 @@ scm_i_init_guile (void *base) scm_init_trees (); scm_init_version (); scm_init_weak_set (); - scm_init_weak_table (); scm_init_weak_vectors (); scm_init_guardians (); /* requires smob_prehistory */ scm_init_vports (); diff --git a/libguile/print.c b/libguile/print.c index 24c532f29..75a44d99c 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -701,9 +701,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_weak_set: scm_i_weak_set_print (exp, port, pstate); break; - case scm_tc7_weak_table: - scm_i_weak_table_print (exp, port, pstate); - break; case scm_tc7_fluid: scm_i_fluid_print (exp, port, pstate); break; diff --git a/libguile/procprop.c b/libguile/procprop.c index ad56bd5ba..c906c93f8 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -30,7 +30,7 @@ #include "libguile/gsubr.h" #include "libguile/smob.h" #include "libguile/vectors.h" -#include "libguile/weak-table.h" +#include "libguile/hashtab.h" #include "libguile/programs.h" #include "libguile/vm-builtins.h" diff --git a/libguile/tags.h b/libguile/tags.h index 3a01a1587..9aa4d00d0 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015,2017 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -423,7 +423,6 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_bytevector 0x4d #define scm_tc7_unused_4f 0x4f #define scm_tc7_weak_set 0x55 -#define scm_tc7_weak_table 0x57 #define scm_tc7_array 0x5d #define scm_tc7_bitvector 0x5f #define scm_tc7_unused_65 0x65 diff --git a/libguile/weak-list.h b/libguile/weak-list.h index 989cb7f0a..e8e5a3555 100644 --- a/libguile/weak-list.h +++ b/libguile/weak-list.h @@ -3,7 +3,7 @@ #ifndef SCM_WEAK_LIST_H #define SCM_WEAK_LIST_H -/* Copyright (C) 2016 Free Software Foundation, Inc. +/* Copyright (C) 2016, 2017 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -24,6 +24,7 @@ #include "libguile/__scm.h" +#include "libguile/pairs.h" #include "libguile/weak-vector.h" @@ -64,6 +65,35 @@ scm_i_visit_weak_list (SCM *list_loc, void (*visit) (SCM)) } + +/* Weak pairs. */ + +SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr); +SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr); +SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr); + +/* Testing the weak component(s) of a cell for reachability. */ +#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \ + (SCM_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0) +#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \ + (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0)) +#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \ + (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1)) + +#define SCM_WEAK_PAIR_DELETED_P(_cell) \ + ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \ + || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell))) + +/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if + the car/cdr has been collected. */ +#define SCM_WEAK_PAIR_WORD(_cell, _word) \ + (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \ + ? SCM_UNDEFINED \ + : SCM_CELL_OBJECT ((_cell), (_word))) +#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0)) +#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1)) + + #endif /* SCM_WEAK_LIST_H */ /* diff --git a/libguile/weak-table.c b/libguile/weak-table.c deleted file mode 100644 index 599c4cf0e..000000000 --- a/libguile/weak-table.c +++ /dev/null @@ -1,1180 +0,0 @@ -/* Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include <assert.h> - -#include "libguile/bdw-gc.h" -#include <gc/gc_mark.h> - -#include "libguile/_scm.h" -#include "libguile/hash.h" -#include "libguile/eval.h" -#include "libguile/ports.h" - -#include "libguile/validate.h" -#include "libguile/weak-list.h" -#include "libguile/weak-table.h" - - -/* Weak Tables - - This file implements weak hash tables. Weak hash tables are - generally used when you want to augment some object with additional - data, but when you don't have space to store the data in the object. - For example, procedure properties are implemented with weak tables. - - Weak tables 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 in such a way that the GC doesn't - trace the weak values. For doubly-weak tables, this means that the - entries are allocated as an "atomic" piece of memory. Key-weak and - value-weak tables use a special GC kind with a custom mark procedure. - When items are added weakly into table, a disappearing link is - registered to their locations. If the referent is collected, then - that link will be zeroed out. - - An entry in the table consists of the key and the value, together - with the hash code of the key. 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 weak references 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_bits value; -} 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; - e->out->value = e->in->value; - - 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); -} - -static void -register_disappearing_links (scm_t_weak_entry *entry, - SCM k, SCM v, - scm_t_weak_table_kind kind) -{ - if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k) - && (kind == SCM_WEAK_TABLE_KIND_KEY - || kind == SCM_WEAK_TABLE_KIND_BOTH)) - SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key, - SCM2PTR (k)); - - if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v) - && (kind == SCM_WEAK_TABLE_KIND_VALUE - || kind == SCM_WEAK_TABLE_KIND_BOTH)) - SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value, - SCM2PTR (v)); -} - -static void -unregister_disappearing_links (scm_t_weak_entry *entry, - scm_t_weak_table_kind kind) -{ - if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) - GC_unregister_disappearing_link ((void **) &entry->key); - - if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) - GC_unregister_disappearing_link ((void **) &entry->value); -} - -#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_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to, - SCM key, SCM value, scm_t_weak_table_kind kind) -{ - if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) - && SCM_HEAP_OBJECT_P (key)) - GC_move_disappearing_link ((void **) &from->key, (void **) &to->key); - - if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) - && SCM_HEAP_OBJECT_P (value)) - GC_move_disappearing_link ((void **) &from->value, (void **) &to->value); -} - -static void -move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to, - scm_t_weak_table_kind kind) -{ - if (from->hash) - { - scm_t_weak_entry copy; - - copy_weak_entry (from, ©); - to->hash = copy.hash; - to->key = copy.key; - to->value = copy.value; - - move_disappearing_links (from, to, - SCM_PACK (copy.key), SCM_PACK (copy.value), - kind); - } - else - { - to->hash = 0; - to->key = 0; - to->value = 0; - } -} - - -typedef struct { - scm_t_weak_entry *entries; /* the data */ - scm_i_pthread_mutex_t lock; /* the lock */ - scm_t_weak_table_kind kind; /* what kind of table it is */ - unsigned long size; /* total number of slots. */ - unsigned long n_items; /* number of items in table */ - unsigned long lower; /* when to shrink */ - unsigned long upper; /* when to grow */ - int size_index; /* index into hashtable_size */ - int min_size_index; /* minimum size_index */ -} scm_t_weak_table; - - -#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table)) -#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \ - SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table") -#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) 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; -} - -static void -rob_from_rich (scm_t_weak_table *table, unsigned long k) -{ - unsigned long empty, size; - - size = table->size; - - /* If we are to free up slot K in the table, we need room to do so. */ - assert (table->n_items < size); - - empty = k; - do - empty = (empty + 1) % size; - while (table->entries[empty].hash); - - do - { - unsigned long last = empty ? (empty - 1) : (size - 1); - move_weak_entry (&table->entries[last], &table->entries[empty], - table->kind); - empty = last; - } - while (empty != k); - - table->entries[empty].hash = 0; - table->entries[empty].key = 0; - table->entries[empty].value = 0; -} - -static void -give_to_poor (scm_t_weak_table *table, unsigned long k) -{ - /* Slot K was just freed up; possibly shuffle others down. */ - unsigned long size = table->size; - - while (1) - { - unsigned long next = (k + 1) % size; - unsigned long hash; - scm_t_weak_entry copy; - - hash = table->entries[next].hash; - - if (!hash || hash_to_index (hash, size) == next) - break; - - copy_weak_entry (&table->entries[next], ©); - - if (!copy.key || !copy.value) - /* Lost weak reference. */ - { - give_to_poor (table, next); - table->n_items--; - continue; - } - - move_weak_entry (&table->entries[next], &table->entries[k], - table->kind); - - k = next; - } - - /* We have shuffled down any entries that should be shuffled down; now - free the end. */ - table->entries[k].hash = 0; - table->entries[k].key = 0; - table->entries[k].value = 0; -} - - - - -/* The GC "kinds" for singly-weak tables. */ -static int weak_key_gc_kind; -static int weak_value_gc_kind; - -static struct GC_ms_entry * -mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, - struct GC_ms_entry *mark_stack_limit, GC_word env) -{ - scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; - unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); - - for (k = 0; k < size; k++) - if (entries[k].hash && entries[k].key) - { - SCM value = SCM_PACK (entries[k].value); - mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value), - mark_stack_ptr, mark_stack_limit, - NULL); - } - - return mark_stack_ptr; -} - -static struct GC_ms_entry * -mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, - struct GC_ms_entry *mark_stack_limit, GC_word env) -{ - scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; - unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); - - for (k = 0; k < size; k++) - if (entries[k].hash && entries[k].value) - { - SCM key = SCM_PACK (entries[k].key); - mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key), - mark_stack_ptr, mark_stack_limit, - NULL); - } - - return mark_stack_ptr; -} - -static scm_t_weak_entry * -allocate_entries (unsigned long size, scm_t_weak_table_kind kind) -{ - scm_t_weak_entry *ret; - size_t bytes = size * sizeof (*ret); - - switch (kind) - { - case SCM_WEAK_TABLE_KIND_KEY: - ret = GC_generic_malloc (bytes, weak_key_gc_kind); - break; - case SCM_WEAK_TABLE_KIND_VALUE: - ret = GC_generic_malloc (bytes, weak_value_gc_kind); - break; - case SCM_WEAK_TABLE_KIND_BOTH: - ret = scm_gc_malloc_pointerless (bytes, "weak-table"); - break; - default: - abort (); - } - - memset (ret, 0, bytes); - - return ret; -} - - - -/* Growing or shrinking is triggered when the load factor - * - * L = N / S (N: number of items in table, 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 hashtable object. - * - * Possible hash table sizes (primes) are stored in the array - * hashtable_size. - */ - -static unsigned long hashtable_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 HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long)) - -static int -compute_size_index (scm_t_weak_table *table) -{ - int i = table->size_index; - - if (table->n_items < table->lower) - { - /* rehashing is not triggered when i <= min_size */ - do - --i; - while (i > table->min_size_index - && table->n_items < hashtable_size[i] / 5); - } - else if (table->n_items > table->upper) - { - ++i; - if (i >= HASHTABLE_SIZE_N) - /* The biggest size currently is 230096423, which for a 32-bit - machine will occupy 2.3GB 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_table *table, int size_index) -{ - int computed = compute_size_index (table); - - 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 table, but allocating the new - vector finalized some objects, making an enlargement - unnecessary. It might still be a good idea to use the larger - table, though. (This branch also gets hit if, while allocating - the vector, some other thread was actively removing items from - the table. That is less likely, though.) */ - unsigned long new_lower = hashtable_size[size_index] / 5; - - return table->size > new_lower; - } - - if (size_index == computed - 1) - { - /* We were going to shrink the table, but when we dropped the lock - to allocate the new vector, some other thread added elements to - the table. */ - return 0; - } - - /* The computed size differs from our newly allocated size by more - than one size index -- recalculate. */ - return 0; -} - -static void -resize_table (scm_t_weak_table *table) -{ - 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 (table); - if (new_size_index == table->size_index) - return; - new_size = hashtable_size[new_size_index]; - new_entries = allocate_entries (new_size, table->kind); - } - while (!is_acceptable_size_index (table, new_size_index)); - - old_entries = table->entries; - old_size = table->size; - - table->size_index = new_size_index; - table->size = new_size; - if (new_size_index <= table->min_size_index) - table->lower = 0; - else - table->lower = new_size / 5; - table->upper = 9 * new_size / 10; - table->n_items = 0; - table->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 || !copy.value) - 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 (table, new_k); - break; - } - } - - table->n_items++; - new_entries[new_k].hash = copy.hash; - new_entries[new_k].key = copy.key; - new_entries[new_k].value = copy.value; - - register_disappearing_links (&new_entries[new_k], - SCM_PACK (copy.key), SCM_PACK (copy.value), - table->kind); - } -} - -/* Run after GC via do_vacuum_weak_table, this function runs over the - whole table, removing lost weak references, reshuffling the table as it - goes. It might resize the table if it reaps enough entries. */ -static void -vacuum_weak_table (scm_t_weak_table *table) -{ - scm_t_weak_entry *entries = table->entries; - unsigned long size = table->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 || !copy.value) - /* Lost weak reference; reshuffle. */ - { - give_to_poor (table, k); - table->n_items--; - } - } - } - - if (table->n_items < table->lower) - resize_table (table); -} - - - - -static SCM -weak_table_ref (scm_t_weak_table *table, unsigned long hash, - scm_t_table_predicate_fn pred, void *closure, - SCM dflt) -{ - unsigned long k, distance, size; - scm_t_weak_entry *entries; - - size = table->size; - entries = table->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 || !copy.value) - /* Lost weak reference; reshuffle. */ - { - give_to_poor (table, k); - table->n_items--; - goto retry; - } - - if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) - /* Found. */ - return SCM_PACK (copy.value); - } - - /* If the entry's distance is less, our key is not in the table. */ - if (entry_distance (other_hash, k, size) < distance) - return dflt; - } - - /* If we got here, then we were unfortunate enough to loop through the - whole table. Shouldn't happen, but hey. */ - return dflt; -} - - -static void -weak_table_put_x (scm_t_weak_table *table, unsigned long hash, - scm_t_table_predicate_fn pred, void *closure, - SCM key, SCM value) -{ - unsigned long k, distance, size; - scm_t_weak_entry *entries; - - size = table->size; - entries = table->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 || !copy.value) - /* Lost weak reference; reshuffle. */ - { - give_to_poor (table, k); - table->n_items--; - goto retry; - } - - if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) - /* Found an entry with this key. */ - break; - } - - if (table->n_items > table->upper) - /* Full table, time to resize. */ - { - resize_table (table); - return weak_table_put_x (table, hash >> 1, pred, closure, key, value); - } - - /* Displace the entry if our distance is less, otherwise keep - looking. */ - if (entry_distance (other_hash, k, size) < distance) - { - rob_from_rich (table, k); - break; - } - } - - /* Fast path for updated values for existing entries of weak-key - tables. */ - if (table->kind == SCM_WEAK_TABLE_KIND_KEY && - entries[k].hash == hash && - entries[k].key == SCM_UNPACK (key)) - { - entries[k].value = SCM_UNPACK (value); - return; - } - - if (entries[k].hash) - unregister_disappearing_links (&entries[k], table->kind); - else - table->n_items++; - - entries[k].hash = hash; - entries[k].key = SCM_UNPACK (key); - entries[k].value = SCM_UNPACK (value); - - register_disappearing_links (&entries[k], key, value, table->kind); -} - - -static void -weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, - scm_t_table_predicate_fn pred, void *closure) -{ - unsigned long k, distance, size; - scm_t_weak_entry *entries; - - size = table->size; - entries = table->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 || !copy.value) - /* Lost weak reference; reshuffle. */ - { - give_to_poor (table, k); - table->n_items--; - goto retry; - } - - if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) - /* Found an entry with this key. */ - { - entries[k].hash = 0; - entries[k].key = 0; - entries[k].value = 0; - - unregister_disappearing_links (&entries[k], table->kind); - - if (--table->n_items < table->lower) - resize_table (table); - else - give_to_poor (table, k); - - return; - } - } - - /* If the entry's distance is less, our key is not in the table. */ - if (entry_distance (other_hash, k, size) < distance) - return; - } -} - - - -static SCM -make_weak_table (unsigned long k, scm_t_weak_table_kind kind) -{ - scm_t_weak_table *table; - - int i = 0, n = k ? k : 31; - while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) - ++i; - n = hashtable_size[i]; - - table = scm_gc_malloc (sizeof (*table), "weak-table"); - table->entries = allocate_entries (n, kind); - table->kind = kind; - table->n_items = 0; - table->size = n; - table->lower = 0; - table->upper = 9 * n / 10; - table->size_index = i; - table->min_size_index = i; - scm_i_pthread_mutex_init (&table->lock, NULL); - - return scm_cell (scm_tc7_weak_table, (scm_t_bits)table); -} - -void -scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_puts ("#<", port); - scm_puts ("weak-table ", port); - scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); - scm_putc ('/', port); - scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); - scm_puts (">", port); -} - -static void -do_vacuum_weak_table (SCM table) -{ - scm_t_weak_table *t; - - t = SCM_WEAK_TABLE (table); - - /* Unlike weak sets, the weak table interface allows custom predicates - to call out to arbitrary Scheme. There are two ways that this code - can be re-entrant, then: calling weak hash procedures while in a - custom predicate, or via finalizers run explicitly by (gc) or in an - async (for non-threaded Guile). We add a restriction that - prohibits the first case, by convention. But since we can't - prohibit the second case, here we trylock instead of lock. Not so - nice. */ - if (scm_i_pthread_mutex_trylock (&t->lock) == 0) - { - vacuum_weak_table (t); - scm_i_pthread_mutex_unlock (&t->lock); - } - - return; -} - -static scm_i_pthread_mutex_t all_weak_tables_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -static SCM all_weak_tables = SCM_EOL; - -static void -vacuum_all_weak_tables (void) -{ - scm_i_pthread_mutex_lock (&all_weak_tables_lock); - scm_i_visit_weak_list (&all_weak_tables, do_vacuum_weak_table); - scm_i_pthread_mutex_unlock (&all_weak_tables_lock); -} - -SCM -scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) -{ - SCM ret; - - ret = make_weak_table (k, kind); - - scm_i_pthread_mutex_lock (&all_weak_tables_lock); - all_weak_tables = scm_i_weak_cons (ret, all_weak_tables); - scm_i_pthread_mutex_unlock (&all_weak_tables_lock); - - return ret; -} - -SCM -scm_weak_table_p (SCM obj) -{ - return scm_from_bool (SCM_WEAK_TABLE_P (obj)); -} - -SCM -scm_c_weak_table_ref (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure, SCM dflt) -#define FUNC_NAME "weak-table-ref" -{ - SCM ret; - scm_t_weak_table *t; - - SCM_VALIDATE_WEAK_TABLE (1, table); - - t = SCM_WEAK_TABLE (table); - - scm_i_pthread_mutex_lock (&t->lock); - - ret = weak_table_ref (t, raw_hash, pred, closure, dflt); - - scm_i_pthread_mutex_unlock (&t->lock); - - return ret; -} -#undef FUNC_NAME - -void -scm_c_weak_table_put_x (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure, SCM key, SCM value) -#define FUNC_NAME "weak-table-put!" -{ - scm_t_weak_table *t; - - SCM_VALIDATE_WEAK_TABLE (1, table); - - t = SCM_WEAK_TABLE (table); - - scm_i_pthread_mutex_lock (&t->lock); - - weak_table_put_x (t, raw_hash, pred, closure, key, value); - - scm_i_pthread_mutex_unlock (&t->lock); -} -#undef FUNC_NAME - -void -scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure) -#define FUNC_NAME "weak-table-remove!" -{ - scm_t_weak_table *t; - - SCM_VALIDATE_WEAK_TABLE (1, table); - - t = SCM_WEAK_TABLE (table); - - scm_i_pthread_mutex_lock (&t->lock); - - weak_table_remove_x (t, raw_hash, pred, closure); - - scm_i_pthread_mutex_unlock (&t->lock); -} -#undef FUNC_NAME - -static int -assq_predicate (SCM x, SCM y, void *closure) -{ - return scm_is_eq (x, SCM_PACK_POINTER (closure)); -} - -SCM -scm_weak_table_refq (SCM table, SCM key, SCM dflt) -{ - return scm_c_weak_table_ref (table, scm_ihashq (key, -1), - assq_predicate, SCM_UNPACK_POINTER (key), - dflt); -} - -void -scm_weak_table_putq_x (SCM table, SCM key, SCM value) -{ - scm_c_weak_table_put_x (table, scm_ihashq (key, -1), - assq_predicate, SCM_UNPACK_POINTER (key), - key, value); -} - -void -scm_weak_table_remq_x (SCM table, SCM key) -{ - scm_c_weak_table_remove_x (table, scm_ihashq (key, -1), - assq_predicate, SCM_UNPACK_POINTER (key)); -} - -void -scm_weak_table_clear_x (SCM table) -#define FUNC_NAME "weak-table-clear!" -{ - scm_t_weak_table *t; - - SCM_VALIDATE_WEAK_TABLE (1, table); - - t = SCM_WEAK_TABLE (table); - - scm_i_pthread_mutex_lock (&t->lock); - - memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size); - t->n_items = 0; - - scm_i_pthread_mutex_unlock (&t->lock); -} -#undef FUNC_NAME - -SCM -scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure, - SCM init, SCM table) -{ - scm_t_weak_table *t; - scm_t_weak_entry *entries; - unsigned long k, size; - - t = SCM_WEAK_TABLE (table); - - scm_i_pthread_mutex_lock (&t->lock); - - size = t->size; - entries = t->entries; - - for (k = 0; k < size; k++) - { - if (entries[k].hash) - { - scm_t_weak_entry copy; - - copy_weak_entry (&entries[k], ©); - - if (copy.key && copy.value) - { - /* Release table lock while we call the function. */ - scm_i_pthread_mutex_unlock (&t->lock); - init = proc (closure, - SCM_PACK (copy.key), SCM_PACK (copy.value), - init); - scm_i_pthread_mutex_lock (&t->lock); - } - } - } - - scm_i_pthread_mutex_unlock (&t->lock); - - return init; -} - -static SCM -fold_trampoline (void *closure, SCM k, SCM v, SCM init) -{ - return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init); -} - -SCM -scm_weak_table_fold (SCM proc, SCM init, SCM table) -#define FUNC_NAME "weak-table-fold" -{ - SCM_VALIDATE_WEAK_TABLE (3, table); - SCM_VALIDATE_PROC (1, proc); - - return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table); -} -#undef FUNC_NAME - -static SCM -for_each_trampoline (void *closure, SCM k, SCM v, SCM seed) -{ - scm_call_2 (SCM_PACK_POINTER (closure), k, v); - return seed; -} - -void -scm_weak_table_for_each (SCM proc, SCM table) -#define FUNC_NAME "weak-table-for-each" -{ - SCM_VALIDATE_WEAK_TABLE (2, table); - SCM_VALIDATE_PROC (1, proc); - - scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table); -} -#undef FUNC_NAME - -static SCM -map_trampoline (void *closure, SCM k, SCM v, SCM seed) -{ - return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed); -} - -SCM -scm_weak_table_map_to_list (SCM proc, SCM table) -#define FUNC_NAME "weak-table-map->list" -{ - SCM_VALIDATE_WEAK_TABLE (2, table); - SCM_VALIDATE_PROC (1, proc); - - return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table); -} -#undef FUNC_NAME - - - - -/* Legacy interface. */ - -SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, - (SCM n), - "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" - "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" - "Return a weak hash table with @var{size} buckets.\n" - "\n" - "You can modify weak hash tables in exactly the same way you\n" - "would modify regular hash tables. (@pxref{Hash Tables})") -#define FUNC_NAME s_scm_make_weak_key_hash_table -{ - return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), - SCM_WEAK_TABLE_KIND_KEY); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, - (SCM n), - "Return a hash table with weak values with @var{size} buckets.\n" - "(@pxref{Hash Tables})") -#define FUNC_NAME s_scm_make_weak_value_hash_table -{ - return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), - SCM_WEAK_TABLE_KIND_VALUE); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 0, - (SCM n), - "Return a hash table with weak keys and values with @var{size}\n" - "buckets. (@pxref{Hash Tables})") -#define FUNC_NAME s_scm_make_doubly_weak_hash_table -{ - return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), - SCM_WEAK_TABLE_KIND_BOTH); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, - (SCM obj), - "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" - "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n" - "Return @code{#t} if @var{obj} is the specified weak hash\n" - "table. Note that a doubly weak hash table is neither a weak key\n" - "nor a weak value hash table.") -#define FUNC_NAME s_scm_weak_key_hash_table_p -{ - return scm_from_bool (SCM_WEAK_TABLE_P (obj) && - SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a weak value hash table.") -#define FUNC_NAME s_scm_weak_value_hash_table_p -{ - return scm_from_bool (SCM_WEAK_TABLE_P (obj) && - SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a doubly weak hash table.") -#define FUNC_NAME s_scm_doubly_weak_hash_table_p -{ - return scm_from_bool (SCM_WEAK_TABLE_P (obj) && - SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH); -} -#undef FUNC_NAME - - - - - -void -scm_weak_table_prehistory (void) -{ - weak_key_gc_kind = - GC_new_kind (GC_new_free_list (), - GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0), - 0, 0); - weak_value_gc_kind = - GC_new_kind (GC_new_free_list (), - GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0), - 0, 0); -} - -void -scm_init_weak_table () -{ -#include "libguile/weak-table.x" - - scm_i_register_async_gc_callback (vacuum_all_weak_tables); -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/weak-table.h b/libguile/weak-table.h deleted file mode 100644 index f516c2601..000000000 --- a/libguile/weak-table.h +++ /dev/null @@ -1,94 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_WEAK_TABLE_H -#define SCM_WEAK_TABLE_H - -/* Copyright (C) 2011, 2012 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#include "libguile/__scm.h" - - - -/* The weak table API is currently only used internally. We could make it - public later, after some API review. */ - -typedef enum { - SCM_WEAK_TABLE_KIND_KEY, - SCM_WEAK_TABLE_KIND_VALUE, - SCM_WEAK_TABLE_KIND_BOTH, -} scm_t_weak_table_kind; - -/* Function that returns nonzero if the given mapping is the one we are - looking for. */ -typedef int (*scm_t_table_predicate_fn) (SCM k, SCM v, void *closure); - -/* Function to fold over the elements of a set. */ -typedef SCM (*scm_t_table_fold_fn) (void *closure, SCM k, SCM v, SCM result); - -SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k, - scm_t_weak_table_kind kind); -SCM_INTERNAL SCM scm_weak_table_p (SCM h); - -SCM_INTERNAL SCM scm_c_weak_table_ref (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure, SCM dflt); -SCM_INTERNAL void scm_c_weak_table_put_x (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure, SCM key, SCM value); -SCM_INTERNAL void scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash, - scm_t_table_predicate_fn pred, - void *closure); - -SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt); -SCM_INTERNAL void scm_weak_table_putq_x (SCM table, SCM key, SCM value); -SCM_INTERNAL void scm_weak_table_remq_x (SCM table, SCM key); - -SCM_INTERNAL void scm_weak_table_clear_x (SCM table); - -SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure, - SCM init, SCM table); -SCM_INTERNAL SCM scm_weak_table_fold (SCM proc, SCM init, SCM table); -SCM_INTERNAL void scm_weak_table_for_each (SCM proc, SCM table); -SCM_INTERNAL SCM scm_weak_table_map_to_list (SCM proc, SCM table); - - - -/* Legacy interface. */ -SCM_API SCM scm_make_weak_key_hash_table (SCM k); -SCM_API SCM scm_make_weak_value_hash_table (SCM k); -SCM_API SCM scm_make_doubly_weak_hash_table (SCM k); -SCM_API SCM scm_weak_key_hash_table_p (SCM h); -SCM_API SCM scm_weak_value_hash_table_p (SCM h); -SCM_API SCM scm_doubly_weak_hash_table_p (SCM h); - - - -SCM_INTERNAL void scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate); -SCM_INTERNAL void scm_weak_table_prehistory (void); -SCM_INTERNAL void scm_init_weak_table (void); - -#endif /* SCM_WEAK_TABLE_H */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 49aea27ba..14bf5a9b2 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -260,7 +260,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc7-vm-continuation #x47) (define %tc7-bytevector #x4d) (define %tc7-weak-set #x55) -(define %tc7-weak-table #x57) +(define %tc7-weak-table #x57) ;no longer used (define %tc7-array #x5d) (define %tc7-bitvector #x5f) (define %tc7-port #x7d) diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 446aff541..336350f9a 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -1,6 +1,6 @@ ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. ;;;; ;;;; This file is part of GNU Guile. ;;;; @@ -103,9 +103,10 @@ ((lambda () #t) program _) ((make-variable 'foo) variable _) ((make-weak-vector 3 #t) weak-vector _) - ((make-weak-key-hash-table) weak-table _) - ((make-weak-value-hash-table) weak-table _) - ((make-doubly-weak-hash-table) weak-table _) + ((make-hash-table) hash-table _) + ((make-weak-key-hash-table) hash-table _) + ((make-weak-value-hash-table) hash-table _) + ((make-doubly-weak-hash-table) hash-table _) (#2((1 2 3) (4 5 6)) array _) (#*00000110 bitvector _) ((expt 2 70) bignum _) -- 2.14.2
>From 1192255df58026dc6dea6bc0ad7ee823c16a72ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org> Date: Sun, 22 Oct 2017 16:56:51 -0700 Subject: [PATCH 2/2] Keep weak hash table item count consistent. Fixes a TOCTTOU kind of bug whereby we'd first count the number of items deleted from the table, and later, *without* having the alloc lock, we'd update the table's item count. The problem is that the item count could have been updated in the meantime, hence the bug. Fixes <https://bugs.gnu.org/19180>. * libguile/hashtab.c (vacuum_weak_hash_table): Rename to... (do_vacuum_weak_hash_table): ... this. Unmarshall the void* argument. Replace 'fprintf' warning with an assertion. (vacuum_weak_hash_table): New function. Call the above with 'GC_call_with_alloc_lock'. (t_fixup_args): Add 'table' field; remove 'removed_items'. (do_weak_bucket_fixup): Update TABLE's 'n_items' field. (weak_bucket_assoc): Check 'SCM_HASHTABLE_N_ITEMS' instead of 'args.removed_items'. --- libguile/hashtab.c | 68 +++++++++++++++++++++++++++--------------------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 86b9ca386..c06283339 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -96,7 +96,7 @@ static char *s_hashtable = "hashtable"; /* Remove nullified weak pairs from ALIST such that the result contains only valid pairs. Set REMOVED_ITEMS to the number of pairs that have been - deleted. */ + deleted. Assumes the allocation lock is already taken. */ static SCM scm_fixup_weak_alist (SCM alist, size_t *removed_items) { @@ -130,9 +130,10 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items) return result; } -static void -vacuum_weak_hash_table (SCM table) +static void * +do_vacuum_weak_hash_table (void *arg) { + SCM table = SCM_PACK_POINTER (arg); SCM buckets = SCM_HASHTABLE_VECTOR (table); unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets); size_t len = SCM_HASHTABLE_N_ITEMS (table); @@ -142,44 +143,52 @@ vacuum_weak_hash_table (SCM table) size_t removed; SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k); alist = scm_fixup_weak_alist (alist, &removed); - if (removed <= len) - len -= removed; - else - { - /* The move to BDW-GC with Guile 2.0 introduced some bugs - related to weak hash tables, threads, memory usage, and the - alloc lock. We were unable to fix these issues - satisfactorily in 2.0 but have addressed them via a rewrite - in 2.2. If you see this message often, you probably want - to upgrade to 2.2. */ - fprintf (stderr, "guile: warning: weak hash table corruption " - "(https://bugs.gnu.org/19180)\n"); - len = 0; - } + + /* The alloc lock is taken, so we cannot get REMOVED > LEN. If we + do, that means we messed up while counting items. */ + assert (removed <= len); + SCM_SIMPLE_VECTOR_SET (buckets, k, alist); } SCM_SET_HASHTABLE_N_ITEMS (table, len); + + return table; +} + +/* Remove deleted weak pairs from the buckets of TABLE, and update + TABLE's item count accordingly. */ +static void +vacuum_weak_hash_table (SCM table) +{ + /* Take the alloc lock so we have a consistent view of the live + elements in TABLE. Failing to do that, we could be miscounting the + number of elements. */ + GC_call_with_alloc_lock (do_vacuum_weak_hash_table, + SCM_PACK (table)); } + /* Packed arguments for `do_weak_bucket_fixup'. */ struct t_fixup_args { + SCM table; SCM bucket; SCM *bucket_copy; - size_t removed_items; }; static void * do_weak_bucket_fixup (void *data) { - struct t_fixup_args *args; SCM pair, *copy; + size_t len, removed_items; + struct t_fixup_args *args = (struct t_fixup_args *) data; - args = (struct t_fixup_args *) data; + args->bucket = scm_fixup_weak_alist (args->bucket, &removed_items); - args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items); + len = SCM_HASHTABLE_N_ITEMS (args->table); + SCM_SET_HASHTABLE_N_ITEMS (args->table, len - removed_items); for (pair = args->bucket, copy = args->bucket_copy; scm_is_pair (pair); @@ -214,6 +223,7 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index, and values in BUCKET. */ strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM)); + args.table = table; args.bucket = bucket; args.bucket_copy = strong_refs; @@ -239,19 +249,9 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index, scm_remember_upto_here_1 (strong_refs); - if (args.removed_items > 0) - { - /* Update TABLE's item count and optionally trigger a rehash. */ - size_t remaining; - - assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items); - - remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items; - SCM_SET_HASHTABLE_N_ITEMS (table, remaining); - - if (remaining < SCM_HASHTABLE_LOWER (table)) - scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc"); - } + if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) + /* Trigger a rehash. */ + scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc"); return result; } -- 2.14.2
