-/* Copyright (C) 1998, 1999 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
-
-\f
-
-/* 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
- * Programming Language Design and Implementation, June 1993
- * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
- *
- * Author: Michael N. Livshin
- * Modified by: Mikael Djurfeldt
- */
-
-#include <stdio.h>
-#include <assert.h>
-
-#include "_scm.h"
-#include "print.h"
-#include "smob.h"
-#include "vectors.h"
-
-#include "validate.h"
-#include "guardians.h"
-
-static long scm_tc16_guardian;
-
-/* 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.
-*/
-#define TCONC_IN(tc, obj, pair) \
-do { \
- SCM_SETCAR ((tc).tail, obj); \
- SCM_SETCAR (pair, SCM_BOOL_F); \
- SCM_SETCDR (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)
-
-#define TCONC_EMPTYP(tc) ((tc).head == (tc).tail)
-
-typedef struct tconc_t
-{
- SCM head;
- SCM tail;
-} tconc_t;
-
-typedef struct guardian_t
-{
- tconc_t live;
- tconc_t zombies;
- struct guardian_t *next;
-} guardian_t;
-
-#define GUARDIAN(x) ((guardian_t *) SCM_CDR (x))
-#define GUARDIAN_LIVE(x) (GUARDIAN (x)->live)
-#define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies)
-#define GUARDIAN_NEXT(x) (GUARDIAN (x)->next)
-
-static guardian_t *first_live_guardian = NULL;
-static guardian_t **current_link_field = NULL;
-
-static SCM
-g_mark (SCM ptr)
-{
- *current_link_field = GUARDIAN (ptr);
- current_link_field = &GUARDIAN_NEXT (ptr);
- GUARDIAN_NEXT (ptr) = NULL;
-
- /* Can't mark zombies here since they can refer to objects which are
- living dead, thereby preventing them to join the zombies. */
- return SCM_BOOL_F;
-}
-
-static int
-g_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- char buf[256];
- sprintf (buf, "#<guardian live objs: %lu zombies: %lu>",
- scm_ilength (SCM_CDR (GUARDIAN_LIVE (exp).head)),
- scm_ilength (SCM_CDR (GUARDIAN_ZOMBIES (exp).head)));
- scm_puts (buf, port);
-
- return 1;
-}
-
-#define CCLO_G(cclo) (SCM_VELTS (cclo)[1])
-
-static SCM
-guard (SCM cclo, SCM arg)
-{
- if (!SCM_UNBNDP (arg))
- {
- scm_guard (cclo, arg);
- return SCM_UNSPECIFIED;
- }
- else
- return scm_get_one_zombie (cclo);
-}
-
-static SCM guard1;
-
-SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
- (),
- "Return a new guardian object.\n"
- "A guardian allows dynamically allocated objects to be\n"
- "saved from deallocation by the garbage collector so that\n"
- "clean up or other actions can be performed using the data\n"
- "stored within the objects.\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.")
-#define FUNC_NAME s_scm_make_guardian
-{
- SCM cclo = scm_makcclo (guard1, 2L);
- guardian_t *g = SCM_MUST_MALLOC_TYPE(guardian_t);
- SCM z1 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
- SCM z2 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
- SCM z;
- /* A tconc starts out with one tail pair. */
- g->live.head = g->live.tail = z1;
- g->zombies.head = g->zombies.tail = z2;
-
- SCM_NEWSMOB (z, scm_tc16_guardian, g);
-
- CCLO_G (cclo) = z;
-
- return cclo;
-}
-#undef FUNC_NAME
-
-void
-scm_guardian_gc_init()
-{
- current_link_field = &first_live_guardian;
- first_live_guardian = NULL;
-}
-
-void
-scm_guardian_zombify ()
-{
- guardian_t *g;
-
- /* Note that new guardians may be stuck on the end of the live
- guardian list as we run this loop. As we move unmarked objects
- to the zombie list and mark them, we may find some guarded
- guardians. The guardian mark function will stick them on the end
- of this list, so they'll be processed properly. */
- for (g = first_live_guardian; g; g = g->next)
- {
- /* Scan the live list for unmarked objects, and move them to the
- zombies tconc. */
- SCM tconc_tail = g->live.tail;
- SCM *prev_ptr = &g->live.head;
- SCM pair = g->live.head;
-
- while (pair != tconc_tail)
- {
- SCM next_pair = SCM_CDR (pair);
-
- if (SCM_NMARKEDP (SCM_CAR (pair)))
- {
- /* got you, zombie! */
-
- /* out of the live list! */
- *prev_ptr = next_pair;
-
- /* to 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. */
- for (pair = g->live.head; SCM_NIMP (pair); pair = SCM_GCCDR (pair))
- SCM_SETGCMARK (pair);
-
- /* Bring the zombies back from the dead. */
- scm_gc_mark (g->zombies.head);
- }
-}
-
-void
-scm_guard (SCM guardian, SCM obj)
-{
- SCM g = CCLO_G (guardian);
-
- if (SCM_NIMP (obj))
- {
- SCM z;
-
- SCM_NEWCELL (z);
-
- /* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
- TCONC_IN (GUARDIAN_LIVE (g), obj, z);
- SCM_ALLOW_INTS;
- }
-}
-
-SCM
-scm_get_one_zombie (SCM guardian)
-{
- SCM g = CCLO_G (guardian);
- SCM res = SCM_BOOL_F;
-
- /* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
- if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (g)))
- TCONC_OUT (GUARDIAN_ZOMBIES (g), res);
- SCM_ALLOW_INTS;
-
- return res;
-}
-
-void
-scm_init_guardian()
-{
- scm_tc16_guardian = scm_make_smob_type_mfpe ("guardian", sizeof (guardian_t),
- g_mark, NULL, g_print, NULL);
- guard1 = scm_make_subr_opt ("guardian", scm_tc7_subr_2o, guard, 0);
-
-#include "guardians.x"
-}
+/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
+
+\f
+
+/* 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
+ * Programming Language Design and Implementation, June 1993
+ * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
+ *
+ * By this point, the semantics are actually quite different from
+ * those described in the abovementioned paper. The semantic changes
+ * are there to improve safety and intuitiveness. The interface is
+ * still (mostly) the one described by the paper, however.
+ *
+ * Original design: Mikael Djurfeldt
+ * Original implementation: Michael Livshin
+ * Hacked on since by: everybody
+ */
+
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/smob.h"
+#include "libguile/validate.h"
+#include "libguile/root.h"
+#include "libguile/hashtab.h"
+#include "libguile/weaks.h"
+
+#include "libguile/guardians.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;
+ struct t_guardian *next;
+ unsigned long flags;
+} t_guardian;
+
+#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
+#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
+
+#define F_GREEDY 1L
+#define F_LISTED (1L << 1)
+#define F_DESTROYED (1L << 2)
+
+#define GREEDY_P(x) (((x)->flags & F_GREEDY) != 0)
+#define SET_GREEDY(x) ((x)->flags |= F_GREEDY)
+
+#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))
+ 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. */
+static SCM
+guardian_mark (SCM ptr)
+{
+ add_to_live_list (GUARDIAN_DATA (ptr));
+
+ /* 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;
+}
+
+
+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)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+
+ scm_puts ("#<", 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);
+
+ if (! DESTROYED_P (g))
+ {
+ scm_puts (" (reachable: ", port);
+ scm_display (scm_length (SCM_CDR (g->live.head)), port);
+ scm_puts (" unreachable: ", port);
+ scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
+ scm_puts (")", port);
+ }
+
+ scm_puts (">", port);
+
+ return 1;
+}
+
+
+/* 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,
+ * the next available unreachable object (or #f if none) is returned.
+ *
+ * If the second optional argument THROW_P is true (the default), then
+ * an error is raised if GUARDIAN is greedy and OBJ is already greedily
+ * guarded. If THROW_P is false, #f is returned instead of raising the
+ * error, and #t is returned if everything is fine.
+ */
+static SCM
+guardian_apply (SCM guardian, SCM obj, SCM throw_p)
+{
+ if (DESTROYED_P (GUARDIAN_DATA (guardian)))
+ scm_misc_error ("guard", "attempted use of destroyed guardian: ~A",
+ scm_list_1 (guardian));
+
+ 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;
+
+ /* This critical section barrier will be replaced by 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);
+ }
+
+ z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
+ TCONC_IN (g->live, obj, z);
+
+ SCM_CRITICAL_SECTION_END;
+ }
+
+ return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T;
+}
+
+
+SCM
+scm_get_one_zombie (SCM guardian)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+ SCM res = SCM_BOOL_F;
+
+ /* This critical section barrier will be replaced by a mutex. */
+ SCM_CRITICAL_SECTION_START;
+
+ if (!TCONC_EMPTYP (g->zombies))
+ TCONC_OUT (g->zombies, res);
+
+ if (scm_is_true (res) && GREEDY_P (g))
+ scm_hashq_remove_x (greedily_guarded_whash, res);
+
+ SCM_CRITICAL_SECTION_END;
+
+ return res;
+}
+
+
+SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
+ (SCM greedy_p),
+ "Create a new guardian.\n"
+ "A guardian protects a set of objects from garbage collection,\n"
+ "allowing a program to apply cleanup or other actions.\n\n"
+
+ "@code{make-guardian} returns a procedure representing the guardian.\n"
+ "Calling the guardian procedure with an argument adds the\n"
+ "argument to the guardian's set of protected objects.\n"
+ "Calling the guardian procedure without an argument returns\n"
+ "one of the protected objects which are ready for garbage\n"
+ "collection, or @code{#f} if no such object is available.\n"
+ "Objects which are returned in this way are removed from\n"
+ "the guardian.\n\n"
+
+ "@code{make-guardian} takes one optional argument that says whether the\n"
+ "new guardian should be greedy or sharing. If there is any chance\n"
+ "that any object protected by the guardian may be resurrected,\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
+{
+ 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->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);
+
+ return z;
+}
+#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;
+
+ 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
+scm_init_guardians ()
+{
+ 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);
+ scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
+
+ scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0);
+ scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0);
+
+ 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"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff