summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/hashtab.c191
-rw-r--r--libguile/symbols.c13
-rw-r--r--libguile/vectors.c56
-rw-r--r--libguile/weaks.c127
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