X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/a6b844c224b65f99300aa0f516fadbef50e7c8aa..806f1ded951f92cdd3ed243daad5d97754568480:/libguile/guardians.c diff --git a/libguile/guardians.c b/libguile/guardians.c dissimilarity index 79% index b69d0f5e9..f7bbb4b02 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -1,640 +1,357 @@ -/* Copyright (C) 1998,1999,2000,2001 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. */ - - - -/* 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_EQ_P ((tc).head, (tc).tail)) - -#define TCONC_IN(tc, obj, pair) \ -do { \ - SCM_SETCAR ((tc).tail, obj); \ - SCM_SET_CELL_WORD_1 (pair, SCM_EOL); \ - SCM_SET_CELL_WORD_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_FALSEP (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_FALSEP (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_FALSEP (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_FALSEP (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_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_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_EQ_P (pair, tc->tail); - pair = next_pair) - { - SCM obj = SCM_CAR (pair); - next_pair = SCM_CDR (pair); - - if (! SCM_MARKEDP (obj)) - { - /* a candidate for finalizing */ - scm_gc_mark_dependencies (obj); - - if (SCM_MARKEDP (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_SETGCMARK (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_EQ_P (pair, tconc_tail)) - { - SCM next_pair = SCM_CDR (pair); - - if (!SCM_MARKEDP (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_SETGCMARK (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_NULLP (pair); pair = SCM_CDR (pair)) - SCM_SETGCMARK (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_NULLP (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_NULLP (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_MAKINUM (31))); - -#include "libguile/guardians.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +/* Copyright (C) 1998,1999,2000,2001, 2006, 2008 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 + */ + + + +/* 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... + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#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/deprecation.h" +#include "libguile/eval.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; +} 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) +{ + t_guardian *g = GUARDIAN_DATA (guardian); + + scm_puts ("#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; +} + +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 + * 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 ENABLE_DEPRECATED + if (!SCM_UNBNDP (throw_p)) + scm_c_issue_deprecation_warning + ("Using the 'throw?' argument of a guardian is deprecated " + "and ineffective."); +#endif + + 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 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; + + SCM_NEWSMOB (z, tc16_guardian, g); + + return z; +} +#undef FUNC_NAME + +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); +#if ENABLE_DEPRECATED + scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0); +#else + scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0); +#endif + +#include "libguile/guardians.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/