diff options
-rw-r--r-- | libguile/hashtab.c | 191 | ||||
-rw-r--r-- | libguile/symbols.c | 13 | ||||
-rw-r--r-- | libguile/vectors.c | 56 | ||||
-rw-r--r-- | libguile/weaks.c | 127 |
4 files changed, 243 insertions, 144 deletions
diff --git a/libguile/hashtab.c b/libguile/hashtab.c index af618e582..27d7a2b7b 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -80,6 +80,121 @@ static char *s_hashtable = "hashtable"; SCM weak_hashtables = SCM_EOL; + +/* Weak cells for use in weak alist vectors (aka. weak hash tables). */ + +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)) + + +/* Return a ``usable'' version of ALIST, an alist of weak pairs. By + ``usable'', we mean that it contains only valid Scheme objects. */ +static SCM +scm_fixup_weak_alist (SCM alist) +{ + SCM result; + SCM prev = SCM_EOL; + + 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_CELL_CAR_DELETED_P (pair)) + || (SCM_WEAK_CELL_CDR_DELETED_P (pair))) + { + /* Remove from ALIST weak pair PAIR whose car/cdr has been + nullified by the GC. */ + if (prev == SCM_EOL) + result = alist; + else + SCM_SETCDR (prev, SCM_CDR (alist)); + + continue; + } + } + } + + return result; +} + + static SCM make_hash_table (int flags, unsigned long k, const char *func_name) { @@ -89,11 +204,13 @@ 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; @@ -102,6 +219,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name) 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; } @@ -153,13 +271,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 @@ -417,7 +530,7 @@ scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*as #define FUNC_NAME "scm_hash_fn_get_handle" { unsigned long k; - SCM h; + SCM alist, h; if (SCM_HASHTABLE_P (table)) table = SCM_HASHTABLE_VECTOR (table); @@ -428,7 +541,17 @@ scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*as k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure); if (k >= SCM_SIMPLE_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure); + + alist = SCM_SIMPLE_VECTOR_REF (table, 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); + + h = assoc_fn (obj, alist, closure); return h; } #undef FUNC_NAME @@ -440,7 +563,7 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ #define FUNC_NAME "scm_hash_fn_create_handle_x" { unsigned long k; - SCM buckets, it; + SCM buckets, alist, it; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -456,7 +579,13 @@ 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); + + 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); + + it = assoc_fn (obj, alist, closure); if (scm_is_true (it)) return it; else @@ -467,7 +596,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))) + || (SCM_I_IS_VECTOR (table))) + { + /* Use a weak cell. */ + if (SCM_HASHTABLE_DOUBLY_WEAK_P (table)) + handle = scm_doubly_weak_cell (obj, init); + else if (SCM_HASHTABLE_WEAK_KEY_P (table)) + handle = scm_weak_car_cell (obj, init); + else + handle = scm_weak_cdr_cell (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)) { @@ -529,7 +676,7 @@ scm_hash_fn_remove_x (SCM table, SCM obj, void *closure) { unsigned long k; - SCM buckets, h; + SCM buckets, alist, h; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -545,7 +692,13 @@ 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); + + 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); + + h = assoc_fn (obj, alist, closure); if (scm_is_true (h)) { SCM_SIMPLE_VECTOR_SET diff --git a/libguile/symbols.c b/libguile/symbols.c index c8b901706..1f07f1aad 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -96,7 +96,18 @@ lookup_interned_symbol (const char *name, size_t len, !scm_is_null (l); l = SCM_CDR (l)) { - SCM sym = SCM_CAAR (l); + SCM pair, sym; + + pair = SCM_CAR (l); + if (!scm_is_pair (pair)) + abort (); + if (SCM_UNPACK (SCM_CAR (pair)) == NULL) + /* Weak pointer. Ignore it. */ + /* FIXME: Should we as well remove it, as in `scm_fixup_weak_alist'? */ + continue; + + sym = SCM_CAR (pair); + if (scm_i_symbol_hash (sym) == raw_hash && scm_i_symbol_length (sym) == len) { diff --git a/libguile/vectors.c b/libguile/vectors.c index 7a6fdfd92..272a3d2dd 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -34,6 +34,9 @@ #include "libguile/dynwind.h" #include "libguile/deprecation.h" +#include <gc/gc.h> /* disappearing links (aka. weak pointers) */ + + #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) @@ -61,6 +64,11 @@ const SCM * scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { + if (SCM_I_WVECTP (vec)) + /* FIXME: We should check each (weak) element of the vector for NULL and + convert it to SCM_BOOL_F. */ + abort (); + scm_generalized_vector_get_handle (vec, h); if (lenp) { @@ -75,6 +83,11 @@ SCM * scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { + if (SCM_I_WVECTP (vec)) + /* FIXME: We should check each (weak) element of the vector for NULL and + convert it to SCM_BOOL_F. */ + abort (); + scm_generalized_vector_get_handle (vec, h); if (lenp) { @@ -192,9 +205,17 @@ scm_c_vector_ref (SCM v, size_t k) { if (SCM_I_IS_VECTOR (v)) { + register SCM elt; + if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - return (SCM_I_VECTOR_ELTS(v))[k]; + scm_out_of_range (NULL, scm_from_size_t (k)); + elt = (SCM_I_VECTOR_ELTS(v))[k]; + + if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v)) + /* ELT was a weak pointer and got nullified by the GC. */ + return SCM_BOOL_F; + + return elt; } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -202,10 +223,18 @@ scm_c_vector_ref (SCM v, size_t k) SCM vv = SCM_I_ARRAY_V (v); if (SCM_I_IS_VECTOR (vv)) { + register SCM elt; + if (k >= dim->ubnd - dim->lbnd + 1) scm_out_of_range (NULL, scm_from_size_t (k)); k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - return (SCM_I_VECTOR_ELTS (vv))[k]; + elt = (SCM_I_VECTOR_ELTS (vv))[k]; + + if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv))) + /* ELT was a weak pointer and got nullified by the GC. */ + return SCM_BOOL_F; + + return elt; } scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); } @@ -243,6 +272,12 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); (SCM_I_VECTOR_WELTS(v))[k] = obj; + if (SCM_I_WVECTP (v)) + { + /* Make it a weak pointer. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -254,6 +289,13 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) scm_out_of_range (NULL, scm_from_size_t (k)); k = SCM_I_ARRAY_BASE (v) + k*dim->inc; (SCM_I_VECTOR_WELTS (vv))[k] = obj; + + if (SCM_I_WVECTP (vv)) + { + /* Make it a weak pointer. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); @@ -359,11 +401,13 @@ scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill) if (c_size > 0) { size_t j; - + if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; - - base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector"); + + /* The base itself should not be scanned for pointers otherwise those + pointers will always be reachable. */ + base = scm_gc_malloc_pointerless (c_size * sizeof (SCM), "weak vector"); for (j = 0; j != c_size; ++j) base[j] = fill; } diff --git a/libguile/weaks.c b/libguile/weaks.c index 72580b8b8..3d684cf82 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -127,6 +127,10 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, #undef FUNC_NAME +/* Weak alist vectors, i.e., vectors of alists. + + The alist vector themselves are _not_ weak. The `car' (or `cdr', or both) + of the pairs within it are weak. See `hashtab.c' for details. */ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0, (SCM size), @@ -140,8 +144,7 @@ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, "would modify regular hash tables. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_key_alist_vector { - return scm_i_allocate_weak_vector - (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_vector (size, SCM_EOL); } #undef FUNC_NAME @@ -152,8 +155,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_alist_vector { - return scm_i_allocate_weak_vector - (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_vector (size, SCM_EOL); } #undef FUNC_NAME @@ -164,8 +166,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_alist_vector { - return scm_i_allocate_weak_vector - (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_vector (size, SCM_EOL); } #undef FUNC_NAME @@ -206,118 +207,6 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0 #define UNMARKED_CELL_P(x) 1 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) *//* FIXME */ -static SCM weak_vectors; - -void -scm_i_init_weak_vectors_for_gc () -{ - weak_vectors = SCM_EOL; -} - -void -scm_i_mark_weak_vector (SCM w) -{ - SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors); - weak_vectors = w; -} - -static int -scm_i_mark_weak_vector_non_weaks (SCM w) -{ - int again = 0; - - if (SCM_IS_WHVEC_ANY (w)) - { - SCM *ptr; - long n = SCM_I_WVECT_LENGTH (w); - long j; - int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w); - int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w); - - ptr = SCM_I_WVECT_GC_WVELTS (w); - - for (j = 0; j < n; ++j) - { - SCM alist, slow_alist; - int slow_toggle = 0; - - /* We do not set the mark bits of the alist spine cells here - since we do not want to ever create the situation where a - marked cell references an unmarked cell (except in - scm_gc_mark, where the referenced cells will be marked - immediately). Thus, we can not use mark bits to stop us - from looping indefinitely over a cyclic alist. Instead, - we use the standard tortoise and hare trick to catch - cycles. The fast walker does the work, and stops when it - catches the slow walker to ensure that the whole cycle - has been worked on. - */ - - alist = slow_alist = ptr[j]; - - while (scm_is_pair (alist)) - { - SCM elt = SCM_CAR (alist); - - if (UNMARKED_CELL_P (elt)) - { - if (scm_is_pair (elt)) - { - SCM key = SCM_CAR (elt); - SCM value = SCM_CDR (elt); - - if (!((weak_keys && UNMARKED_CELL_P (key)) - || (weak_values && UNMARKED_CELL_P (value)))) - { - /* The item should be kept. We need to mark it - recursively. - */ - scm_gc_mark (elt); - again = 1; - } - } - else - { - /* A non-pair cell element. This should not - appear in a real alist, but when it does, we - need to keep it. - */ - scm_gc_mark (elt); - again = 1; - } - } - - alist = SCM_CDR (alist); - - if (slow_toggle && scm_is_pair (slow_alist)) - { - slow_alist = SCM_CDR (slow_alist); - slow_toggle = !slow_toggle; - if (scm_is_eq (slow_alist, alist)) - break; - } - } - if (!scm_is_pair (alist)) - scm_gc_mark (alist); - } - } - - return again; -} - -int -scm_i_mark_weak_vectors_non_weaks () -{ - int again = 0; - SCM w = weak_vectors; - while (!scm_is_null (w)) - { - if (scm_i_mark_weak_vector_non_weaks (w)) - again = 1; - w = SCM_I_WVECT_GC_CHAIN (w); - } - return again; -} static void scm_i_remove_weaks (SCM w) @@ -368,6 +257,7 @@ scm_i_remove_weaks (SCM w) #endif } +#if 0 void scm_i_remove_weaks_from_weak_vectors () { @@ -378,6 +268,7 @@ scm_i_remove_weaks_from_weak_vectors () w = SCM_I_WVECT_GC_CHAIN (w); } } +#endif |