[PATCH] Marking weak alist vectors

[Ludovic Courtès]

Hi,

The patch below fixes a bug in the garbage collection process of weak
alist vectors.  Without the patch, a value attached to a weak key (or
the opposite) may be freed just _before_ the weak key in question is
freed.

The problem stems from the fact that `scm_i_mark_weak_vector_non_weaks ()'
would not mark a value attached to a weak key if that weak key is
unmarked.  Therefore, both the weak key and its associated value become
unmarked during the very same mark phase.  And since the order in which
they are swept during the subsequent sweep phase is undefined, we have a
problem.

The patch fixes `scm_i_mark_weak_vector_non_weaks ()'.  This way, a
value attached to a weak key will only become unmarked during the mark
phase _after_ the mark phase during which its weak key became unmarked.
You might want to re-read this sentence carefully.  ;-)

I wrote a test case for this which is to be installed as
`test-suite/standalone/test-weaks.c'.  It uses object properties.

This patch has an undesired side effect: it makes `gc.test' fail.  I'll
have to dig into this.  But we probably had better treat this problem
independently given this (using Guile CVS):

  $ guile
  guile> (gc-live-object-stats)
  Segmentation fault (core dumped)

BTW, in `scm_init_properties ()', SCM_PROPERTIES_WHASH was not made
permanent, which looks like an error.

Thanks,
Ludovic.


libguile/ChangeLog

2005-11-08  Ludovic Courtès  <address@hidden>

        * gc-mark.c (scm_mark_all): Removed C++/C99-style comment.

        * properties.c (scm_init_properties): Make SCM_PROPERTIES_WHASH
        a permanent object.
    
        * weaks.c (weak_vectors): Initialize it to `SCM_EOL'.
        (scm_i_mark_weak_vector_non_weaks): When WEAK_KEYS is false and KEY is
        unmarked, mark it recursively.  Likewise, when WEAK_VALUES if false and
        VALUE is unmarked, mark it recursively.
        (scm_i_remove_weaks): Don't only check whether the first pair in ALIST
        is unmarked: check whether either its KEY (when WEAK_KEYS is true) or
        VALUE (when WEAK_VALUES is true) is unmarked.


test-suite/ChangeLog

2005-11-08  Ludovic Courtès  <address@hidden>

        * standalone/Makefile.am (TESTS): Added `test-weaks'.
        (check_PROGRAMS): Likewise.
    
        * standalone/test-weaks.c: New file.



--- orig/libguile/gc-mark.c
+++ mod/libguile/gc-mark.c
@@ -74,7 +74,7 @@
 
   scm_i_init_weak_vectors_for_gc ();
   scm_i_init_guardians_for_gc ();
-  
+
   scm_i_clear_mark_space ();
   
   /* Mark every thread's stack and registers */
@@ -138,12 +138,9 @@
       break;
     }
 
-  //fprintf (stderr, "%d loops\n", loops);
-
-  /* Remove all unmarked entries from the weak vectors.
-   */
+  /* Remove all unmarked entries from the weak vectors.  */
   scm_i_remove_weaks_from_weak_vectors ();
-  
+
   /* Bring hashtables upto date.
    */
   scm_i_scan_weak_hashtables ();


--- orig/libguile/properties.c
+++ mod/libguile/properties.c
@@ -125,6 +125,7 @@
 scm_init_properties ()
 {
   scm_properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+  scm_properties_whash = scm_permanent_object (scm_properties_whash);
 #include "libguile/properties.x"
 }
 

--- orig/libguile/weaks.c
+++ mod/libguile/weaks.c
@@ -205,7 +205,11 @@
 
 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
 
-static SCM weak_vectors;
+/* A list of live weak vectors, updated each time a weak vector is marked (in
+   `scm_i_mark_weak_vector ()') and cleared at the beginning of each mark
+   phase (in `scm_mark_all ()' which calls
+   `scm_i_init_weak_vectors_for_gc ()').  */
+static SCM weak_vectors = SCM_EOL;
 
 void
 scm_i_init_weak_vectors_for_gc ()
@@ -264,14 +268,18 @@
                    {
                      SCM key = SCM_CAR (elt);
                      SCM value = SCM_CDR (elt);
-                 
-                     if (!((weak_keys && UNMARKED_CELL_P (key))
-                           || (weak_values && UNMARKED_CELL_P (value))))
+
+                     if ((!weak_keys) && (UNMARKED_CELL_P (key)))
+                       scm_gc_mark (key);
+
+                     if ((!weak_values) && (UNMARKED_CELL_P (value)))
+                       scm_gc_mark (value);
+
+                     if ((!UNMARKED_CELL_P (key))
+                         && (!UNMARKED_CELL_P (value)))
                        {
-                         /* The item should be kept.  We need to mark it
-                            recursively.
-                         */ 
-                         scm_gc_mark (elt);
+                         /* The whole pair should be kept.  */
+                         SCM_SET_GC_MARK (elt);
                          again = 1;
                        }
                    }
@@ -323,6 +331,8 @@
 {
   SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
   size_t n = SCM_I_WVECT_LENGTH (w);
+  int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w);
+  int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w);
   size_t i;
 
   if (!SCM_IS_WHVEC_ANY (w))
