>From 49cb10e6f054a202ffc47109d0f9d88df9546b70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 21 Oct 2017 16:18:39 -0600 Subject: [PATCH] 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 . * libguile.h: Don't include "weak-table.h". * libguile/Makefile.am (address@hidden@_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 | 48 ++- libguile/init.c | 4 +- libguile/print.c | 5 +- libguile/procprop.c | 4 +- libguile/tags.h | 3 +- libguile/weak-list.h | 32 +- module/system/base/types.scm | 2 +- test-suite/tests/types.test | 9 +- 12 files changed, 809 insertions(+), 188 deletions(-) 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 @@ address@hidden@_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..6402e5a39 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 +#include + +/* 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)"); + 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 ("#= 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..19caea5dc 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,34 @@ #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 = 1, + SCM_WEAK_TABLE_KIND_VALUE = 2, + SCM_WEAK_TABLE_KIND_BOTH = 1 | 2 +} 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_KEY | SCM_WEAK_TABLE_KIND_VALUE)) \ + == (SCM_WEAK_TABLE_KIND_KEY | SCM_WEAK_TABLE_KIND_VALUE)) +#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 +75,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 +88,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 { + int 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 +102,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 +119,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 +173,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 7667d24bb..2ed721919 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014, 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 @@ -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/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