-/* 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/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_intprint ((long) 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_DEFER_INTS;
-
- if (GREEDY_P (g))
- {
- if (scm_is_true (scm_hashq_get_handle
- (greedily_guarded_whash, obj)))
- {
- SCM_ALLOW_INTS;
-
- 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_ALLOW_INTS;
- }
-
- 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_DEFER_INTS;
-
- 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_ALLOW_INTS;
-
- 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_DEFER_INTS;
-
- res = scm_from_bool (DESTROYED_P (GUARDIAN_DATA (guardian)));
-
- SCM_ALLOW_INTS;
-
- 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_DEFER_INTS;
-
- if (DESTROYED_P (g))
- {
- SCM_ALLOW_INTS;
- 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_ALLOW_INTS;
-
- 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 pair;
-
- scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:",
- scm_cur_errp);
- scm_newline (scm_cur_errp);
- for (pair = self_centered_zombies;
- !scm_is_null (pair); pair = SCM_CDR (pair))
- {
- scm_display (SCM_CAR (pair), scm_cur_errp);
- scm_newline (scm_cur_errp);
- }
-
- 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:
-*/
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011,
+ * 2012, 2013 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 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
+ *
+ * Original design: Mikael Djurfeldt
+ * Original implementation: Michael Livshin
+ * Hacked on since by: everybody
+ *
+ * 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.
+ *
+ * Boiled down again: Marius Vollmer
+ *
+ * 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-Demers-Weiser GC by Ludovic Courtès.
+ */
+
+/* Uncomment the following line to debug guardian finalization. */
+/* #define DEBUG_GUARDIANS 1 */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.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/deprecation.h"
+#include "libguile/eval.h"
+
+#include "libguile/guardians.h"
+#include "libguile/bdw-gc.h"
+
+
+
+
+static scm_t_bits tc16_guardian;
+
+typedef struct t_guardian
+{
+ scm_i_pthread_mutex_t mutex;
+ 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_SMOB_DATA_1 (x))
+
+
+
+
+static int
+guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+
+ scm_puts ("#<guardian ", port);
+ scm_uintprint ((scm_t_bits) g, 16, port);
+
+ scm_puts (" (reachable: ", port);
+ scm_display (scm_from_uint (g->live), port);
+ scm_puts (" unreachable: ", 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 (void *ptr, void *finalizer_data)
+{
+ SCM cell_pool;
+ SCM obj, guardian_list, proxied_finalizer;
+
+ obj = PTR2SCM (ptr);
+ guardian_list = SCM_CDR (PTR2SCM (finalizer_data));
+ proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data));
+
+#ifdef DEBUG_GUARDIANS
+ printf ("finalizing guarded %p (%u guardians)\n",
+ ptr, scm_to_uint (scm_length (guardian_list)));
+#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 (;
+ !scm_is_null (guardian_list);
+ guardian_list = SCM_CDR (guardian_list))
+ {
+ SCM zombies;
+ t_guardian *g;
+
+ if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
+ {
+ /* The guardian itself vanished in the meantime. */
+#ifdef DEBUG_GUARDIANS
+ printf (" guardian for %p vanished\n", ptr);
+#endif
+ continue;
+ }
+
+ g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+
+ scm_i_pthread_mutex_lock (&g->mutex);
+
+ 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, obj);
+ SCM_SETCDR (zombies, g->zombies);
+ g->zombies = zombies;
+
+ g->live--;
+
+ scm_i_pthread_mutex_unlock (&g->mutex);
+ }
+
+ if (scm_is_true (proxied_finalizer))
+ {
+ /* Re-register the finalizer that was in place before we installed this
+ one. */
+ GC_finalization_proc finalizer, prev_finalizer;
+ void *finalizer_data, *prev_finalizer_data;
+
+ finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
+ finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));
+
+ if (finalizer == NULL)
+ abort ();
+
+ GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data,
+ &prev_finalizer, &prev_finalizer_data);
+
+#ifdef DEBUG_GUARDIANS
+ printf (" reinstalled proxied finalizer %p for %p\n", finalizer, ptr);
+#endif
+ }
+
+#ifdef DEBUG_GUARDIANS
+ printf ("end of finalize (%p)\n", ptr);
+#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_NIMP (obj))
+ {
+ /* Register a finalizer and pass a pair as the ``client data''
+ argument. The pair contains in its car `#f' or a pair describing a
+ ``proxied'' finalizer (see below); its cdr contains a list of
+ guardians interested in OBJ.
+
+ A ``proxied'' finalizer is a finalizer that was registered for OBJ
+ before OBJ became guarded (e.g., a SMOB `free' function). We are
+ assuming here that finalizers are only used internally, either at
+ the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
+ or by this function. */
+ GC_finalization_proc prev_finalizer;
+ void *prev_data;
+ SCM guardians_for_obj, finalizer_data;
+
+ scm_i_pthread_mutex_lock (&g->mutex);
+
+ g->live++;
+
+ /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
+ collected before the objects it guards (see `guardians.test'). */
+ guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL);
+ finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded,
+ SCM2PTR (finalizer_data),
+ &prev_finalizer, &prev_data);
+
+ if (prev_finalizer == finalize_guarded)
+ {
+ /* OBJ is already guarded by another guardian: add GUARDIAN to its
+ list of guardians. */
+ SCM prev_guardian_list, prev_finalizer_data;
+
+ if (prev_data == NULL)
+ abort ();
+
+ prev_finalizer_data = PTR2SCM (prev_data);
+ if (!scm_is_pair (prev_finalizer_data))
+ abort ();
+
+ prev_guardian_list = SCM_CDR (prev_finalizer_data);
+ SCM_SETCDR (guardians_for_obj, prev_guardian_list);
+
+ /* Also copy information about proxied finalizers. */
+ SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data));
+ }
+ else if (prev_finalizer != NULL)
+ {
+ /* There was already a finalizer registered for OBJ so we will
+ ``proxy'' it, i.e., record it so that we can re-register it once
+ `finalize_guarded ()' has finished. */
+ SCM proxied_finalizer;
+
+ proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer),
+ PTR2SCM (prev_data));
+ SCM_SETCAR (finalizer_data, proxied_finalizer);
+ }
+
+ scm_i_pthread_mutex_unlock (&g->mutex);
+ }
+}
+
+static SCM
+scm_i_get_one_zombie (SCM guardian)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+ SCM res = SCM_BOOL_F;
+
+ scm_i_pthread_mutex_lock (&g->mutex);
+
+ if (!scm_is_null (g->zombies))
+ {
+ /* Note: We return zombies in reverse order. */
+ res = SCM_CAR (g->zombies);
+ g->zombies = SCM_CDR (g->zombies);
+ }
+
+ scm_i_pthread_mutex_unlock (&g->mutex);
+
+ return res;
+}
+
+/* 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 (!SCM_UNBNDP (obj))
+ {
+ scm_i_guard (guardian, obj);
+ return SCM_UNSPECIFIED;
+ }
+ else
+ return scm_i_get_one_zombie (guardian);
+}
+
+SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
+ (),
+"Create a new guardian. A guardian protects a set of objects from\n"
+"garbage collection, allowing a program to apply cleanup or other\n"
+"actions.\n"
+"\n"
+"@code{make-guardian} returns a procedure representing the guardian.\n"
+"Calling the guardian procedure with an argument adds the argument to\n"
+"the guardian's set of protected objects. Calling the guardian\n"
+"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"
+"is available. Objects which are returned in this way are removed from\n"
+"the guardian.\n"
+"\n"
+"You can put a single object into a guardian more than once and you can\n"
+"put a single object into more than one guardian. The object will then\n"
+"be returned multiple times by the guardian procedures.\n"
+"\n"
+"An object is eligible to be returned from a guardian when it is no\n"
+"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"
+"actions, for example, you can do that by keeping objects alive in some\n"
+"global data structure until they are no longer needed for finalizing\n"
+"other objects.\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"
+"object from being returned by a guardian. But as long as an object\n"
+"can be returned from a guardian it will not be removed from such a\n"
+"weak vector or hash table. In other words, a weak link does not\n"
+"prevent an object from being considered collectable, but being inside\n"
+"a guardian prevents a weak link from being broken.\n"
+"\n"
+"A key in a weak key hash table can be though of as having a strong\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"
+"reference from the key to the value is also considered to be coming\n"
+"from within a guardian. Thus, if there is no other reference to the\n"
+ "value, it is eligible to be returned from a guardian.\n")
+#define FUNC_NAME s_scm_make_guardian
+{
+ t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
+ SCM z;
+
+ scm_i_pthread_mutex_init (&g->mutex, NULL);
+
+ /* A tconc starts out with one tail pair. */
+ g->live = 0;
+ g->zombies = SCM_EOL;
+
+ g->next = NULL;
+
+ SCM_NEWSMOB (z, tc16_guardian, g);
+
+ return z;
+}
+#undef FUNC_NAME
+
+void
+scm_init_guardians ()
+{
+ /* We use unordered finalization `a la Java. */
+#ifdef HAVE_GC_SET_JAVA_FINALIZATION
+ /* This function was added in 7.2alpha2 (June 2009). */
+ GC_set_java_finalization (1);
+#else
+ /* This symbol is deprecated as of 7.3. */
+ GC_java_finalization = 1;
+#endif
+
+ tc16_guardian = scm_make_smob_type ("guardian", 0);
+
+ scm_set_smob_print (tc16_guardian, guardian_print);
+ scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
+
+#include "libguile/guardians.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff