This is the mail archive of the guile@sourceware.cygnus.com mailing list for the Guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Re: SCM_DEBUG_FREELIST


Hello folks!

I extended the responsibilities of SCM_DEBUG_CELL_ACCESSES to also check for
any accesses to free cells.  This means, if your code accidentally drops a
reference and that cell gets collected, guile will abort as soon as the very
next access to that collected cell takes place.

When guile is compiled with SCM_DEBUG_CELL_ACCESSES=1 you can choose three
different modes of operation at run time.
- checking is disabled.  This is the default when guile starts.  However, note
  that even when checking is disabled guile will be noticeably slower.
  This mode is enabled with (set-debug-cell-accesses! #f)
- checking is enabled, but no extra garbage collections are performed.  This
  means, that guile will check _every_ access to a cell for whether the cell
  is actually on the heap and whether it is not a free cell.  In this mode
  garbage collection is only triggered at the usual moments.  This means that
  if a reference is temporarily dropped, but during that time no gc happens,
  you will still not be able to find that bug.
  This mode is enabled with (set-debug-cell-accesses! #t)
- checking is enabled and additional garbage collections are performed with a
  user selectable frequency.  Actually, the user can select after how many
  cell accesses a gc is to be performed.  Choosing a high frequency, however,
  results in a very(!!!) slow interpreter.
  This mode is enabled with (set-debug-cell-accesses! <some number>) where
  lower numbers mean a higher gc frequency.

Unfortunately, there seem to be bugs related with the code or within guile:
1) during gc sometimes there are free cells discovered.  This can be expected
   when marking the stack (for which case the checks are not performed), but
   for me it also happened when the gc was trying to mark a closure object
   that was reached from the stack.  I could not figure out what was going on
   there.  Thus, I have disabled the checking for free cells during gc
   completely (see fixme comment in function scm_check_cell).  It would be
   great if someone had an idea about what is going on there.
2) when doing (set-debug-cell-accesses! <some number>) for numbers smaller
   than 20, the system seems to run into some endless loop.  Again, your ideas
   are welcomed to figure out why this happens.

Other than that, I wish you a lot of fun with the experimental code.

Best regards
Dirk



Index: libguile/gc.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/gc.c,v
retrieving revision 1.134
diff -u -r1.134 gc.c
--- gc.c	2000/06/20 02:37:22	1.134
+++ gc.c	2000/06/23 10:34:00
@@ -84,6 +84,86 @@
 #endif
 
 
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+
+static unsigned int debug_cells_p = 0;
+static unsigned int debug_cells_gc_counter = 0;
+static unsigned int debug_cells_gc_counter_init = 0;
+
+
+void
+scm_check_cell (SCM cell) 
+{
+  if (debug_cells_p)
+    {
+      debug_cells_p = 0;  /* disable to avoid recursion */
+
+      if (!scm_cellp (cell)) 
+	{
+	  abort ();
+	}
+      else if (SCM_FREE_CELL_P (cell))
+	{
+	  /* Dirk:FIXME:: Something strange happens during gc... */
+	  if (!scm_gc_heap_lock)
+	    abort ();
+	}
+      else if (!scm_gc_heap_lock)
+	{
+	  /* Dirk:FIXME:: The test for scm_gc_heap_lock != 0 is required in
+	     order not to start garbage collection within an already running
+	     garbage collection. However, there should be a better name for
+	     this variable, like for example scm_gc_running_p.
+	  */
+	  if (debug_cells_gc_counter_init)
+	    {
+	      if (--debug_cells_gc_counter == 0)
+		{
+		  debug_cells_gc_counter = debug_cells_gc_counter_init;
+		  scm_gc ();
+		}
+	    }
+	}
+      debug_cells_p = 1;  /* re-enable */
+    }
+}
+
+
+SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
+            (SCM flag),
+            "If FLAG is #f, cell access checking is disabled.\n"
+            "If FLAG is #t, cell access checking is enabled, but no\n"
+	    "additional calls to garbage collection are issued.\n"
+	    "If FLAG is a number, cell access checking is enabled,\n"
+	    "with an additional garbage collection after the given\n"
+	    "number of cell accesses.\n"
+            "This procedure only exists because the compile-time flag\n"
+	    "SCM_DEBUG_CELL_ACCESSES was set to 1.\n")
+#define FUNC_NAME s_scm_set_debug_cell_accesses_x
+{
+  if (SCM_FALSEP (flag)) {
+    debug_cells_p = 0;
+  } else if (SCM_EQ_P (flag, SCM_BOOL_T)) {
+    debug_cells_gc_counter_init = 0;
+    debug_cells_p = 1;
+  } else if (SCM_INUMP (flag)) {
+    long int f = SCM_INUM (flag);
+    if (f <= 0) SCM_OUT_OF_RANGE(1, flag);
+    debug_cells_gc_counter_init = f;
+    debug_cells_gc_counter = f;
+    debug_cells_p = 1;
+  } else {
+    SCM_WRONG_TYPE_ARG (1, flag);
+  }
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
+
+
+
 /* {heap tuning parameters}
  *
  * These are parameters for controlling memory allocation.  The heap
@@ -317,7 +397,7 @@
   int last_seg = -1, count = 0;
   SCM f;
 
-  for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f))
+  for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f))
     {
       int this_seg = which_seg (f);
 
@@ -368,8 +448,8 @@
 {
   SCM ls;
   int n = 0;
-  for (ls = freelist; SCM_NNULLP (ls); ls = SCM_CDR (ls))
-    if (SCM_CELL_TYPE (ls) == scm_tc_free_cell)
+  for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls))
+    if (SCM_FREE_CELL_P (ls))
       ++n;
     else
       {
@@ -444,8 +524,8 @@
   SCM f;
   int i = 0;
 
-  for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
-    if (SCM_CAR (f) != (SCM) scm_tc_free_cell)
+  for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++)
+    if (!SCM_FREE_CELL_P (f))
       {
 	fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
 		 scm_newcell_count, i);
@@ -483,13 +563,13 @@
 
   /* The rest of this is supposed to be identical to the SCM_NEWCELL
      macro.  */
-  if (SCM_IMP (scm_freelist))
+  if (SCM_NULLP (scm_freelist))
     new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist);
   else
     {
       new = scm_freelist;
-      scm_freelist = SCM_CDR (scm_freelist);
-      SCM_SETCAR (new, scm_tc16_allocated);
+      scm_freelist = SCM_FREE_CELL_CDR (scm_freelist);
+      SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated);
     }
 
   return new;
@@ -509,13 +589,13 @@
 
   /* The rest of this is supposed to be identical to the SCM_NEWCELL
      macro.  */
-  if (SCM_IMP (scm_freelist2))
+  if (SCM_NULLP (scm_freelist2))
     new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
   else
     {
       new = scm_freelist2;
-      scm_freelist2 = SCM_CDR (scm_freelist2);
-      SCM_SETCAR (new, scm_tc16_allocated);
+      scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2);
+      SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated);
     }
 
   return new;
@@ -538,7 +618,7 @@
 freelist_length (SCM freelist)
 {
   int n;
-  for (n = 0; SCM_NNULLP (freelist); freelist = SCM_CDR (freelist))
+  for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist))
     ++n;
   return n;
 }
@@ -725,8 +805,8 @@
     }
   while (SCM_NULLP (cell));
   --scm_ints_disabled;
-  *freelist = SCM_CDR (cell);
-  SCM_SET_CELL_TYPE (cell, scm_tc16_allocated);
+  *freelist = SCM_FREE_CELL_CDR (cell);
+  SCM_SET_FREE_CELL_TYPE (cell, scm_tc16_allocated);
   return cell;
 }
 
@@ -922,7 +1002,7 @@
     return;
 
 gc_mark_nimp:
-  if (SCM_NCELLP (ptr))
+  if (!SCM_CELLP (ptr))
     scm_wta (ptr, "rogue pointer in heap", NULL);
 
   switch (SCM_TYP7 (ptr))
@@ -1262,7 +1342,17 @@
 		  }
 		if (scm_heap_table[seg_id].span == 1
 		    || SCM_DOUBLE_CELLP (* (SCM *) &x[m]))
-		  scm_gc_mark (* (SCM *) &x[m]);
+		  {
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+		    /* We might stumble over pointers to free cells.  We don't
+		       want to access these if cell access debugging is
+		       enabled.
+		    */
+		    if (SCM_FREE_CELL_P (* (SCM *) &x[m]))
+		      break;
+#endif
+		    scm_gc_mark (* (SCM *) &x[m]);
+		  }
 		break;
 	      }
 
