#include "libguile/validate.h"
#include "libguile/hashtab.h"
+
+
\f
/* NOTES
static char *s_hashtable = "hashtable";
-SCM weak_hashtables = SCM_EOL;
\f
-/* Weak cells for use in weak alist vectors (aka. weak hash tables). */
+/* Helper functions and macros to deal with weak pairs.
-static SCM
-scm_weak_car_cell (SCM car, SCM cdr)
-{
- 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))
- {
- /* Weak car cells make sense iff the car is non-immediate. */
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
- (GC_PTR)SCM_UNPACK (car));
- }
-
- return (SCM_PACK (cell));
-}
-
-static SCM
-scm_weak_cdr_cell (SCM car, SCM cdr)
-{
- 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 (cdr))
- {
- /* Weak cdr cells make sense iff the cdr is non-immediate. */
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
- (GC_PTR)SCM_UNPACK (cdr));
- }
-
- return (SCM_PACK (cell));
-}
-
-static SCM
-scm_doubly_weak_cell (SCM car, SCM cdr)
-{
- 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))
- {
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
- (GC_PTR)SCM_UNPACK (car));
- }
- if (SCM_NIMP (cdr))
- {
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
- (GC_PTR)SCM_UNPACK (cdr));
- }
-
- return (SCM_PACK (cell));
-}
-
-/* Testing the weak component(s) of a cell for reachability. */
-#define SCM_WEAK_CELL_WORD_DELETED_P(_cell, _word) \
- (SCM_CELL_WORD ((_cell), (_word)) == SCM_PACK (NULL))
-#define SCM_WEAK_CELL_CAR_DELETED_P(_cell) \
- (SCM_WEAK_CELL_WORD_DELETED_P ((_cell), 0))
-#define SCM_WEAK_CELL_CDR_DELETED_P(_cell) \
- (SCM_WEAK_CELL_WORD_DELETED_P ((_cell), 1))
-
-/* Accessing the components of a weak cell. */
-#define SCM_WEAK_CELL_WORD(_cell, _word) \
- ((SCM_WEAK_CELL_WORD_DELETED_P ((_cell), (_word))) \
- ? SCM_BOOL_F : SCM_CAR (pair))
-#define SCM_WEAK_CELL_CAR(_cell) (SCM_WEAK_CELL_WORD ((_cell), 0))
-#define SCM_WEAK_CELL_CDR(_cell) (SCM_WEAK_CELL_WORD ((_cell), 1))
+ 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. */
+ ``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)
+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))
if (scm_is_pair (pair))
{
- if ((SCM_WEAK_CELL_CAR_DELETED_P (pair))
- || (SCM_WEAK_CELL_CDR_DELETED_P (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 = alist;
+ 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)
+
+
\f
static SCM
make_hash_table (int flags, unsigned long k, const char *func_name)
t->upper = 9 * n / 10;
t->flags = flags;
t->hash_fn = NULL;
- if (flags)
- {
- /* FIXME: We should eventually remove WEAK_HASHTABLES. */
- 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;
}
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));
return 1;
}
-/* FIXME */
-#define UNMARKED_CELL_P(x) 0 /* (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 ()
-{
-#if 0 /* FIXME */
- 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);
- }
- }
- }
-#endif
-}
-
-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)
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 alist, 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));
- alist = SCM_SIMPLE_VECTOR_REF (table, k);
+ weak = IS_WEAK_THING (table);
+ alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- /* XXX: We assume that if TABLE is a vector, then it's a weak vector. */
- if ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table)))
- || (SCM_I_IS_VECTOR (table)))
- /* FIXME: We could maybe trigger a rehash here depending on whether
- `scm_fixup_weak_alist ()' noticed some change. */
- alist = scm_fixup_weak_alist (alist);
+ 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
SCM (*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
+ int weak = 0;
unsigned long k;
SCM buckets, alist, it;
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
+ weak = IS_WEAK_THING (table);
alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- if ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table)))
- || (SCM_I_IS_VECTOR (table)))
- alist = scm_fixup_weak_alist (alist);
+ 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
*/
SCM handle, new_bucket;
- if ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table)))
- || (SCM_I_IS_VECTOR (table)))
+ 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_cell (obj, init);
+ handle = scm_doubly_weak_pair (obj, init);
else if (SCM_HASHTABLE_WEAK_KEY_P (table))
- handle = scm_weak_car_cell (obj, init);
+ handle = scm_weak_car_pair (obj, init);
else
- handle = scm_weak_cdr_cell (obj, init);
+ handle = scm_weak_cdr_pair (obj, init);
}
else
/* Use a regular, non-weak cell. */
}
-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, alist, h;
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
+ weak = IS_WEAK_THING (table);
alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- if ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table)))
- || (SCM_I_IS_VECTOR (table)))
- alist = scm_fixup_weak_alist (alist);
+ 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
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);
}
}
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
HCoop / bpt / guile.git / blobdiff