@@ -343,8 +353,13 @@
          alist = *fixup;
          while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
            {
-             if (UNMARKED_CELL_P (SCM_CAR (alist)))
+             SCM elt = SCM_CAR (alist);
+             SCM key = SCM_CAR (elt), value = SCM_CDR (elt);
+
+             if ((weak_keys && UNMARKED_CELL_P (key))
+                 || (weak_values && UNMARKED_CELL_P (value)))
                {
+                 /* Remove this pair from ALIST.  */
                  *fixup = SCM_CDR (alist);
                  delta++;
                }


--- orig/test-suite/standalone/Makefile.am
+++ mod/test-suite/standalone/Makefile.am
@@ -74,6 +74,13 @@
 check_PROGRAMS += test-conversion
 TESTS += test-conversion
 
+# test-weaks
+test_weaks_SOURCES = test-weaks.c
+test_weaks_CFLAGS = ${test_cflags}
+test_weaks_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-weaks
+TESTS += test-weaks
+
 all-local:
        cd ${srcdir} && chmod u+x ${check_SCRIPTS}
 



test-weaks.c:

--8<---------------cut here---------------start------------->8---
/* Copyright (C) 2005 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */


/* This test case targets garbage collection of weak hash tables.  It does so
   by using object properties (which are currently implemented using weak
   hash tables) and verifying that properties attached to an object are
   always GC'd _after_ the object itself has been freed.

   In order to do so, `test_weak_gc ()' creates a number of SMOBs.  The C
   structure underlying those SMOBs explicitly maintains a reference counter
   for each instance.  This reference counter is:

   1. incremented each time a SMOB is attached to another SMOB (by means of
      object properties);

   2. decremented each time a SMOB that was attached to another SMOB is
      freed.  For instance if A is attached to B, when B is GC'd, A's
      reference counter is decremented.

   The invariant that we check is: any SMOB that is GC'd must have its
   reference count equal to zero.  */


#include "libguile.h"

#include <stdio.h>
#include <assert.h>

/* Number of time a `my-object' SMOB was freed.  */
static unsigned free_count = 0;

static scm_t_bits my_object_type = 0;
static SCM        some_property = SCM_BOOL_F;
static SCM my_object_new_smob_proc = SCM_BOOL_F,
  attach_object_proc = SCM_BOOL_F;

typedef struct my_object
{
  struct my_object *attached_to;

  unsigned ref_count;
  int      freed;
} my_object_t;


static void
my_object_init (my_object_t *obj)
{
  obj->attached_to = NULL;
  obj->ref_count = 0;
  obj->freed = 0;
}

static size_t
my_object_free (SCM obj)
{
  my_object_t *my_object = (my_object_t *)SCM_SMOB_DATA (obj);

  if (my_object->attached_to)
    {
      /* Decrease the reference count of the object MY_OBJECT is attached
         to.  */
      assert (my_object->attached_to->ref_count > 0);
      my_object->attached_to->ref_count--;
    }

  /* MY_OBJECT must not have been already freed and there must be no pending
     references to it.  */
  assert (!my_object->freed);
  assert (my_object->ref_count == 0);

  my_object->freed = 1;

  free_count++;

  return 0;
}


/* Return a new `my-object' SMOB.  */
static SCM
my_object_new_smob (void)
{
  my_object_t *obj;

  obj = scm_malloc (sizeof (*obj));
  my_object_init (obj);

  SCM_RETURN_NEWSMOB (my_object_type, obj);
}

/* Attach TO_BE_ATTACHED to OBJ.  */
static SCM
attach_object (SCM obj, SCM to_be_attached)
{
  my_object_t *c_obj, *c_to_be_attached;

  assert (SCM_SMOB_PREDICATE (my_object_type, obj));
  assert (SCM_SMOB_PREDICATE (my_object_type, to_be_attached));

  /* TO_BE_ATTACHED is attached as a property of OBJ.  As such, OBJ will get
     GC'd _before_ TO_BE_ATTACHED.  */
  scm_primitive_property_set_x (some_property, obj, to_be_attached);
  c_obj = (my_object_t *)SCM_SMOB_DATA (obj);
  c_to_be_attached = (my_object_t *)SCM_SMOB_DATA (to_be_attached);

  /* Because TO_BE_ATTACHED is to be freed _after_ OBJ, we can increase its
     reference count and it should be zero by the time it is freed.  */
  c_to_be_attached->ref_count++;
  c_obj->attached_to = c_to_be_attached;

  return obj;
}


/* Instantiate a number of `my-object' SMOBs, attached some of them together,
   invoke the GC, and wait until all of these SMOBs have been freed.  */
static void
test_weak_gc (void)
{
#define PAIRS 500
  unsigned pair_count, total;

  for (pair_count = 0, total = 0;
       pair_count < PAIRS;
       pair_count++)
    {
      SCM obj, attached;

      obj = my_object_new_smob ();
      attached = my_object_new_smob ();

#if 0
      printf ("%p attached to %p\n",
              SCM_SMOB_DATA (obj), SCM_SMOB_DATA (attached));
#endif

      attach_object (obj, attached);
      my_object_new_smob ();
      total += 3;

      obj = attached = SCM_BOOL_F;
    }

  while (free_count < total)
    {
      unsigned i;
      scm_gc ();

      for (i = 0; i < 1000; i++)
        scm_cons (SCM_I_MAKINUM (0), SCM_I_MAKINUM (0));
    }
}


int
main (int argc, char *argv[])
{
  scm_init_guile ();

  my_object_type = scm_make_smob_type ("test-object", 0);
  scm_set_smob_free (my_object_type, my_object_free);

  some_property = scm_primitive_make_property (SCM_BOOL_F);

  my_object_new_smob_proc =
    scm_c_make_gsubr ("make-my-object", 0, 0, 0, my_object_new_smob);
  attach_object_proc =
    scm_c_make_gsubr ("attach-object!", 0, 0, 0, attach_object);

  test_weak_gc ();

  return 0;
}
--8<---------------cut here---------------end--------------->8---