mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

First stab at implementing weak hash tables and vectors. Unable to run the REPL.

Browse source 
* libguile/hashtab.c (scm_weak_car_cell): New.
  (scm_weak_cdr_cell): New.
  (scm_doubly_weak_cell): New.
  (SCM_WEAK_CELL_WORD_DELETED_P): New.
  (SCM_WEAK_CELL_WORD): New.
  (scm_fixup_weak_alist): New.
  (make_hash_table): Always use non-weak vectors.  Allocate
  `scm_t_hashtable' objects as pointerless.
  (scm_i_rehash): Always make NEW_BUCKETS a non-weak vector.
  (scm_hash_fn_get_handle): Call `scm_fixup_weak_alist ()' on weak
  buckets before calling ASSOC_FN.
  (scm_hash_fn_remove_x): Likewise.
  (scm_hash_fn_create_handle_x): Likewise.  Also, use `scm_.*weak.*cell
  ()' for HANDLE when needed.

* libguile/symbols.c (lookup_interned_symbol): Check for nullified
  pairs.

* libguile/vectors.c (scm_vector_elements): Abort on weak vectors.
  (scm_vector_writable_elements): Likewise.
  (scm_c_vector_ref): Check whether the referenced element has been
  nullified.
  (scm_c_vector_set_x): Use `GC_GENERAL_REGISTER_DISAPPEARING_LINK ()'.
  (scm_i_allocate_weak_vector): Use `scm_gc_malloc_pointerless ()'
  instead of `scm_gc_malloc ()' when allocating room for the vector
  itself.

* libguile/weaks.c (scm_make_weak_key_alist_vector): Use
  `scm_make_vector ()' instead of `scm_i_allocate_weak_vector ()'.
  (scm_make_weak_value_alist_vector): Likewise.
  (scm_make_doubly_weak_alist_vector): Likewise.
  (weak_vectors): Removed.
  (scm_i_init_weak_vectors_for_gc): Removed.
  (scm_i_mark_weak_vector): Removed.
  (scm_i_mark_weak_vector_non_weaks): Removed.
  (scm_i_mark_weak_vectors_non_weaks): Removed.
  (scm_i_remove_weaks_from_weak_vectors): Commented out.

git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-7
This commit is contained in:
Ludovic Courtes 2006-04-04 21:28:13 +00:00 • committed by Ludovic Courtès
parent a82e795325
commit 3a2de079d5
4 changed files with 243 additions and 144 deletions
Download patch file Download diff file Expand all files Collapse all files

191
libguile/hashtab.c
View file

@ -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

13
libguile/symbols.c
View file

@ -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)
{

56
libguile/vectors.c
View file

@ -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;
}

127
libguile/weaks.c
View file

@ -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