diff options
Diffstat (limited to 'libguile/hashtab.c')
-rw-r--r-- | libguile/hashtab.c | 322 |
1 files changed, 208 insertions, 114 deletions
diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 2fe09196c..633d26261 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -30,6 +30,8 @@ #include "libguile/validate.h" #include "libguile/hashtab.h" + + /* NOTES @@ -78,8 +80,99 @@ static unsigned long hashtable_size[] = { static char *s_hashtable = "hashtable"; -SCM weak_hashtables = SCM_EOL; + +/* 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. */ + + +/* Return a ``usable'' version of ALIST, an alist of weak pairs. By + ``usable'', we mean that it contains only valid Scheme objects. On + return, REMOVE_ITEMS is set to the number of pairs that have been + deleted. */ +static SCM +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); + prev = alist, alist = SCM_CDR (alist)) + { + SCM pair = SCM_CAR (alist); + + if (scm_is_pair (pair)) + { + if (SCM_WEAK_PAIR_DELETED_P (pair)) + { + /* Remove from ALIST weak pair PAIR whose car/cdr has been + nullified by the GC. */ + if (prev == SCM_EOL) + result = SCM_CDR (alist); + else + SCM_SETCDR (prev, SCM_CDR (alist)); + + (*removed_items)++; + continue; + } + } + } + + return result; +} + + +/* Helper macros. */ + +/* Return true if OBJ is either a weak hash table or a weak alist vector (as + defined in `weaks.[ch]'). + FIXME: We should eventually keep only weah hash tables. Actually, the + procs in `weaks.c' already no longer return vectors. */ +/* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */ +#define IS_WEAK_THING(_obj) \ + ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \ + || (SCM_I_IS_VECTOR (table))) + + + +/* Fixup BUCKET, an alist part of weak hash table OBJ. BUCKETS is the full + bucket vector for OBJ and IDX is the index of BUCKET within this + vector. See also `scm_internal_hash_fold ()'. */ +#define START_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \ +do \ + { \ + size_t _removed; \ + \ + /* Disable the GC so that BUCKET remains valid until ASSOC_FN has \ + returned. */ \ + /* FIXME: We could maybe trigger a rehash here depending on whether \ + `scm_fixup_weak_alist ()' noticed some change. */ \ + GC_disable (); \ + (_bucket) = scm_fixup_weak_alist ((_bucket), &_removed); \ + SCM_SIMPLE_VECTOR_SET ((_buckets), (_idx), (_bucket)); \ + \ + if ((_removed) && (SCM_HASHTABLE_P (_obj))) \ + { \ + SCM_SET_HASHTABLE_N_ITEMS ((_obj), \ + SCM_HASHTABLE_N_ITEMS (_obj) - _removed); \ + scm_i_rehash ((_obj), (_hashfn), \ + NULL, "START_WEAK_BUCKET_FIXUP"); \ + } \ + } \ +while (0) + +/* Terminate a weak bucket fixup phase. */ +#define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \ + do { GC_enable (); } while (0) + + + static SCM make_hash_table (int flags, unsigned long k, const char *func_name) { @@ -89,24 +182,22 @@ make_hash_table (int flags, unsigned long k, const char *func_name) while (i < HASHTABLE_SIZE_N && n > hashtable_size[i]) ++i; n = hashtable_size[i]; - if (flags) - vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL); - else - vector = scm_c_make_vector (n, SCM_EOL); - t = scm_gc_malloc (sizeof (*t), s_hashtable); + + /* 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); t->min_size_index = t->size_index = i; t->n_items = 0; t->lower = 0; t->upper = 9 * n / 10; t->flags = flags; t->hash_fn = NULL; - if (flags) - { - SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables); - weak_hashtables = table; - } - else - SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL); + + SCM_NEWSMOB2 (table, scm_tc16_hashtable, vector, t); + return table; } @@ -153,13 +244,8 @@ scm_i_rehash (SCM table, SCM_HASHTABLE (table)->lower = new_size / 4; SCM_HASHTABLE (table)->upper = 9 * new_size / 10; buckets = SCM_HASHTABLE_VECTOR (table); - - if (SCM_HASHTABLE_WEAK_P (table)) - new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table), - scm_from_ulong (new_size), - SCM_EOL); - else - new_buckets = scm_c_make_vector (new_size, SCM_EOL); + + 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 @@ -182,9 +268,15 @@ scm_i_rehash (SCM table, while (scm_is_pair (ls)) { unsigned long h; + cell = ls; 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)); @@ -215,81 +307,6 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } -#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) - -/* keep track of hash tables that need to shrink after scan */ -static SCM to_rehash = SCM_EOL; - -/* scan hash tables and update hash tables item count */ -void -scm_i_scan_weak_hashtables () -{ - SCM *next = &weak_hashtables; - SCM h = *next; - while (!scm_is_null (h)) - { - if (!SCM_GC_MARK_P (h)) - *next = h = SCM_HASHTABLE_NEXT (h); - else - { - SCM vec = SCM_HASHTABLE_VECTOR (h); - size_t delta = SCM_I_WVECT_DELTA (vec); - SCM_I_SET_WVECT_DELTA (vec, 0); - SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta); - - if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h)) - { - SCM tmp = SCM_HASHTABLE_NEXT (h); - /* temporarily move table from weak_hashtables to to_rehash */ - SCM_SET_HASHTABLE_NEXT (h, to_rehash); - to_rehash = h; - *next = h = tmp; - } - else - { - next = SCM_HASHTABLE_NEXTLOC (h); - h = SCM_HASHTABLE_NEXT (h); - } - } - } -} - -static void * -rehash_after_gc (void *dummy1 SCM_UNUSED, - void *dummy2 SCM_UNUSED, - void *dummy3 SCM_UNUSED) -{ - if (!scm_is_null (to_rehash)) - { - SCM first = to_rehash, last, h; - /* important to clear to_rehash here so that we don't get stuck - in an infinite loop if scm_i_rehash causes GC */ - to_rehash = SCM_EOL; - h = first; - do - { - /* Rehash only when we have a hash_fn. - */ - if (SCM_HASHTABLE (h)->hash_fn) - scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL, - "rehash_after_gc"); - last = h; - h = SCM_HASHTABLE_NEXT (h); - } while (!scm_is_null (h)); - /* move tables back to weak_hashtables */ - SCM_SET_HASHTABLE_NEXT (last, weak_hashtables); - weak_hashtables = first; - } - return 0; -} - -static size_t -hashtable_free (SCM obj) -{ - scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable); - return 0; -} - SCM scm_c_make_hash_table (unsigned long k) @@ -413,19 +430,34 @@ SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure) #define FUNC_NAME "scm_hash_fn_get_handle" { + int weak = 0; unsigned long k; - SCM h; + SCM buckets, alist, h; if (SCM_HASHTABLE_P (table)) - table = SCM_HASHTABLE_VECTOR (table); + buckets = SCM_HASHTABLE_VECTOR (table); else - SCM_VALIDATE_VECTOR (1, table); - if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0) + { + SCM_VALIDATE_VECTOR (1, table); + buckets = table; + } + + if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) return SCM_BOOL_F; - k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure); - if (k >= SCM_SIMPLE_VECTOR_LENGTH (table)) + k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); + if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure); + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + h = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + return h; } #undef FUNC_NAME @@ -436,8 +468,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ SCM (*assoc_fn)(), void * closure) #define FUNC_NAME "scm_hash_fn_create_handle_x" { + int weak = 0; unsigned long k; - SCM buckets, it; + SCM buckets, alist, it; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -453,7 +486,16 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); 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); + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + it = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + if (scm_is_true (it)) return it; else @@ -464,7 +506,25 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ again since the hashtable might have been rehashed. This necessitates a new hash value as well. */ - SCM new_bucket = scm_acons (obj, init, SCM_EOL); + SCM handle, new_bucket; + + if ((SCM_HASHTABLE_P (table)) && (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 (table, buckets) && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets)) { @@ -519,14 +579,15 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(), } -SCM +SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void *closure) { + int weak = 0; unsigned long k; - SCM buckets, h; + SCM buckets, alist, h; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -542,7 +603,16 @@ scm_hash_fn_remove_x (SCM table, SCM obj, k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + h = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + if (scm_is_true (h)) { SCM_SIMPLE_VECTOR_SET @@ -917,21 +987,47 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); else + /* Weak alist vector. */ buckets = table; n = SCM_SIMPLE_VECTOR_LENGTH (buckets); for (i = 0; i < n; ++i) { - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; - while (!scm_is_null (ls)) + SCM prev, ls; + + for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i); + !scm_is_null (ls); + prev = ls, ls = SCM_CDR (ls)) { + SCM handle; + if (!scm_is_pair (ls)) scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + handle = SCM_CAR (ls); if (!scm_is_pair (handle)) scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + + if (IS_WEAK_THING (table)) + { + if (SCM_WEAK_PAIR_DELETED_P (handle)) + { + /* We hit a weak pair whose car/cdr has become + unreachable: unlink it from the bucket. */ + if (prev != SCM_BOOL_F) + SCM_SETCDR (prev, SCM_CDR (ls)); + else + SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls)); + + if (SCM_HASHTABLE_P (table)) + /* Update the item count. */ + SCM_HASHTABLE_DECREMENT (table); + + continue; + } + } + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); - ls = SCM_CDR (ls); } } @@ -1066,11 +1162,9 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, void scm_hashtab_prehistory () { + /* Initialize the hashtab SMOB type. */ scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0); - scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr); scm_set_smob_print (scm_tc16_hashtable, hashtable_print); - scm_set_smob_free (scm_tc16_hashtable, hashtable_free); - scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0); } void |