*/
\f
-#if 0 /* FIXME: Not re-implemented for Boehm's GC. */
-
/* This is an implementation of guardians as described in
* R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
* a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
* 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...
+ *
+ * Rewritten for the Boehm-Wiser GC by Ludovic Courtès.
+ * FIXME: This is currently not thread-safe.
*/
#include "libguile/eval.h"
#include "libguile/guardians.h"
+#include <gc/gc.h>
-/* The live and zombies FIFOs are implemented as tconcs as described
- in Dybvig's paper. This decouples addition and removal of elements
- so that no synchronization between these needs to take place.
-*/
-
-typedef struct t_tconc
-{
- SCM head;
- SCM tail;
-} t_tconc;
-
-#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail))
-
-#define TCONC_IN(tc, obj, pair) \
-do { \
- SCM_SETCAR ((tc).tail, obj); \
- SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \
- SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \
- SCM_SETCDR ((tc).tail, pair); \
- (tc).tail = pair; \
-} while (0)
-
-#define TCONC_OUT(tc, res) \
-do { \
- (res) = SCM_CAR ((tc).head); \
- (tc).head = SCM_CDR ((tc).head); \
-} while (0)
static scm_t_bits tc16_guardian;
typedef struct t_guardian
{
- t_tconc live;
- t_tconc zombies;
+ unsigned long live;
+ SCM zombies;
struct t_guardian *next;
} t_guardian;
#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
-static t_guardian *guardians;
-
-void
-scm_i_init_guardians_for_gc ()
-{
- guardians = NULL;
-}
-
-/* mark a guardian by adding it to the live guardian list. */
-static SCM
-guardian_mark (SCM ptr)
-{
- t_guardian *g = GUARDIAN_DATA (ptr);
- g->next = guardians;
- guardians = g;
-
- 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
-guardian_free (SCM ptr)
-{
- scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian");
- return 0;
-}
static int
guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
scm_uintprint ((scm_t_bits) g, 16, port);
scm_puts (" (reachable: ", port);
- scm_display (scm_length (SCM_CDR (g->live.head)), port);
+ scm_display (scm_from_uint (g->live), port);
scm_puts (" unreachable: ", port);
- scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
+ scm_display (scm_length (g->zombies), port);
scm_puts (")", port);
scm_puts (">", port);
return 1;
}
+/* Handle finalization of OBJ which is guarded by the guardians listed in
+ GUARDIAN_LIST. */
+static void
+finalize_guarded (GC_PTR obj, GC_PTR guardian_list)
+{
+ SCM cell_pool;
+
+#if 0
+ printf ("finalizing guarded %p (%u guardians)\n",
+ obj, scm_to_uint (scm_length (guardian_list)));
+ scm_write (guardian_list, scm_current_output_port ());
+#endif
+
+ /* Preallocate a bunch of cells so that we can make sure that no garbage
+ collection (and, thus, nested calls to `finalize_guarded ()') occurs
+ while executing the following loop. This is quite inefficient (call to
+ `scm_length ()') but that shouldn't be a problem in most cases. */
+ cell_pool = scm_make_list (scm_length (guardian_list), SCM_UNSPECIFIED);
+
+ /* Tell each guardian interested in OBJ that OBJ is no longer
+ reachable. */
+ for (;
+ guardian_list != SCM_EOL;
+ guardian_list = SCM_CDR (guardian_list))
+ {
+ SCM zombies;
+ t_guardian *g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+
+ if (g->live == 0)
+ abort ();
+
+ /* Get a fresh cell from CELL_POOL. */
+ zombies = cell_pool;
+ cell_pool = SCM_CDR (cell_pool);
+
+ /* Compute and update G's zombie list. */
+ SCM_SETCAR (zombies, SCM_PACK (obj));
+ SCM_SETCDR (zombies, g->zombies);
+ g->zombies = zombies;
+
+ g->live--;
+ g->zombies = zombies;
+ }
+
+#if 0
+ printf ("end of finalize (%p)\n", obj);
+#endif
+}
+
+/* Add OBJ as a guarded object of GUARDIAN. */
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);
+ /* Register a finalizer and pass a list of guardians interested in OBJ
+ as the ``client data'' argument. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_data;
+ SCM guardians_for_obj;
+
+ g->live++;
+ guardians_for_obj = scm_cons (guardian, SCM_EOL);
+
+ GC_REGISTER_FINALIZER_NO_ORDER ((GC_PTR)obj, finalize_guarded,
+ (GC_PTR)guardians_for_obj,
+ &prev_finalizer, &prev_data);
+
+ if ((prev_finalizer == finalize_guarded) && (prev_data != NULL))
+ {
+ /* OBJ is already guarded by another guardian: add GUARDIAN to its
+ list of guardians. */
+ SCM prev_guardian_list = SCM_PACK (prev_data);
+
+ if (!scm_is_pair (prev_guardian_list))
+ abort ();
+
+ SCM_SETCDR (guardians_for_obj, prev_guardian_list);
+ }
}
}
t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F;
- if (!TCONC_EMPTYP (g->zombies))
- TCONC_OUT (g->zombies, res);
+ if (g->zombies != SCM_EOL)
+ {
+ /* Note: We return zombies in reverse order. */
+ res = SCM_CAR (g->zombies);
+ g->zombies = SCM_CDR (g->zombies);
+ }
return res;
}
#define FUNC_NAME s_scm_make_guardian
{
t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
- SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
- SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
SCM z;
/* A tconc starts out with one tail pair. */
- g->live.head = g->live.tail = z1;
- g->zombies.head = g->zombies.tail = z2;
+ g->live = 0;
+ g->zombies = SCM_EOL;
g->next = NULL;
void
scm_init_guardians ()
{
+ /* We use unordered finalization `a la Java. */
+ GC_java_finalization = 1;
+
tc16_guardian = scm_make_smob_type ("guardian", 0);
- scm_set_smob_mark (tc16_guardian, guardian_mark);
- scm_set_smob_free (tc16_guardian, guardian_free);
+
scm_set_smob_print (tc16_guardian, guardian_print);
#if ENABLE_DEPRECATED
scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
c-file-style: "gnu"
End:
*/
-
-#endif
HCoop / bpt / guile.git / blobdiff