mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-29 16:30:19 +02:00
First stab at implementing weak hash tables and vectors. Unable to run the REPL.
* 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:
parent
a82e795325
commit
3a2de079d5
4 changed files with 243 additions and 144 deletions
|
@ -80,6 +80,121 @@ static char *s_hashtable = "hashtable";
|
||||||
|
|
||||||
SCM weak_hashtables = SCM_EOL;
|
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
|
static SCM
|
||||||
make_hash_table (int flags, unsigned long k, const char *func_name)
|
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])
|
while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
|
||||||
++i;
|
++i;
|
||||||
n = hashtable_size[i];
|
n = hashtable_size[i];
|
||||||
if (flags)
|
|
||||||
vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
|
/* In both cases, i.e., regardless of whether we are creating a weak hash
|
||||||
else
|
table, we return a non-weak vector. This is because the vector itself
|
||||||
vector = scm_c_make_vector (n, SCM_EOL);
|
is not weak in the case of a weak hash table: the alist pairs are. */
|
||||||
t = scm_gc_malloc (sizeof (*t), s_hashtable);
|
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->min_size_index = t->size_index = i;
|
||||||
t->n_items = 0;
|
t->n_items = 0;
|
||||||
t->lower = 0;
|
t->lower = 0;
|
||||||
|
@ -102,6 +219,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name)
|
||||||
t->hash_fn = NULL;
|
t->hash_fn = NULL;
|
||||||
if (flags)
|
if (flags)
|
||||||
{
|
{
|
||||||
|
/* FIXME: We should eventually remove WEAK_HASHTABLES. */
|
||||||
SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
|
SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
|
||||||
weak_hashtables = table;
|
weak_hashtables = table;
|
||||||
}
|
}
|
||||||
|
@ -153,13 +271,8 @@ scm_i_rehash (SCM table,
|
||||||
SCM_HASHTABLE (table)->lower = new_size / 4;
|
SCM_HASHTABLE (table)->lower = new_size / 4;
|
||||||
SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
|
SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
|
||||||
buckets = SCM_HASHTABLE_VECTOR (table);
|
buckets = SCM_HASHTABLE_VECTOR (table);
|
||||||
|
|
||||||
if (SCM_HASHTABLE_WEAK_P (table))
|
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
|
||||||
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);
|
|
||||||
|
|
||||||
/* When this is a weak hashtable, running the GC might change it.
|
/* When this is a weak hashtable, running the GC might change it.
|
||||||
We need to cope with this while rehashing its elements. We do
|
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"
|
#define FUNC_NAME "scm_hash_fn_get_handle"
|
||||||
{
|
{
|
||||||
unsigned long k;
|
unsigned long k;
|
||||||
SCM h;
|
SCM alist, h;
|
||||||
|
|
||||||
if (SCM_HASHTABLE_P (table))
|
if (SCM_HASHTABLE_P (table))
|
||||||
table = SCM_HASHTABLE_VECTOR (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);
|
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure);
|
||||||
if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
|
if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
|
||||||
scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
|
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;
|
return h;
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#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"
|
#define FUNC_NAME "scm_hash_fn_create_handle_x"
|
||||||
{
|
{
|
||||||
unsigned long k;
|
unsigned long k;
|
||||||
SCM buckets, it;
|
SCM buckets, alist, it;
|
||||||
|
|
||||||
if (SCM_HASHTABLE_P (table))
|
if (SCM_HASHTABLE_P (table))
|
||||||
buckets = SCM_HASHTABLE_VECTOR (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);
|
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
|
||||||
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
|
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
|
||||||
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
|
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))
|
if (scm_is_true (it))
|
||||||
return it;
|
return it;
|
||||||
else
|
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
|
again since the hashtable might have been rehashed. This
|
||||||
necessitates a new hash value as well.
|
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)
|
if (!scm_is_eq (table, buckets)
|
||||||
&& !scm_is_eq (SCM_HASHTABLE_VECTOR (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)
|
void *closure)
|
||||||
{
|
{
|
||||||
unsigned long k;
|
unsigned long k;
|
||||||
SCM buckets, h;
|
SCM buckets, alist, h;
|
||||||
|
|
||||||
if (SCM_HASHTABLE_P (table))
|
if (SCM_HASHTABLE_P (table))
|
||||||
buckets = SCM_HASHTABLE_VECTOR (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);
|
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
|
||||||
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
|
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
|
||||||
scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
|
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))
|
if (scm_is_true (h))
|
||||||
{
|
{
|
||||||
SCM_SIMPLE_VECTOR_SET
|
SCM_SIMPLE_VECTOR_SET
|
||||||
|
|
|
@ -96,7 +96,18 @@ lookup_interned_symbol (const char *name, size_t len,
|
||||||
!scm_is_null (l);
|
!scm_is_null (l);
|
||||||
l = SCM_CDR (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
|
if (scm_i_symbol_hash (sym) == raw_hash
|
||||||
&& scm_i_symbol_length (sym) == len)
|
&& scm_i_symbol_length (sym) == len)
|
||||||
{
|
{
|
||||||
|
|
|
@ -34,6 +34,9 @@
|
||||||
#include "libguile/dynwind.h"
|
#include "libguile/dynwind.h"
|
||||||
#include "libguile/deprecation.h"
|
#include "libguile/deprecation.h"
|
||||||
|
|
||||||
|
#include <gc/gc.h> /* disappearing links (aka. weak pointers) */
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
|
#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,
|
scm_vector_elements (SCM vec, scm_t_array_handle *h,
|
||||||
size_t *lenp, ssize_t *incp)
|
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);
|
scm_generalized_vector_get_handle (vec, h);
|
||||||
if (lenp)
|
if (lenp)
|
||||||
{
|
{
|
||||||
|
@ -75,6 +83,11 @@ SCM *
|
||||||
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
|
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
|
||||||
size_t *lenp, ssize_t *incp)
|
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);
|
scm_generalized_vector_get_handle (vec, h);
|
||||||
if (lenp)
|
if (lenp)
|
||||||
{
|
{
|
||||||
|
@ -192,9 +205,17 @@ scm_c_vector_ref (SCM v, size_t k)
|
||||||
{
|
{
|
||||||
if (SCM_I_IS_VECTOR (v))
|
if (SCM_I_IS_VECTOR (v))
|
||||||
{
|
{
|
||||||
|
register SCM elt;
|
||||||
|
|
||||||
if (k >= SCM_I_VECTOR_LENGTH (v))
|
if (k >= SCM_I_VECTOR_LENGTH (v))
|
||||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||||
return (SCM_I_VECTOR_ELTS(v))[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)
|
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);
|
SCM vv = SCM_I_ARRAY_V (v);
|
||||||
if (SCM_I_IS_VECTOR (vv))
|
if (SCM_I_IS_VECTOR (vv))
|
||||||
{
|
{
|
||||||
|
register SCM elt;
|
||||||
|
|
||||||
if (k >= dim->ubnd - dim->lbnd + 1)
|
if (k >= dim->ubnd - dim->lbnd + 1)
|
||||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
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");
|
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))
|
if (k >= SCM_I_VECTOR_LENGTH (v))
|
||||||
scm_out_of_range (NULL, scm_from_size_t (k));
|
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||||
(SCM_I_VECTOR_WELTS(v))[k] = obj;
|
(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)
|
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));
|
scm_out_of_range (NULL, scm_from_size_t (k));
|
||||||
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
|
||||||
(SCM_I_VECTOR_WELTS (vv))[k] = obj;
|
(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
|
else
|
||||||
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
|
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)
|
if (c_size > 0)
|
||||||
{
|
{
|
||||||
size_t j;
|
size_t j;
|
||||||
|
|
||||||
if (SCM_UNBNDP (fill))
|
if (SCM_UNBNDP (fill))
|
||||||
fill = SCM_UNSPECIFIED;
|
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)
|
for (j = 0; j != c_size; ++j)
|
||||||
base[j] = fill;
|
base[j] = fill;
|
||||||
}
|
}
|
||||||
|
|
127
libguile/weaks.c
127
libguile/weaks.c
|
@ -127,6 +127,10 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
|
||||||
#undef FUNC_NAME
|
#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_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
|
||||||
(SCM size),
|
(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})")
|
"would modify regular hash tables. (@pxref{Hash Tables})")
|
||||||
#define FUNC_NAME s_scm_make_weak_key_alist_vector
|
#define FUNC_NAME s_scm_make_weak_key_alist_vector
|
||||||
{
|
{
|
||||||
return scm_i_allocate_weak_vector
|
return scm_make_vector (size, SCM_EOL);
|
||||||
(1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
@ -152,8 +155,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0,
|
||||||
"(@pxref{Hash Tables})")
|
"(@pxref{Hash Tables})")
|
||||||
#define FUNC_NAME s_scm_make_weak_value_alist_vector
|
#define FUNC_NAME s_scm_make_weak_value_alist_vector
|
||||||
{
|
{
|
||||||
return scm_i_allocate_weak_vector
|
return scm_make_vector (size, SCM_EOL);
|
||||||
(2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
@ -164,8 +166,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector",
|
||||||
"buckets. (@pxref{Hash Tables})")
|
"buckets. (@pxref{Hash Tables})")
|
||||||
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
|
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
|
||||||
{
|
{
|
||||||
return scm_i_allocate_weak_vector
|
return scm_make_vector (size, SCM_EOL);
|
||||||
(3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#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)) *//*
|
#define UNMARKED_CELL_P(x) 1 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) *//*
|
||||||
FIXME */
|
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
|
static void
|
||||||
scm_i_remove_weaks (SCM w)
|
scm_i_remove_weaks (SCM w)
|
||||||
|
@ -368,6 +257,7 @@ scm_i_remove_weaks (SCM w)
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#if 0
|
||||||
void
|
void
|
||||||
scm_i_remove_weaks_from_weak_vectors ()
|
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);
|
w = SCM_I_WVECT_GC_CHAIN (w);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue