dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* gc-mark.c (scm_mark_all): Do not rely on hooks to run the weak

Browse source 
hashtable and guardian machinery but call the relevant functions
directly.

* guardians.h, guardians.c, deprecated.h,
deprecated.c (scm_destroy_guardian_x, scm_guardian_greedy_p,
scm_guardian_destroyed_p, scm_guard, scm_get_one_zombie):
Deprecated and moved into deprecated.[ch].

* guardians.h, guardians.c: Mostly rewritten.
(scm_i_init_guardians_for_gc,
scm_i_identify_inaccessible_guardeds,
scm_i_mark_inaccessible_guardeds): New.

* weaks.h, weaks.c (SCM_I_WVECT_TYPE, SCM_I_SET_WVECT_TYPE): New.
(SCM_I_WVECT_N_ITEMS, SCM_I_SET_WVECT_N_ITEMS): New.
(SCM_WVECTF_NOSCAN, SCM_WVECT_NOSCAN_P): Removed.
(scm_weaks_prehistory): Removed.
(scm_i_init_weak_vectors_for_gc, scm_i_mark_weak_vector,
scm_i_mark_weak_vectors_non_weaks,
scm_i_remove_weaks_from_weak_vectors, scm_i_remove_weaks): New.
(scm_weak_vector_gc_init, scm_mark_weak_vector_spines,
scm_scan_weak_vectors): Removed.

* hashtab.h (scm_i_scan_weak_hashtables): New.
* hashtab.c (make_hash_table, scm_i_rehash): Do not use
SCM_WVECTF_NOSCAN.
(hashtable_print): Use SCM_HASHTABLE_N_ITEMS instead of
t->n_items.
(scan_weak_hashtables, scm_i_scan_weak_hashtables): Renamed former
to latter.  Do not scan the alists themselves, this is done by the
weak vector code now.  Just update the element count.

* vectors.h (SCM_I_WVECT_TYPE, SCM_I_WVECT_EXTRA): Renamed former
to latter.  The type is now only part of the cell word.
(SCM_I_SET_WVECT_TYPE, SCM_I_SET_WVECT_EXTRA): Likewise.

* init.c (scm_i_init_guile): Do not call scm_weaks_prehistory.
This commit is contained in:
Marius Vollmer 2005-07-31 23:04:36 +00:00
commit 06c1d90009
11 changed files with 519 additions and 703 deletions
Download patch file Download diff file Expand all files Collapse all files

53
libguile/deprecated.c
View file

@ -1439,6 +1439,59 @@ scm_i_defer_ints_etc ()
"Use a mutex instead if appropriate."); "Use a mutex instead if appropriate.");
} }
SCM
scm_guard (SCM guardian, SCM obj, int throw_p)
{
scm_c_issue_deprecation_warning
("scm_guard is deprecated. Use scm_call_1 instead.");
return scm_call_1 (guardian, obj);
}
SCM
scm_get_one_zombie (SCM guardian)
{
scm_c_issue_deprecation_warning
("scm_guard is deprecated. Use scm_call_0 instead.");
return scm_call_0 (guardian);
}
SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
(SCM guardian),
"Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
#define FUNC_NAME s_scm_guardian_destroyed_p
{
scm_c_issue_deprecation_warning
("'guardian-destroyed?' is deprecated.");
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
(SCM guardian),
"Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
#define FUNC_NAME s_scm_guardian_greedy_p
{
scm_c_issue_deprecation_warning
("'guardian-greedy?' is deprecated.");
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
(SCM guardian),
"Destroys @var{guardian}, by making it impossible to put any more\n"
"objects in it or get any objects from it. It also unguards any\n"
"objects guarded by @var{guardian}.")
#define FUNC_NAME s_scm_destroy_guardian_x
{
scm_c_issue_deprecation_warning
("'destroy-guardian!' is deprecated and ineffective.");
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void void
scm_i_init_deprecated () scm_i_init_deprecated ()
{ {

42
libguile/deprecated.h
View file

@ -538,22 +538,25 @@ SCM_API SCM_STACKITEM *scm_i_stack_base (void);
#define SCM_FLUIDP(x) scm_i_fluidp (x) #define SCM_FLUIDP(x) scm_i_fluidp (x)
SCM_API int scm_i_fluidp (SCM x); SCM_API int scm_i_fluidp (SCM x);
/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers from running, /* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers
since in those days the handler directly ran scheme code, and that had to from running, since in those days the handler directly ran scheme
be avoided when the heap was not in a consistent state etc. And since code, and that had to be avoided when the heap was not in a
the scheme code could do a stack swapping new continuation etc, signals consistent state etc. And since the scheme code could do a stack
had to be deferred around various C library functions which were not safe swapping new continuation etc, signals had to be deferred around
or not known to be safe to swap away, which was a lot of stuff. various C library functions which were not safe or not known to be
safe to swap away, which was a lot of stuff.
These days signals are implemented with asyncs and don't directly run These days signals are implemented with asyncs and don't directly
scheme code in the handler, but hold it until an SCM_TICK etc where it run scheme code in the handler, but hold it until an SCM_TICK etc
will be safe. This means interrupt protection is not needed and where it will be safe. This means interrupt protection is not
SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is something of an anachronism. needed and SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is
something of an anachronism.
What past SCM_CRITICAL_SECTION_START usage also did though was indicate code that was What past SCM_CRITICAL_SECTION_START usage also did though was
not reentrant, ie. could not be reentered by signal handler code. The indicate code that was not reentrant, ie. could not be reentered by
present definitions are a mutex lock, affording that reentrancy signal handler code. The present definitions are a mutex lock,
protection against the new guile 1.8 free-running posix threads. affording that reentrancy protection against the new guile 1.8
free-running posix threads.
One big problem with the present defintions though is that code which One big problem with the present defintions though is that code which
throws an error from within a DEFER/ALLOW region will leave the throws an error from within a DEFER/ALLOW region will leave the
@ -567,6 +570,17 @@ SCM_API void scm_i_defer_ints_etc (void);
#define SCM_REDEFER_INTS scm_i_defer_ints_etc () #define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
#define SCM_REALLOW_INTS scm_i_defer_ints_etc () #define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
/* Deprecated since they are unnecessary and had not been documented.
*/
SCM_API SCM scm_guard (SCM guardian, SCM obj, int throw_p);
SCM_API SCM scm_get_one_zombie (SCM guardian);
/* Deprecated since guardians no longer have these special features.
*/
SCM_API SCM scm_destroy_guardian_x (SCM guardian);
SCM_API SCM scm_guardian_greedy_p (SCM guardian);
SCM_API SCM scm_guardian_destroyed_p (SCM guardian);
void scm_i_init_deprecated (void); void scm_i_init_deprecated (void);
#endif #endif

119
libguile/gc-mark.c
View file

@ -50,6 +50,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/deprecation.h" #include "libguile/deprecation.h"
#include "libguile/gc.h" #include "libguile/gc.h"
#include "libguile/guardians.h"
#ifdef GUILE_DEBUG_MALLOC #ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h" #include "libguile/debug-malloc.h"
@ -70,7 +71,9 @@ void
scm_mark_all (void) scm_mark_all (void)
{ {
long j; long j;
scm_i_init_weak_vectors_for_gc ();
scm_i_init_guardians_for_gc ();
scm_i_clear_mark_space (); scm_i_clear_mark_space ();
@ -95,11 +98,55 @@ scm_mark_all (void)
} }
} }
/* FIXME: we should have a means to register C functions to be run
* in different phases of GC
*/
scm_mark_subr_table (); scm_mark_subr_table ();
int loops = 0;
while (1)
{
loops++;
int again;
/* Mark the non-weak references of weak vectors. For a weak key
alist vector, this would mark the values for keys that are
marked. We need to do this in a loop until everything
settles down since the newly marked values might be keys in
other weak key alist vectors, for example.
*/
again = scm_i_mark_weak_vectors_non_weaks ();
if (again)
continue;
/* Now we scan all marked guardians and move all unmarked objects
from the accessible to the inaccessible list.
*/
scm_i_identify_inaccessible_guardeds ();
/* When we have identified all inaccessible objects, we can mark
them.
*/
again = scm_i_mark_inaccessible_guardeds ();
/* This marking might have changed the situation for weak vectors
and might have turned up new guardians that need to be processed,
so we do it all over again.
*/
if (again)
continue;
/* Nothing new marked in this round, we are done.
*/
break;
}
//fprintf (stderr, "%d loops\n", loops);
/* Remove all unmarked entries from the weak vectors.
*/
scm_i_remove_weaks_from_weak_vectors ();
/* Bring hashtables upto date.
*/
scm_i_scan_weak_hashtables ();
} }
/* {Mark/Sweep} /* {Mark/Sweep}
@ -144,6 +191,7 @@ Perhaps this would work better with an explicit markstack?
*/ */
void void
scm_gc_mark_dependencies (SCM p) scm_gc_mark_dependencies (SCM p)
#define FUNC_NAME "scm_gc_mark_dependencies" #define FUNC_NAME "scm_gc_mark_dependencies"
@ -267,62 +315,7 @@ scm_gc_mark_dependencies (SCM p)
break; break;
case scm_tc7_wvect: case scm_tc7_wvect:
SCM_I_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors); scm_i_mark_weak_vector (ptr);
scm_weak_vectors = ptr;
if (SCM_IS_WHVEC_ANY (ptr))
{
long x;
long len;
int weak_keys;
int weak_values;
len = SCM_SIMPLE_VECTOR_LENGTH (ptr);
weak_keys = SCM_WVECT_WEAK_KEY_P (ptr);
weak_values = SCM_WVECT_WEAK_VALUE_P (ptr);
for (x = 0; x < len; ++x)
{
SCM alist;
alist = SCM_SIMPLE_VECTOR_REF (ptr, x);
/* mark everything on the alist except the keys or
* values, according to weak_values and weak_keys. */
while ( scm_is_pair (alist)
&& !SCM_GC_MARK_P (alist)
&& scm_is_pair (SCM_CAR (alist)))
{
SCM kvpair;
SCM next_alist;
kvpair = SCM_CAR (alist);
next_alist = SCM_CDR (alist);
/*
* Do not do this:
* SCM_SET_GC_MARK (alist);
* SCM_SET_GC_MARK (kvpair);
*
* It may be that either the key or value is protected by
* an escaped reference to part of the spine of this alist.
* If we mark the spine here, and only mark one or neither of the
* key and value, they may never be properly marked.
* This leads to a horrible situation in which an alist containing
* freelist cells is exported.
*
* So only mark the spines of these arrays last of all marking.
* If somebody confuses us by constructing a weak vector
* with a circular alist then we are hosed, but at least we
* won't prematurely drop table entries.
*/
if (!weak_keys)
scm_gc_mark (SCM_CAR (kvpair));
if (!weak_values)
scm_gc_mark (SCM_CDR (kvpair));
alist = next_alist;
}
if (SCM_NIMP (alist))
scm_gc_mark (alist);
}
}
break; break;
case scm_tc7_symbol: case scm_tc7_symbol:
@ -389,8 +382,8 @@ scm_gc_mark_dependencies (SCM p)
were called with.) were called with.)
*/ */
return ; return ;
gc_mark_loop: gc_mark_loop:
if (SCM_IMP (ptr)) if (SCM_IMP (ptr))
return; return;

630
libguile/guardians.c
View file

@ -23,14 +23,20 @@
* Programming Language Design and Implementation, June 1993 * Programming Language Design and Implementation, June 1993
* ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
* *
* Original design: Mikael Djurfeldt
* Original implementation: Michael Livshin
* Hacked on since by: everybody
*
* By this point, the semantics are actually quite different from * By this point, the semantics are actually quite different from
* those described in the abovementioned paper. The semantic changes * those described in the abovementioned paper. The semantic changes
* are there to improve safety and intuitiveness. The interface is * are there to improve safety and intuitiveness. The interface is
* still (mostly) the one described by the paper, however. * still (mostly) the one described by the paper, however.
* *
* Original design: Mikael Djurfeldt * Boiled down again: Marius Vollmer
* Original implementation: Michael Livshin *
* Hacked on since by: everybody * Now they should again behave like those described in the paper.
* Scheme guardians should be simple and friendly, not like the greedy
* monsters we had...
*/ */
@ -43,6 +49,8 @@
#include "libguile/root.h" #include "libguile/root.h"
#include "libguile/hashtab.h" #include "libguile/hashtab.h"
#include "libguile/weaks.h" #include "libguile/weaks.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"
#include "libguile/guardians.h" #include "libguile/guardians.h"
@ -83,71 +91,105 @@ typedef struct t_guardian
t_tconc live; t_tconc live;
t_tconc zombies; t_tconc zombies;
struct t_guardian *next; struct t_guardian *next;
unsigned long flags;
} t_guardian; } t_guardian;
#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x)) #define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
#define F_GREEDY 1L static t_guardian *guardians;
#define F_LISTED (1L << 1)
#define F_DESTROYED (1L << 2)
#define GREEDY_P(x) (((x)->flags & F_GREEDY) != 0) void
#define SET_GREEDY(x) ((x)->flags |= F_GREEDY) scm_i_init_guardians_for_gc ()
#define LISTED_P(x) (((x)->flags & F_LISTED) != 0)
#define SET_LISTED(x) ((x)->flags |= F_LISTED)
#define CLR_LISTED(x) ((x)->flags &= ~F_LISTED)
#define DESTROYED_P(x) (((x)->flags & F_DESTROYED) != 0)
#define SET_DESTROYED(x) ((x)->flags |= F_DESTROYED)
/* during the gc mark phase, live guardians are linked into the lists
here. */
static t_guardian *greedy_guardians = NULL;
static t_guardian *sharing_guardians = NULL;
static SCM greedily_guarded_whash = SCM_EOL;
/* this is the list of guarded objects that are parts of cycles. we
don't know in which order to return them from guardians, so we just
unguard them and whine about it in after-gc-hook */
static SCM self_centered_zombies = SCM_EOL;
static void
add_to_live_list (t_guardian *g)
{ {
if (LISTED_P (g)) guardians = NULL;
return;
if (GREEDY_P (g))
{
g->next = greedy_guardians;
greedy_guardians = g;
}
else
{
g->next = sharing_guardians;
sharing_guardians = g;
}
SET_LISTED (g);
} }
/* mark a guardian by adding it to the live guardian list. */ /* mark a guardian by adding it to the live guardian list. */
static SCM static SCM
guardian_mark (SCM ptr) guardian_mark (SCM ptr)
{ {
add_to_live_list (GUARDIAN_DATA (ptr)); t_guardian *g = GUARDIAN_DATA (ptr);
g->next = guardians;
guardians = g;
/* the objects protected by the guardian are not marked here: that
would prevent them from ever getting collected. instead marking
is done at the end of the mark phase by guardian_zombify. */
return SCM_BOOL_F; return SCM_BOOL_F;
} }
/* Identify inaccessible objects and move them from the live list to
the zombie list. An object is inaccessible when it is unmarked at
this point. Therefore, the inaccessible objects are not marked yet
since that would prevent them from being recognized as
inaccessible.
The pairs that form the life list itself are marked, tho.
*/
void
scm_i_identify_inaccessible_guardeds ()
{
t_guardian *g;
for (g = guardians; g; g = g->next)
{
SCM pair, next_pair;
SCM *prev_ptr;
for (pair = g->live.head, prev_ptr = &g->live.head;
!scm_is_eq (pair, g->live.tail);
pair = next_pair)
{
SCM obj = SCM_CAR (pair);
next_pair = SCM_CDR (pair);
if (!SCM_GC_MARK_P (obj))
{
/* Unmarked, move to 'inaccessible' list.
*/
*prev_ptr = next_pair;
TCONC_IN (g->zombies, obj, pair);
}
else
{
SCM_SET_GC_MARK (pair);
prev_ptr = SCM_CDRLOC (pair);
}
}
SCM_SET_GC_MARK (pair);
}
}
int
scm_i_mark_inaccessible_guardeds ()
{
t_guardian *g;
int again = 0;
/* We never need to see the guardians again that are processed here,
so we clear the list. Calling scm_gc_mark below might find new
guardians, however (and other things), and we inform the GC about
this by returning non-zero. See scm_mark_all in gc-mark.c
*/
g = guardians;
guardians = NULL;
for (; g; g = g->next)
{
SCM pair;
for (pair = g->zombies.head;
!scm_is_eq (pair, g->zombies.tail);
pair = SCM_CDR (pair))
{
if (!SCM_GC_MARK_P (pair))
{
scm_gc_mark (SCM_CAR (pair));
SCM_SET_GC_MARK (pair);
again = 1;
}
}
SCM_SET_GC_MARK (pair);
}
return again;
}
static size_t static size_t
guardian_free (SCM ptr) guardian_free (SCM ptr)
@ -156,39 +198,49 @@ guardian_free (SCM ptr)
return 0; return 0;
} }
static int static int
guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
{ {
t_guardian *g = GUARDIAN_DATA (guardian); t_guardian *g = GUARDIAN_DATA (guardian);
scm_puts ("#<", port); scm_puts ("#<guardian ", port);
if (DESTROYED_P (g))
scm_puts ("destroyed ", port);
if (GREEDY_P (g))
scm_puts ("greedy", port);
else
scm_puts ("sharing", port);
scm_puts (" guardian 0x", port);
scm_uintprint ((scm_t_bits) g, 16, port); scm_uintprint ((scm_t_bits) g, 16, port);
if (! DESTROYED_P (g)) scm_puts (" (reachable: ", port);
{ scm_display (scm_length (SCM_CDR (g->live.head)), port);
scm_puts (" (reachable: ", port); scm_puts (" unreachable: ", port);
scm_display (scm_length (SCM_CDR (g->live.head)), port); scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
scm_puts (" unreachable: ", port); scm_puts (")", port);
scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
scm_puts (")", port);
}
scm_puts (">", port); scm_puts (">", port);
return 1; return 1;
} }
static void
scm_i_guard (SCM guardian, SCM obj)
{
t_guardian *g = GUARDIAN_DATA (guardian);
if (!SCM_IMP (obj))
{
SCM z;
z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
TCONC_IN (g->live, obj, z);
}
}
static SCM
scm_i_get_one_zombie (SCM guardian)
{
t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F;
if (!TCONC_EMPTYP (g->zombies))
TCONC_OUT (g->zombies, res);
return res;
}
/* This is the Scheme entry point for each guardian: If OBJ is an /* This is the Scheme entry point for each guardian: If OBJ is an
* object, it's added to the guardian's live list. If OBJ is unbound, * object, it's added to the guardian's live list. If OBJ is unbound,
@ -202,112 +254,63 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
static SCM static SCM
guardian_apply (SCM guardian, SCM obj, SCM throw_p) guardian_apply (SCM guardian, SCM obj, SCM throw_p)
{ {
if (DESTROYED_P (GUARDIAN_DATA (guardian))) #if ENABLE_DEPRECATED
scm_misc_error ("guard", "attempted use of destroyed guardian: ~A", if (!SCM_UNBNDP (throw_p))
scm_list_1 (guardian)); scm_c_issue_deprecation_warning
("Using the 'throw?' argument of a guardian is deprecated "
"and ineffective.");
#endif
if (!SCM_UNBNDP (obj)) if (!SCM_UNBNDP (obj))
return scm_guard (guardian, obj,
(SCM_UNBNDP (throw_p)
? 1
: scm_is_true (throw_p)));
else
return scm_get_one_zombie (guardian);
}
SCM
scm_guard (SCM guardian, SCM obj, int throw_p)
{
t_guardian *g = GUARDIAN_DATA (guardian);
if (!SCM_IMP (obj))
{ {
SCM z; scm_i_guard (guardian, obj);
return SCM_UNSPECIFIED;
/* This critical section barrier will be replaced by a mutex. */
/* njrev: per comment above, should use a mutex. */
SCM_CRITICAL_SECTION_START;
if (GREEDY_P (g))
{
if (scm_is_true (scm_hashq_get_handle
(greedily_guarded_whash, obj)))
{
SCM_CRITICAL_SECTION_END;
if (throw_p)
scm_misc_error ("guard",
"object is already greedily guarded: ~A",
scm_list_1 (obj));
else
return SCM_BOOL_F;
}
else
scm_hashq_create_handle_x (greedily_guarded_whash,
obj, guardian);
/* njrev: this can throw a memory or out-of-range error. */
}
z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
TCONC_IN (g->live, obj, z);
SCM_CRITICAL_SECTION_END;
} }
else
return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T; return scm_i_get_one_zombie (guardian);
} }
SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
SCM (),
scm_get_one_zombie (SCM guardian) "Create a new guardian. A guardian protects a set of objects from\n"
{ "garbage collection, allowing a program to apply cleanup or other\n"
t_guardian *g = GUARDIAN_DATA (guardian); "actions.\n"
SCM res = SCM_BOOL_F; "\n"
"@code{make-guardian} returns a procedure representing the guardian.\n"
/* This critical section barrier will be replaced by a mutex. */ "Calling the guardian procedure with an argument adds the argument to\n"
SCM_CRITICAL_SECTION_START; "the guardian's set of protected objects. Calling the guardian\n"
/* njrev: -> mutex */ "procedure without an argument returns one of the protected objects\n"
"which are ready for garbage collection, or @code{#f} if no such object\n"
if (!TCONC_EMPTYP (g->zombies)) "is available. Objects which are returned in this way are removed from\n"
TCONC_OUT (g->zombies, res); "the guardian.\n"
"\n"
if (scm_is_true (res) && GREEDY_P (g)) "You can put a single object into a guardian more than once and you can\n"
scm_hashq_remove_x (greedily_guarded_whash, res); "put a single object into more than one guardian. The object will then\n"
"be returned multiple times by the guardian procedures.\n"
SCM_CRITICAL_SECTION_END; "\n"
"An object is eligible to be returned from a guardian when it is no\n"
return res; "longer referenced from outside any guardian.\n"
} "\n"
"There is no guarantee about the order in which objects are returned\n"
"from a guardian. If you want to impose an order on finalization\n"
SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, "actions, for example, you can do that by keeping objects alive in some\n"
(SCM greedy_p), "global data structure until they are no longer needed for finalizing\n"
"Create a new guardian.\n" "other objects.\n"
"A guardian protects a set of objects from garbage collection,\n" "\n"
"allowing a program to apply cleanup or other actions.\n\n" "Being an element in a weak vector, a key in a hash table with weak\n"
"keys, or a value in a hash table with weak value does not prevent an\n"
"@code{make-guardian} returns a procedure representing the guardian.\n" "object from being returned by a guardian. But as long as an object\n"
"Calling the guardian procedure with an argument adds the\n" "can be returned from a guardian it will not be removed from such a\n"
"argument to the guardian's set of protected objects.\n" "weak vector or hash table. In other words, a weak link does not\n"
"Calling the guardian procedure without an argument returns\n" "prevent an object from being considered collectable, but being inside\n"
"one of the protected objects which are ready for garbage\n" "a guardian prevents a weak link from being broken.\n"
"collection, or @code{#f} if no such object is available.\n" "\n"
"Objects which are returned in this way are removed from\n" "A key in a weak key hash table can be though of as having a strong\n"
"the guardian.\n\n" "reference to its associated value as long as the key is accessible.\n"
"Consequently, when the key only accessible from within a guardian, the\n"
"@code{make-guardian} takes one optional argument that says whether the\n" "reference from the key to the value is also considered to be coming\n"
"new guardian should be greedy or sharing. If there is any chance\n" "from within a guardian. Thus, if there is no other reference to the\n"
"that any object protected by the guardian may be resurrected,\n" "value, it is eligible to be returned from a guardian.\n")
"then you should make the guardian greedy (this is the default).\n\n"
"See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n"
"\"Guardians in a Generation-Based Garbage Collector\".\n"
"ACM SIGPLAN Conference on Programming Language Design\n"
"and Implementation, June 1993.\n\n"
"(the semantics are slightly different at this point, but the\n"
"paper still (mostly) accurately describes the interface).")
#define FUNC_NAME s_scm_make_guardian #define FUNC_NAME s_scm_make_guardian
{ {
t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian"); t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
@ -320,280 +323,13 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
g->zombies.head = g->zombies.tail = z2; g->zombies.head = g->zombies.tail = z2;
g->next = NULL; g->next = NULL;
g->flags = 0L;
/* [cmm] the UNBNDP check below is redundant but I like it. */
if (SCM_UNBNDP (greedy_p) || scm_is_true (greedy_p))
SET_GREEDY (g);
SCM_NEWSMOB (z, tc16_guardian, g); SCM_NEWSMOB (z, tc16_guardian, g);
return z; return z;
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
(SCM guardian),
"Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
#define FUNC_NAME s_scm_guardian_destroyed_p
{
SCM res = SCM_BOOL_F;
/* This critical section barrier will be replaced by a mutex. */
SCM_CRITICAL_SECTION_START;
/* njrev: Critical section not needed here. (Falls into category of
stuff that is the responsibility of Scheme code, whenever
accessing data from multiple threads.) */
res = scm_from_bool (DESTROYED_P (GUARDIAN_DATA (guardian)));
SCM_CRITICAL_SECTION_END;
return res;
}
#undef FUNC_NAME
SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
(SCM guardian),
"Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
#define FUNC_NAME s_scm_guardian_greedy_p
{
return scm_from_bool (GREEDY_P (GUARDIAN_DATA (guardian)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
(SCM guardian),
"Destroys @var{guardian}, by making it impossible to put any more\n"
"objects in it or get any objects from it. It also unguards any\n"
"objects guarded by @var{guardian}.")
#define FUNC_NAME s_scm_destroy_guardian_x
{
t_guardian *g = GUARDIAN_DATA (guardian);
/* This critical section barrier will be replaced by a mutex. */
SCM_CRITICAL_SECTION_START;
if (DESTROYED_P (g))
{
SCM_CRITICAL_SECTION_END;
SCM_MISC_ERROR ("guardian is already destroyed: ~A",
scm_list_1 (guardian));
}
if (GREEDY_P (g))
{
/* clear the "greedily guarded" property of the objects */
SCM pair;
for (pair = g->live.head; pair != g->live.tail; pair = SCM_CDR (pair))
scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair));
for (pair = g->zombies.head; pair != g->zombies.tail; pair = SCM_CDR (pair))
scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair));
}
/* empty the lists */
g->live.head = g->live.tail;
g->zombies.head = g->zombies.tail;
SET_DESTROYED (g);
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* called before gc mark phase begins to initialise the live guardian list. */
static void *
guardian_gc_init (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
greedy_guardians = sharing_guardians = NULL;
return 0;
}
static void
mark_dependencies_in_tconc (t_tconc *tc)
{
SCM pair, next_pair;
SCM *prev_ptr;
/* scan the list for unmarked objects, and mark their
dependencies */
for (pair = tc->head, prev_ptr = &tc->head;
!scm_is_eq (pair, tc->tail);
pair = next_pair)
{
SCM obj = SCM_CAR (pair);
next_pair = SCM_CDR (pair);
if (! SCM_GC_MARK_P (obj))
{
/* a candidate for finalizing */
scm_gc_mark_dependencies (obj);
if (SCM_GC_MARK_P (obj))
{
/* uh oh. a cycle. transfer this object (the
spine cell, to be exact) to
self_centered_zombies, so we'll be able to
complain about it later. */
*prev_ptr = next_pair;
SCM_SET_GC_MARK (pair);
SCM_SETCDR (pair, self_centered_zombies);
self_centered_zombies = pair;
}
else
{
/* see if this is a guardian. if yes, list it (but don't
mark it yet). */
if (GUARDIAN_P (obj))
add_to_live_list (GUARDIAN_DATA (obj));
prev_ptr = SCM_CDRLOC (pair);
}
}
}
}
static void
mark_dependencies (t_guardian *g)
{
mark_dependencies_in_tconc (&g->zombies);
mark_dependencies_in_tconc (&g->live);
}
static void
mark_and_zombify (t_guardian *g)
{
SCM tconc_tail = g->live.tail;
SCM *prev_ptr = &g->live.head;
SCM pair = g->live.head;
while (!scm_is_eq (pair, tconc_tail))
{
SCM next_pair = SCM_CDR (pair);
if (!SCM_GC_MARK_P (SCM_CAR (pair)))
{
/* got you, zombie! */
/* out of the live list! */
*prev_ptr = next_pair;
if (GREEDY_P (g))
/* if the guardian is greedy, mark this zombie now. this
way it won't be zombified again this time around. */
SCM_SET_GC_MARK (SCM_CAR (pair));
/* into the zombie list! */
TCONC_IN (g->zombies, SCM_CAR (pair), pair);
}
else
prev_ptr = SCM_CDRLOC (pair);
pair = next_pair;
}
/* Mark the cells of the live list (yes, the cells in the list, we
don't care about objects pointed to by the list cars, since we
know they are already marked). */
for (pair = g->live.head; !scm_is_null (pair); pair = SCM_CDR (pair))
SCM_SET_GC_MARK (pair);
}
/* this is called by the garbage collector between the mark and sweep
phases. for each marked guardian, it moves any unmarked object in
its live list (tconc) to its zombie list (tconc). */
static void *
guardian_zombify (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
t_guardian *last_greedy_guardian = NULL;
t_guardian *last_sharing_guardian = NULL;
t_guardian *first_greedy_guardian = NULL;
t_guardian *first_sharing_guardian = NULL;
t_guardian *g;
/* First, find all newly unreachable objects and mark their
dependencies.
Note that new guardians may be stuck on the end of the live
guardian lists as we run this loop, since guardians might be
guarded too. When we mark a guarded guardian, its mark function
sticks in the appropriate live guardian list. The loop
terminates when no new guardians are found. */
do {
first_greedy_guardian = greedy_guardians;
first_sharing_guardian = sharing_guardians;
for (g = greedy_guardians; g != last_greedy_guardian;
g = g->next)
mark_dependencies (g);
for (g = sharing_guardians; g != last_sharing_guardian;
g = g->next)
mark_dependencies (g);
last_greedy_guardian = first_greedy_guardian;
last_sharing_guardian = first_sharing_guardian;
} while (first_greedy_guardian != greedy_guardians
|| first_sharing_guardian != sharing_guardians);
/* now, scan all the guardians that are currently known to be live
and move their unmarked objects to zombie lists. */
for (g = greedy_guardians; g; g = g->next)
{
mark_and_zombify (g);
CLR_LISTED (g);
}
for (g = sharing_guardians; g; g = g->next)
{
mark_and_zombify (g);
CLR_LISTED (g);
}
/* Preserve the zombies in their undead state, by marking to prevent
collection. */
for (g = greedy_guardians; g; g = g->next)
scm_gc_mark (g->zombies.head);
for (g = sharing_guardians; g; g = g->next)
scm_gc_mark (g->zombies.head);
return 0;
}
static void *
whine_about_self_centered_zombies (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
if (!scm_is_null (self_centered_zombies))
{
SCM port = scm_current_error_port ();
SCM pair;
scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:",
port);
scm_newline (port);
for (pair = self_centered_zombies;
!scm_is_null (pair); pair = SCM_CDR (pair))
{
scm_display (SCM_CAR (pair), port);
scm_newline (port);
}
self_centered_zombies = SCM_EOL;
}
return 0;
}
void void
scm_init_guardians () scm_init_guardians ()
{ {
@ -601,17 +337,11 @@ scm_init_guardians ()
scm_set_smob_mark (tc16_guardian, guardian_mark); scm_set_smob_mark (tc16_guardian, guardian_mark);
scm_set_smob_free (tc16_guardian, guardian_free); scm_set_smob_free (tc16_guardian, guardian_free);
scm_set_smob_print (tc16_guardian, guardian_print); scm_set_smob_print (tc16_guardian, guardian_print);
#if ENABLE_DEPRECATED
scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0); scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
#else
scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); #endif
scm_gc_register_root (&self_centered_zombies);
scm_c_hook_add (&scm_after_gc_c_hook,
whine_about_self_centered_zombies, 0, 0);
greedily_guarded_whash =
scm_permanent_object (scm_make_doubly_weak_hash_table (scm_from_int (31)));
#include "libguile/guardians.x" #include "libguile/guardians.x"
} }

12
libguile/guardians.h
View file

@ -24,15 +24,11 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
SCM_API SCM scm_make_guardian (SCM greedy_p); SCM_API SCM scm_make_guardian (void);
SCM_API SCM scm_destroy_guardian_x (SCM guardian);
SCM_API SCM scm_guardian_greedy_p (SCM guardian); SCM_API void scm_i_init_guardians_for_gc (void);
SCM_API SCM scm_guardian_destroyed_p (SCM guardian); SCM_API void scm_i_identify_inaccessible_guardeds (void);
SCM_API int scm_i_mark_inaccessible_guardeds (void);
/* these are to be called from C: */
SCM_API SCM scm_guard (SCM guardian, SCM obj, int throw_p);
SCM_API SCM scm_get_one_zombie (SCM guardian);
SCM_API void scm_init_guardians (void); SCM_API void scm_init_guardians (void);

69
libguile/hashtab.c
View file

@ -18,6 +18,8 @@
#include <stdio.h>
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/alist.h" #include "libguile/alist.h"
#include "libguile/hash.h" #include "libguile/hash.h"
@ -88,12 +90,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name)
++i; ++i;
n = hashtable_size[i]; n = hashtable_size[i];
if (flags) if (flags)
/* The SCM_WVECTF_NOSCAN flag informs the weak vector code not to vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
perform the final scan for broken references. Instead we do
that ourselves in scan_weak_hashtables. */
vector = scm_i_allocate_weak_vector (flags | SCM_WVECTF_NOSCAN,
scm_from_int (n),
SCM_EOL);
else else
vector = scm_c_make_vector (n, SCM_EOL); vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc (sizeof (*t), s_hashtable); t = scm_gc_malloc (sizeof (*t), s_hashtable);
@ -158,8 +155,7 @@ scm_i_rehash (SCM table,
buckets = SCM_HASHTABLE_VECTOR (table); buckets = SCM_HASHTABLE_VECTOR (table);
if (SCM_HASHTABLE_WEAK_P (table)) if (SCM_HASHTABLE_WEAK_P (table))
new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table) new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table),
| SCM_WVECTF_NOSCAN,
scm_from_ulong (new_size), scm_from_ulong (new_size),
SCM_EOL); SCM_EOL);
else else
@ -167,16 +163,13 @@ scm_i_rehash (SCM table,
/* 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
this by first installing the new, empty bucket vector and turning this by first installing the new, empty bucket vector. Then we
the old bucket vector into a regularily scanned weak vector. remove the elements from the old bucket vector and insert them
Then we remove the elements from the old bucket vector and insert into the new one.
them into the new one.
*/ */
SCM_SET_HASHTABLE_VECTOR (table, new_buckets); SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0); SCM_SET_HASHTABLE_N_ITEMS (table, 0);
if (SCM_HASHTABLE_WEAK_P (table))
SCM_I_SET_WVECT_TYPE (buckets, ((scm_t_bits) SCM_HASHTABLE_FLAGS (table)));
old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets); old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < old_size; ++i) for (i = 0; i < old_size; ++i)
@ -206,7 +199,6 @@ scm_i_rehash (SCM table,
static int static int
hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{ {
scm_t_hashtable *t = SCM_HASHTABLE (exp);
scm_puts ("#<", port); scm_puts ("#<", port);
if (SCM_HASHTABLE_WEAK_KEY_P (exp)) if (SCM_HASHTABLE_WEAK_KEY_P (exp))
scm_puts ("weak-key-", port); scm_puts ("weak-key-", port);
@ -215,7 +207,7 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp)) else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
scm_puts ("doubly-weak-", port); scm_puts ("doubly-weak-", port);
scm_puts ("hash-table ", port); scm_puts ("hash-table ", port);
scm_uintprint (t->n_items, 10, port); scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc ('/', port); scm_putc ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)), scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port); 10, port);
@ -228,12 +220,9 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
/* keep track of hash tables that need to shrink after scan */ /* keep track of hash tables that need to shrink after scan */
static SCM to_rehash = SCM_EOL; static SCM to_rehash = SCM_EOL;
/* scan hash tables for broken references, remove them, and update /* scan hash tables and update hash tables item count */
hash tables item count */ void
static void * scm_i_scan_weak_hashtables ()
scan_weak_hashtables (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{ {
SCM *next = &weak_hashtables; SCM *next = &weak_hashtables;
SCM h = *next; SCM h = *next;
@ -243,34 +232,12 @@ scan_weak_hashtables (void *dummy1 SCM_UNUSED,
*next = h = SCM_HASHTABLE_NEXT (h); *next = h = SCM_HASHTABLE_NEXT (h);
else else
{ {
SCM alist; SCM vec = SCM_HASHTABLE_VECTOR (h);
int i, n = SCM_HASHTABLE_N_BUCKETS (h); size_t delta = SCM_I_WVECT_DELTA (vec);
int weak_car = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CAR; SCM_I_SET_WVECT_DELTA (vec, 0);
int weak_cdr = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CDR; SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta);
int check_size_p = 0;
for (i = 0; i < n; ++i) if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
{
SCM *next_spine = NULL;
alist = SCM_HASHTABLE_BUCKET (h, i);
while (scm_is_pair (alist))
{
if ((weak_car && UNMARKED_CELL_P (SCM_CAAR (alist)))
|| (weak_cdr && UNMARKED_CELL_P (SCM_CDAR (alist))))
{
if (next_spine)
*next_spine = SCM_CDR (alist);
else
SCM_SET_HASHTABLE_BUCKET (h, i, SCM_CDR (alist));
SCM_HASHTABLE_DECREMENT (h);
check_size_p = 1;
}
else
next_spine = SCM_CDRLOC (alist);
alist = SCM_CDR (alist);
}
}
if (check_size_p
&& SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
{ {
SCM tmp = SCM_HASHTABLE_NEXT (h); SCM tmp = SCM_HASHTABLE_NEXT (h);
/* temporarily move table from weak_hashtables to to_rehash */ /* temporarily move table from weak_hashtables to to_rehash */
@ -285,7 +252,6 @@ scan_weak_hashtables (void *dummy1 SCM_UNUSED,
} }
} }
} }
return 0;
} }
static void * static void *
@ -1104,7 +1070,6 @@ scm_hashtab_prehistory ()
scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr); scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
scm_set_smob_print (scm_tc16_hashtable, hashtable_print); scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
scm_set_smob_free (scm_tc16_hashtable, hashtable_free); scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
scm_c_hook_add (&scm_after_sweep_c_hook, scan_weak_hashtables, 0, 0);
scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0); scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
} }

1
libguile/hashtab.h
View file

@ -97,6 +97,7 @@ SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h); SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
SCM_API void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char*func_name); SCM_API void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char*func_name);
SCM_API void scm_i_scan_weak_hashtables (void);
SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);

1
libguile/init.c
View file

@ -428,7 +428,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_struct_prehistory (); /* requires storage */ scm_struct_prehistory (); /* requires storage */
scm_symbols_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */
scm_weaks_prehistory (); /* requires storage */
scm_init_subr_table (); scm_init_subr_table ();
scm_environments_prehistory (); /* requires storage */ scm_environments_prehistory (); /* requires storage */
scm_modules_prehistory (); /* requires storage and hash tables */ scm_modules_prehistory (); /* requires storage and hash tables */

4
libguile/vectors.h
View file

@ -94,8 +94,8 @@ SCM_API SCM scm_i_vector_equal_p (SCM x, SCM y);
#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH #define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS #define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS #define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
#define SCM_I_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x)) #define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_2 (x))
#define SCM_I_SET_WVECT_TYPE(x, t) (SCM_SET_CELL_WORD_2 ((x),(t))) #define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_2 ((x),(t)))
#define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x)) #define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x))
#define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o))) #define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o)))

256
libguile/weaks.c
View file

@ -42,6 +42,8 @@
#include <stdio.h>
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/lang.h" #include "libguile/lang.h"
@ -201,132 +203,180 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0
} }
#undef FUNC_NAME #undef FUNC_NAME
static void *
scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
scm_weak_vectors = SCM_EOL;
return 0;
}
static void *
scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
SCM w;
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w))
{
if (SCM_IS_WHVEC_ANY (w))
{
SCM const *ptr;
SCM obj;
long j;
long n;
obj = w;
ptr = SCM_I_WVECT_GC_WVELTS (w);
n = SCM_I_WVECT_LENGTH (w);
for (j = 0; j < n; ++j)
{
SCM alist;
alist = ptr[j];
while ( scm_is_pair (alist)
&& !SCM_GC_MARK_P (alist)
&& scm_is_pair (SCM_CAR (alist)))
{
SCM_SET_GC_MARK (alist);
SCM_SET_GC_MARK (SCM_CAR (alist));
alist = SCM_CDR (alist);
}
}
}
}
return 0;
}
#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
static void * static SCM weak_vectors;
scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED, void
void *dummy3 SCM_UNUSED) scm_i_init_weak_vectors_for_gc ()
{ {
SCM *ptr, w; weak_vectors = SCM_EOL;
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w)) }
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))
{ {
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)
{ {
register long j, n; SCM alist, slow_alist;
int slow_toggle = 0;
ptr = SCM_I_WVECT_GC_WVELTS (w); /* We do not set the mark bits of the alist spine cells here
n = SCM_I_WVECT_LENGTH (w); since we do not want to ever create the situation where a
for (j = 0; j < n; ++j) marked cell references an unmarked cell (except in
if (UNMARKED_CELL_P (ptr[j])) scm_gc_mark, where the referenced cells will be marked
ptr[j] = SCM_BOOL_F; immediately). Thus, we can not use mark bits to stop us
} from looping indefinitely over a cyclic alist. Instead,
/* check if we should scan the alist vector here (hashtables we use the standard tortoise and hare trick to catch
have their own scan function in hashtab.c). */ cycles. The fast walker does the work, and stops when it
else if (!SCM_WVECT_NOSCAN_P (w)) catches the slow walker to ensure that the whole cycle
{ has been worked on.
SCM obj = w; */
register long n = SCM_I_WVECT_LENGTH (w);
register long j;
int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
ptr = SCM_I_WVECT_GC_WVELTS (w); alist = slow_alist = ptr[j];
for (j = 0; j < n; ++j) while (scm_is_pair (alist))
{ {
SCM * fixup; SCM elt = SCM_CAR (alist);
SCM alist;
fixup = ptr + j; if (UNMARKED_CELL_P (elt))
alist = *fixup;
while (scm_is_pair (alist)
&& scm_is_pair (SCM_CAR (alist)))
{ {
SCM key; if (scm_is_pair (elt))
SCM value;
key = SCM_CAAR (alist);
value = SCM_CDAR (alist);
if ( (weak_keys && UNMARKED_CELL_P (key))
|| (weak_values && UNMARKED_CELL_P (value)))
{ {
*fixup = SCM_CDR (alist); 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 else
fixup = SCM_CDRLOC (alist); {
alist = SCM_CDR (alist); /* 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 0; 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)
{
SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
size_t n = SCM_I_WVECT_LENGTH (w);
size_t i;
if (!SCM_IS_WHVEC_ANY (w))
{
for (i = 0; i < n; ++i)
if (UNMARKED_CELL_P (ptr[i]))
ptr[i] = SCM_BOOL_F;
}
else
{
size_t delta = 0;
for (i = 0; i < n; ++i)
{
SCM alist, *fixup;
fixup = ptr + i;
alist = *fixup;
while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
{
if (UNMARKED_CELL_P (SCM_CAR (alist)))
{
*fixup = SCM_CDR (alist);
delta++;
}
else
{
SCM_SET_GC_MARK (alist);
fixup = SCM_CDRLOC (alist);
}
alist = *fixup;
}
}
#if 0
if (delta)
fprintf (stderr, "vector %p, delta %d\n", w, delta);
#endif
SCM_I_SET_WVECT_DELTA (w, delta);
}
}
void
scm_i_remove_weaks_from_weak_vectors ()
{
SCM w = weak_vectors;
while (!scm_is_null (w))
{
scm_i_remove_weaks (w);
w = SCM_I_WVECT_GC_CHAIN (w);
}
} }
void
scm_weaks_prehistory ()
{
scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0);
scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0);
scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
}
SCM SCM
scm_init_weaks_builtins () scm_init_weaks_builtins ()
{ {

35
libguile/weaks.h
View file

@ -28,17 +28,28 @@
#define SCM_WVECTF_WEAK_KEY 1 #define SCM_WVECTF_WEAK_KEY 1
#define SCM_WVECTF_WEAK_VALUE 2 #define SCM_WVECTF_WEAK_VALUE 2
#define SCM_WVECTF_NOSCAN 4
#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_KEY) #define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_VALUE) #define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)
#define SCM_WVECT_NOSCAN_P(x) (SCM_I_WVECT_TYPE (x) & SCM_WVECTF_NOSCAN)
#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
SCM_API SCM scm_weak_vectors; /* The DELTA field is used by the abstract hash tables. During GC,
this field will be set to the number of items that have been
dropped. The abstract hash table will then use it to update its
item count. DELTA is unsigned.
*/
#define SCM_I_WVECT_DELTA(x) (SCM_I_WVECT_EXTRA(x) >> 3)
#define SCM_I_SET_WVECT_DELTA(x,n) (SCM_I_SET_WVECT_EXTRA \
((x), ((SCM_I_WVECT_EXTRA (x) & 7) \
| ((n) << 3))))
#define SCM_I_WVECT_TYPE(x) (SCM_I_WVECT_EXTRA(x) & 7)
#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA \
((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
@ -51,10 +62,14 @@ SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
SCM_API SCM scm_weak_key_alist_vector_p (SCM x); SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
SCM_API SCM scm_weak_value_alist_vector_p (SCM x); SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x); SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
SCM_API void scm_weaks_prehistory (void);
SCM_API SCM scm_init_weaks_builtins (void); SCM_API SCM scm_init_weaks_builtins (void);
SCM_API void scm_init_weaks (void); SCM_API void scm_init_weaks (void);
SCM_API void scm_i_init_weak_vectors_for_gc (void);
SCM_API void scm_i_mark_weak_vector (SCM w);
SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
#endif /* SCM_WEAKS_H */ #endif /* SCM_WEAKS_H */
/* /*