diff options
Diffstat (limited to 'libguile/weak-table.c')
-rw-r--r-- | libguile/weak-table.c | 845 |
1 files changed, 845 insertions, 0 deletions
diff --git a/libguile/weak-table.c b/libguile/weak-table.c new file mode 100644 index 000000000..1e4d8d302 --- /dev/null +++ b/libguile/weak-table.c @@ -0,0 +1,845 @@ +/* Copyright 2011-2014,2017-2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <assert.h> + +#include "alist.h" +#include "bdw-gc.h" +#include "eval.h" +#include "finalizers.h" +#include "gsubr.h" +#include "hash.h" +#include "numbers.h" +#include "pairs.h" +#include "ports.h" +#include "procs.h" +#include "threads.h" +#include "weak-list.h" + +#include "weak-table.h" + +#include <gc/gc_typed.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. + + This is a normal bucket-and-chain hash table, except that the chain + entries are 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. + + Note that since the weak references are stored in an atomic region + with disappearing links, they need to be accessed with the GC alloc + lock. `read_weak_entry' will do that for you. The hash code itself + can be read outside the lock, though. + */ + + +typedef struct scm_weak_entry scm_t_weak_entry; + +struct scm_weak_entry { + unsigned long hash; + scm_t_weak_entry *next; + scm_t_bits key; + scm_t_bits value; +}; + + +struct weak_entry_data { + scm_t_weak_entry *entry; + scm_t_bits key; + scm_t_bits value; +}; + +static void* +do_read_weak_entry (void *data) +{ + struct weak_entry_data *e = data; + + e->key = e->entry->key; + e->value = e->entry->value; + + return NULL; +} + +static void +read_weak_entry (scm_t_weak_entry *entry, scm_t_bits *key, scm_t_bits *value) +{ + struct weak_entry_data data; + + data.entry = entry; + GC_call_with_alloc_lock (do_read_weak_entry, &data); + + *key = data.key; + *value = data.value; +} + +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); +} + +typedef struct { + scm_t_weak_entry **buckets; /* the data */ + scm_i_pthread_mutex_t lock; /* the lock */ + scm_t_weak_table_kind kind; /* what kind of table it is */ + unsigned long n_buckets; /* total number of buckets. */ + 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 */ + GC_word last_gc_no; +} 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)) + + + + +/* GC descriptors for the various kinds of scm_t_weak_entry. */ +static GC_descr weak_key_descr; +static GC_descr weak_value_descr; +static GC_descr doubly_weak_descr; + +static scm_t_weak_entry * +allocate_entry (scm_t_weak_table_kind kind) +{ + scm_t_weak_entry *ret; + + switch (kind) + { + case SCM_WEAK_TABLE_KIND_KEY: + ret = GC_malloc_explicitly_typed (sizeof (*ret), weak_key_descr); + break; + case SCM_WEAK_TABLE_KIND_VALUE: + ret = GC_malloc_explicitly_typed (sizeof (*ret), weak_value_descr); + break; + case SCM_WEAK_TABLE_KIND_BOTH: + ret = GC_malloc_explicitly_typed (sizeof (*ret), doubly_weak_descr); + break; + default: + abort (); + } + + return ret; +} + +static void +add_entry (scm_t_weak_table *table, scm_t_weak_entry *entry) +{ + unsigned long bucket = entry->hash % table->n_buckets; + entry->next = table->buckets[bucket]; + table->buckets[bucket] = entry; + table->n_items++; +} + + + +/* 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.25. + * + * 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 void +resize_table (scm_t_weak_table *table) +{ + scm_t_weak_entry **old_buckets, **new_buckets; + int new_size_index; + unsigned long old_n_buckets, new_n_buckets, old_k; + + new_size_index = table->size_index; + if (table->n_items < table->lower) + { + /* Rehashing is not triggered when i <= min_size. */ + do + new_size_index -= 1; + while (new_size_index > table->min_size_index + && table->n_items < hashtable_size[new_size_index] / 4); + } + else if (table->n_items > table->upper) + { + new_size_index += 1; + if (new_size_index >= HASHTABLE_SIZE_N) + /* Limit max bucket count. */ + return; + } + else + /* Nothing to do. */ + return; + + new_n_buckets = hashtable_size[new_size_index]; + new_buckets = scm_gc_malloc (sizeof (*new_buckets) * new_n_buckets, + "weak table buckets"); + + old_buckets = table->buckets; + old_n_buckets = table->n_buckets; + + table->size_index = new_size_index; + table->n_buckets = new_n_buckets; + if (new_size_index <= table->min_size_index) + table->lower = 0; + else + table->lower = new_n_buckets / 4; + table->upper = 9 * new_n_buckets / 10; + table->n_items = 0; + table->buckets = new_buckets; + + for (old_k = 0; old_k < old_n_buckets; old_k++) + { + scm_t_weak_entry *entry = old_buckets[old_k]; + while (entry) + { + scm_t_weak_entry *next = entry->next; + entry->next = NULL; + add_entry (table, entry); + entry = next; + } + } +} + +/* 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 buckets. */ +static void +vacuum_weak_table (scm_t_weak_table *table) +{ + GC_word gc_no = GC_get_gc_no (); + unsigned long k; + + if (gc_no == table->last_gc_no) + return; + + table->last_gc_no = gc_no; + + for (k = 0; k < table->n_buckets; k++) + { + scm_t_weak_entry **loc = table->buckets + k; + scm_t_weak_entry *entry; + + for (entry = *loc; entry; entry = *loc) + { + scm_t_bits key, value; + + read_weak_entry (entry, &key, &value); + if (!key || !value) + /* Lost weak reference; prune entry. */ + { + *loc = entry->next; + table->n_items--; + entry->next = NULL; + unregister_disappearing_links (entry, table->kind); + } + else + loc = &entry->next; + } + } + + 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 bucket = hash % table->n_buckets; + scm_t_weak_entry *entry; + + for (entry = table->buckets[bucket]; entry; entry = entry->next) + { + if (entry->hash == hash) + { + scm_t_bits key, value; + + read_weak_entry (entry, &key, &value); + if (key && value && pred (SCM_PACK (key), SCM_PACK (value), closure)) + /* Found. */ + return SCM_PACK (value); + } + } + + 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 bucket = hash % table->n_buckets; + scm_t_weak_entry *entry; + + for (entry = table->buckets[bucket]; entry; entry = entry->next) + { + if (entry->hash == hash) + { + scm_t_bits k, v; + + read_weak_entry (entry, &k, &v); + if (k && v && pred (SCM_PACK (k), SCM_PACK (v), closure)) + { + unregister_disappearing_links (entry, table->kind); + key = SCM_PACK (k); + entry->value = SCM_UNPACK (value); + register_disappearing_links (entry, key, value, table->kind); + return; + } + } + } + + if (table->n_items > table->upper) + /* Full table, time to resize. */ + resize_table (table); + + entry = allocate_entry (table->kind); + entry->hash = hash; + entry->key = SCM_UNPACK (key); + entry->value = SCM_UNPACK (value); + register_disappearing_links (entry, key, value, table->kind); + add_entry (table, entry); +} + + +static void +weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure) +{ + unsigned long bucket = hash % table->n_buckets; + scm_t_weak_entry **loc = table->buckets + bucket; + scm_t_weak_entry *entry; + + for (entry = *loc; entry; entry = *loc) + { + if (entry->hash == hash) + { + scm_t_bits k, v; + + read_weak_entry (entry, &k, &v); + if (k && v && pred (SCM_PACK (k), SCM_PACK (v), closure)) + { + *loc = entry->next; + table->n_items--; + entry->next = NULL; + unregister_disappearing_links (entry, table->kind); + + if (table->n_items < table->lower) + resize_table (table); + + return; + } + } + loc = &entry->next; + } + + 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->buckets = scm_gc_malloc (sizeof (*table->buckets) * n, + "weak table buckets"); + table->kind = kind; + table->n_items = 0; + table->n_buckets = n; + table->lower = 0; + table->upper = 9 * n / 10; + table->size_index = i; + table->min_size_index = i; + table->last_gc_no = GC_get_gc_no (); + 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)->n_buckets, 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. In any + case, if the mutex is held by another thread, then the table is in + active use, so the next user of the table will handle the vacuum + for us. */ + 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); + + vacuum_weak_table (t); + + 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); + + vacuum_weak_table (t); + + 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); + + vacuum_weak_table (t); + + 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; + unsigned long k; + scm_t_weak_entry *entry; + + SCM_VALIDATE_WEAK_TABLE (1, table); + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + t->last_gc_no = GC_get_gc_no (); + + for (k = 0; k < t->n_buckets; k++) + { + for (entry = t->buckets[k]; entry; entry = entry->next) + unregister_disappearing_links (entry, t->kind); + t->buckets[k] = NULL; + } + 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; + unsigned long k; + SCM alist = SCM_EOL; + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + vacuum_weak_table (t); + + for (k = 0; k < t->n_buckets; k++) + { + scm_t_weak_entry *entry; + for (entry = t->buckets[k]; entry; entry = entry->next) + { + scm_t_bits key, value; + read_weak_entry (entry, &key, &value); + + if (key && value) + alist = scm_acons (SCM_PACK (key), SCM_PACK (value), alist); + } + } + + scm_i_pthread_mutex_unlock (&t->lock); + + /* Call the proc outside the lock. */ + for (; !scm_is_null (alist); alist = scm_cdr (alist)) + init = proc (closure, scm_caar (alist), scm_cdar (alist), init); + + 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) +{ + GC_word weak_key_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 }; + GC_word weak_value_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 }; + GC_word doubly_weak_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 }; + + GC_set_bit (weak_key_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next)); + GC_set_bit (weak_value_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next)); + GC_set_bit (doubly_weak_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next)); + + GC_set_bit (weak_key_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, value)); + GC_set_bit (weak_value_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, key)); + + weak_key_descr = GC_make_descriptor (weak_key_bitmap, + GC_WORD_LEN (scm_t_weak_entry)); + weak_value_descr = GC_make_descriptor (weak_value_bitmap, + GC_WORD_LEN (scm_t_weak_entry)); + doubly_weak_descr = GC_make_descriptor (doubly_weak_bitmap, + GC_WORD_LEN (scm_t_weak_entry)); +} + +void +scm_init_weak_table () +{ +#include "weak-table.x" + + scm_i_register_async_gc_callback (vacuum_all_weak_tables); +} |