@@ -1322,7 +1412,7 @@
 {
   int collected;
   *freelist->clustertail = freelist->cells;
-  if (SCM_NNULLP (freelist->cells))
+  if (!SCM_NULLP (freelist->cells))
     {
       SCM c = freelist->cells;
       SCM_SETCAR (c, SCM_CDR (c));
@@ -1573,7 +1663,7 @@
 	    sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep");
 	    }
 #if 0
-	  if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
+	  if (SCM_FREE_CELL_P (scmptr))
 	    exit (2);
 #endif
 	  if (!--left_to_collect)
@@ -1593,7 +1683,7 @@
 		 conservative collector might trace it as some other type
 		 of object.  */
 	      SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
-	      SCM_SETCDR (scmptr, nfreelist);
+	      SCM_SET_FREE_CELL_CDR (scmptr, nfreelist);
 	      nfreelist = scmptr;
 	    }
 
@@ -1925,11 +2015,11 @@
 	    SCM scmptr = PTR2SCM (ptr);
 
 	    SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
-	    SCM_SETCDR (scmptr, PTR2SCM (ptr + span));
+	    SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (ptr + span));
 	    ptr += span;
 	  }
 
-	SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL);
+	SCM_SET_FREE_CELL_CDR (PTR2SCM (ptr - span), SCM_EOL);
       }
 
     /* Patch up the last cluster pointer in the segment
Index: libguile/gc.h
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/gc.h,v
retrieving revision 1.53
diff -u -r1.53 gc.h
--- gc.h	2000/06/20 14:57:35	1.53
+++ gc.h	2000/06/23 10:34:00
@@ -85,40 +85,45 @@
 /* Low level cell data accessing macros:
  */
 
-#if SCM_DEBUG_CELL_ACCESSES == 1
-#define SCM_VALIDATE_CELL(cell, expr) \
-  (!scm_cellp (cell) ? abort (), 0 : (expr))
+#define SCM_FREE_CELL_P(x) \
+  (!SCM_IMP (x) && (* (const scm_bits_t *) SCM2PTR (x) == scm_tc_free_cell))
+#define SCM_FREE_CELL_CDR(x) \
+  (((const scm_bits_t *) SCM2PTR (x)) [1])
+#define SCM_SET_FREE_CELL_TYPE(x, v) \
+  (((scm_bits_t *) SCM2PTR (x)) [0] = (v))
+#define SCM_SET_FREE_CELL_CDR(x, v) \
+  (((scm_bits_t *) SCM2PTR (x)) [1] = (v))
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+   extern void scm_check_cell (SCM);
+#  define SCM_VALIDATE_CELL(cell, expr) (scm_check_cell (cell), (expr))
 #else
-#define SCM_VALIDATE_CELL(cell, expr) expr
+#  define SCM_VALIDATE_CELL(cell, expr) expr
 #endif
 
-#define SCM_CELL_WORD(x, n)					\
-    SCM_VALIDATE_CELL ((x),					\
-		       ((scm_bits_t *) SCM2PTR (x)) [n])
+#define SCM_CELL_WORD(x, n) \
+  SCM_VALIDATE_CELL ((x), ((const scm_bits_t *) SCM2PTR (x)) [n])
 #define SCM_CELL_WORD_0(x) SCM_CELL_WORD (x, 0)
 #define SCM_CELL_WORD_1(x) SCM_CELL_WORD (x, 1)
 #define SCM_CELL_WORD_2(x) SCM_CELL_WORD (x, 2)
 #define SCM_CELL_WORD_3(x) SCM_CELL_WORD (x, 3)
 
-#define SCM_CELL_OBJECT(x, n)						\
-    SCM_VALIDATE_CELL ((x),						\
-		       SCM_PACK (((scm_bits_t *) SCM2PTR (x)) [n]))
+#define SCM_CELL_OBJECT(x, n) \
+  SCM_VALIDATE_CELL ((x), SCM_PACK (((const scm_bits_t *) SCM2PTR (x)) [n]))
 #define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT (x, 0)
 #define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT (x, 1)
 #define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT (x, 2)
 #define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT (x, 3)
 
-#define SCM_SET_CELL_WORD(x, n, v)					    \
-    SCM_VALIDATE_CELL ((x),						    \
-		       ((scm_bits_t *) SCM2PTR (x)) [n] = (scm_bits_t) (v))
+#define SCM_SET_CELL_WORD(x, n, v) \
+  SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = (scm_bits_t) (v))
 #define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD (x, 0, v)
 #define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD (x, 1, v)
 #define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD (x, 2, v)
 #define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD (x, 3, v)
 
-#define SCM_SET_CELL_OBJECT(x, n, v)					  \
-    SCM_VALIDATE_CELL ((x),						  \
-		       ((scm_bits_t *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
+#define SCM_SET_CELL_OBJECT(x, n, v) \
+  SCM_VALIDATE_CELL ((x), ((scm_bits_t *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
 #define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT (x, 0, v)
 #define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT (x, 1, v)
 #define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT (x, 2, v)
@@ -136,9 +141,9 @@
 #define SCM_SETOR_CDR(x, y)\
   (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
 
-#define SCM_CELL_WORD_LOC(x, n) (&SCM_CELL_WORD (x, n))
-#define SCM_CARLOC(x) ((SCM *) (&(((scm_bits_t *) SCM2PTR (x)) [0])))
-#define SCM_CDRLOC(x) ((SCM *) (&(((scm_bits_t *) SCM2PTR (x)) [1])))
+#define SCM_CELL_WORD_LOC(x, n) ((scm_bits_t *) & SCM_CELL_WORD (x, n))
+#define SCM_CARLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 0))
+#define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1))
 
 
 /* SCM_PTR_LT and friends define how to compare two SCM_CELLPTRs (which may
@@ -150,7 +155,6 @@
 #define SCM_PTR_GE(x, y) (!SCM_PTR_LT (x, y))
 
 
-/* Dirk:FIXME:: */
 /* Freelists consist of linked cells where the type entry holds the value
  * scm_tc_free_cell and the second entry holds a pointer to the next cell of
  * the freelist.  Due to this structure, freelist cells are not cons cells
@@ -178,8 +182,8 @@
           else \
             { \
                _into = scm_freelist; \
-               scm_freelist = SCM_CDR (scm_freelist); \
-               SCM_SET_CELL_TYPE (_into, scm_tc16_allocated); \
+               scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); \
+               SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \
             } \
         } while(0)
 #define SCM_NEWCELL2(_into) \
@@ -190,16 +194,13 @@
           else \
             { \
                _into = scm_freelist2; \
-               scm_freelist2 = SCM_CDR (scm_freelist2); \
-               SCM_SET_CELL_TYPE (_into, scm_tc16_allocated); \
+               scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); \
+               SCM_SET_FREE_CELL_TYPE (_into, scm_tc16_allocated); \
             } \
         } while(0)
 #endif
 
 
-#define SCM_FREEP(x) (SCM_NIMP (x) && (SCM_CELL_TYPE (x) == scm_tc_free_cell))
-#define SCM_NFREEP(x) (!SCM_FREEP (x))
-
 /* 1. This shouldn't be used on immediates.
    2. It thinks that subrs are always unmarked (harmless). */
 #define SCM_MARKEDP(x) ((SCM_CELL_TYPE (x) & 5) == 5 \
@@ -286,6 +287,16 @@
                              scm_sizet init_heap2_size, int trig2,
 			     scm_sizet max_segment_size);
 extern void scm_init_gc (void);
+
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+#define SCM_FREEP(x) (SCM_FREE_CELL_P (x))
+#define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x))
+
+#endif  /* SCM_DEBUG_DEPRECATED == 0 */
+
 #endif  /* GCH */
 
 /*
Index: libguile/weaks.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/weaks.c,v
retrieving revision 1.26
diff -u -r1.26 weaks.c
--- weaks.c	2000/05/05 11:10:57	1.26
+++ weaks.c	2000/06/23 10:34:00
@@ -264,7 +264,7 @@
 	  ptr = SCM_VELTS (w);
 	  n = SCM_LENGTH (w);
 	  for (j = 0; j < n; ++j)
-	    if (SCM_FREEP (ptr[j]))
+	    if (SCM_FREE_CELL_P (ptr[j]))
 	      ptr[j] = SCM_BOOL_F;
 	}
       else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
@@ -296,8 +296,8 @@
 
 		  key = SCM_CAAR (alist);
 		  value = SCM_CDAR (alist);
-		  if (   (weak_keys && SCM_FREEP (key))
-			 || (weak_values && SCM_FREEP (value)))
+		  if (   (weak_keys && SCM_FREE_CELL_P (key))
+			 || (weak_values && SCM_FREE_CELL_P (value)))
 		    {
 		      *fixup = SCM_CDR (alist);
 		    }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]