First stab at the guardian implementation. Works fine at first glance!

* libguile/guardians.c: Overhauled.  Removed the `tconc' structure.
  Much, much, simpler.
  (finalize_guarded): New function.

* libguile/init.c (scm_i_init_guile): Call `scm_init_guardians ()'.

git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-11

libguile/guardians.c

@@ -16,8 +16,6 @@
  */
 
 
-#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
@@ -38,6 +36,9 @@
  * 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.
  */
 
 
@@ -54,150 +55,25 @@
 #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;
+  unsigned long live;
-  t_tconc zombies;
+  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)
@@ -208,9 +84,9 @@ 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);
@@ -218,6 +94,56 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
   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)
 {
@@ -225,9 +151,30 @@ scm_i_guard (SCM guardian, SCM obj)
 
   if (!SCM_IMP (obj))
     {
-      SCM z;
+      /* Register a finalizer and pass a list of guardians interested in OBJ
-      z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
+	 as the ``client data'' argument.  */
-      TCONC_IN (g->live, obj, z);
+      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);
+	}
     }
 }
 
@@ -237,8 +184,12 @@ scm_i_get_one_zombie (SCM guardian)
   t_guardian *g = GUARDIAN_DATA (guardian);
   SCM res = SCM_BOOL_F;
 
-  if (!TCONC_EMPTYP (g->zombies))
+  if (g->zombies != SCM_EOL)
-    TCONC_OUT (g->zombies, res);
+    {
+      /* Note: We return zombies in reverse order.  */
+      res = SCM_CAR (g->zombies);
+      g->zombies = SCM_CDR (g->zombies);
+    }
 
   return res;
 }
@@ -315,13 +266,11 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
 #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->live = 0;
-  g->zombies.head = g->zombies.tail = z2;
+  g->zombies = SCM_EOL;
 
   g->next = NULL;
 
@@ -334,9 +283,11 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
 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);
@@ -352,5 +303,3 @@ scm_init_guardians ()
   c-file-style: "gnu"
   End:
 */
-
-#endif

libguile/init.c

@@ -517,7 +517,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_vectors ();
   scm_init_version ();
   scm_init_weaks ();
-/*   scm_init_guardians (); */
+  scm_init_guardians ();
   scm_init_vports ();
   scm_init_eval ();
   scm_init_evalext ();