* gc.h: add scm_debug_cells_gc_interval to public interface

* gc-card.c ("sweep_card"): set scm_gc_running while sweeping.

* gc.c (scm_i_expensive_validation_check): separate expensive
validation checks from cheap ones.

NEWS

@@ -142,9 +142,9 @@ cause aborts in long running programs.
 The new functions are more symmetrical and do not need cooperation
 from smob free routines, among other improvements.
 
-The new functions are scm_malloc, scm_realloc, scm_strdup,
+The new functions are scm_malloc, scm_realloc, scm_calloc, scm_strdup,
-scm_strndup, scm_gc_malloc, scm_gc_calloc, scm_gc_realloc, scm_gc_free,
+scm_strndup, scm_gc_malloc, scm_gc_calloc, scm_gc_realloc,
-scm_gc_register_collectable_memory, and
+scm_gc_free, scm_gc_register_collectable_memory, and
 scm_gc_unregister_collectable_memory.  Refer to the manual for more
 details and for upgrading instructions.
 

doc/ref/scheme-memory.texi

@@ -76,6 +76,7 @@ For really specialized needs, take at look at
 @code{scm_gc_unregister_collectable_memory}.
 
 @deftypefn {C Function} void *scm_malloc (size_t @var{size})
+@deftypefnx {C Function} void *scm_calloc (size_t @var{size})
 Allocate @var{size} bytes of memory and return a pointer to it.  When
 @var{size} is 0, return @code{NULL}.  When not enough memory is
 available, signal an error.  This function runs the GC to free up some
@@ -85,6 +86,9 @@ The memory is allocated by the libc @code{malloc} function and can be
 freed with @code{free}.  There is no @code{scm_free} function to go
 with @code{scm_malloc} to make it easier to pass memory back and forth
 between different modules.
+
+The function @code{scm_calloc} is similar to @code{scm_malloc}, but
+initializes the block of memory to zero as well.
 @end deftypefn
 
 @deftypefn {C Function} void *scm_realloc (void *@var{mem}, size_t @var{new_size})
@@ -98,6 +102,9 @@ When not enough memory is available, signal an error.  This function
 runs the GC to free up some memory when it deems it appropriate.
 @end deftypefn
 
+
+
+
 @deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what})
 Informs the GC that the memory at @var{mem} of size @var{size} can
 potentially be freed during a GC.  That is, announce that @var{mem} is
@@ -127,12 +134,14 @@ much less efficiently than it could.
 
 @deftypefn {C Function} void *scm_gc_malloc (size_t @var{size}, const char *@var{what})
 @deftypefnx {C Function} void *scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
-Like @code{scm_malloc} or @code{scm_realloc}, but also call
+@deftypefnx {C Function} void *scm_gc_calloc (size_t @var{size}, const char *@var{what})
-@code{scm_gc_register_collectable_memory}.  Note that you need to pass
+Like @code{scm_malloc}, @code{scm_realloc} or @code{scm_calloc}, but
-the old size of a reallocated memory block as well.  See below for a
+also call @code{scm_gc_register_collectable_memory}.  Note that you
-motivation.
+need to pass the old size of a reallocated memory block as well.  See
+below for a motivation.
 @end deftypefn
 
+
 @deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
 Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.
 

libguile/ChangeLog

@@ -1,3 +1,12 @@
+2002-08-08  Han-Wen Nienhuys  <hanwen@cs.uu.nl>
+
+	* gc.h: add scm_debug_cells_gc_interval to public interface
+
+	* gc-card.c ("sweep_card"): set scm_gc_running while sweeping.
+
+	* gc.c (scm_i_expensive_validation_check): separate expensive
+	validation checks from cheap ones.
+
 2002-08-06  Han-Wen Nienhuys  <hanwen@cs.uu.nl>
 
 	* read.c (scm_input_error): new function: give meaningful error

libguile/gc-card.c

@@ -86,12 +86,13 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, int span)
   int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
   int free_count  = 0;
 
+  ++ scm_gc_running_p;
+
   /*
     I tried something fancy with shifting by one bit every word from
     the bitvec in turn, but it wasn't any faster, but quite bit
     hairier.
    */
-
   for (p += offset; p < end; p += span, offset += span)
     {
       SCM scmptr = PTR2SCM(p);
@@ -273,6 +274,8 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, int span)
       *free_list = PTR2SCM (p);
       free_count ++;
     }
+
+  --scm_gc_running_p;
   return free_count;
 }
 #undef FUNC_NAME
@@ -301,6 +304,7 @@ scm_init_card_freelist (scm_t_cell *  card, SCM *free_list, int span)
 }
 
 
+
 #if 0
 /*
   These functions are meant to be called from GDB as a debug aid.
@@ -318,6 +322,16 @@ typedef struct scm_t_list_cell_struct {
   struct scm_t_list_cell_struct * cdr;
 } scm_t_list_cell;
 
+
+typedef struct scm_t_double_cell
+{
+  scm_t_bits word_0;
+  scm_t_bits word_1;
+  scm_t_bits word_2;
+  scm_t_bits word_3;
+} scm_t_double_cell;
+
+
 int
 scm_gc_marked_p (SCM obj)
 {

libguile/gc-mark.c

@@ -83,9 +83,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 #include <unistd.h>
 #endif
 
-
-
-
 #ifdef __ia64__
 # define SCM_MARK_BACKING_STORE() do {                                \
     ucontext_t ctx;                                                   \
@@ -101,6 +98,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 # define SCM_MARK_BACKING_STORE()
 #endif
 
+
 /*
   Entry point for this file.
  */
@@ -108,10 +106,10 @@ void
 scm_mark_all (void)
 {
   long j;
-
+  
   
   scm_i_clear_mark_space ();
-
+  
 #ifndef USE_THREADS
 
   /* Mark objects on the C stack. */
@@ -157,12 +155,14 @@ scm_mark_all (void)
 	  }
       }
   }
+  
 
   /* FIXME: we should have a means to register C functions to be run
    * in different phases of GC
    */
   scm_mark_subr_table ();
 
+
 #ifndef USE_THREADS
   scm_gc_mark (scm_root->handle);
 #endif
@@ -171,7 +171,6 @@ scm_mark_all (void)
 /* {Mark/Sweep}
  */
 
-
 /*
   Mark an object precisely, then recurse.
  */
@@ -182,7 +181,9 @@ scm_gc_mark (SCM ptr)
     return ;
   
   if (SCM_GC_MARK_P (ptr))
-    return;
+    {
+      return;
+    }
 
   SCM_SET_GC_MARK (ptr);
   scm_gc_mark_dependencies (ptr);
@@ -475,9 +476,12 @@ gc_mark_loop:
   }
   
  if (SCM_GC_MARK_P (ptr))
+  {
     return;
-
+  }
+  
   SCM_SET_GC_MARK (ptr);
+
   goto   scm_mark_dependencies_again;
   
 }
@@ -485,6 +489,7 @@ gc_mark_loop:
 
 
 
+
 /* Mark a region conservatively */
 void
 scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
@@ -570,4 +575,3 @@ scm_gc_init_mark(void)
 #endif
 }
 
-

libguile/gc-segment.c

@@ -546,6 +546,7 @@ scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_erro
 }
 
 
+
 void
 scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist)
 {
@@ -568,4 +569,3 @@ scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *f
     freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
 			    / 100);
 }
-

libguile/gc.c

@@ -90,53 +90,87 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 
 unsigned int scm_gc_running_p = 0;
 
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
-
 /* Set this to != 0 if every cell that is accessed shall be checked:
  */
-unsigned int scm_debug_cell_accesses_p = 1;
+int scm_debug_cell_accesses_p = 0;
+int scm_expensive_debug_cell_accesses_p = 0;
 
 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
  * the number of cell accesses after which a gc shall be called.
  */
-static unsigned int debug_cells_gc_interval = 0;
+int scm_debug_cells_gc_interval = 0;
 
-
+/*
-/* Assert that the given object is a valid reference to a valid cell.  This
+  Global variable, so you can switch it off at runtime by setting
- * test involves to determine whether the object is a cell pointer, whether
+  scm_i_cell_validation_already_running.
- * this pointer actually points into a heap segment and whether the cell
- * pointed to is not a free cell.  Further, additional garbage collections may
- * get executed after a user defined number of cell accesses.  This helps to
- * find places in the C code where references are dropped for extremely short
- * periods.
  */
+int scm_i_cell_validation_already_running ;
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+
+
+/*
+  
+  Assert that the given object is a valid reference to a valid cell.  This
+  test involves to determine whether the object is a cell pointer, whether
+  this pointer actually points into a heap segment and whether the cell
+  pointed to is not a free cell.  Further, additional garbage collections may
+  get executed after a user defined number of cell accesses.  This helps to
+  find places in the C code where references are dropped for extremely short
+  periods.
+
+*/
+
+
+void
+scm_i_expensive_validation_check (SCM cell)
+{
+  if (!scm_in_heap_p (cell))
+    {
+      fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
+	       (unsigned long) SCM_UNPACK (cell));
+      abort ();
+    }
+
+  /* If desired, perform additional garbage collections after a user
+   * defined number of cell accesses.
+   */
+  if (scm_debug_cells_gc_interval)
+    {
+      static unsigned int counter = 0;
+
+      if (counter != 0)
+	{
+	  --counter;
+	}
+      else
+	{
+	  counter = scm_debug_cells_gc_interval;
+	  scm_igc ("scm_assert_cell_valid");
+	}
+    }
+}
 
 void
 scm_assert_cell_valid (SCM cell)
 {
-  static unsigned int already_running = 0;
+  if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
-
-  if (!already_running)
     {
-      already_running = 1;  /* set to avoid recursion */
+      scm_i_cell_validation_already_running = 1;  /* set to avoid recursion */
 
       /*
-	During GC, no user-code should be run, and the guile core should
+	During GC, no user-code should be run, and the guile core
-	use non-protected accessors.
+	should use non-protected accessors.
-       */
+      */
       if (scm_gc_running_p)
-	abort();
+	return;
 
       /*
-	Only scm_in_heap_p is wildly expensive. 
+	Only scm_in_heap_p and rescanning the heap is wildly
-       */
+	expensive.
-      if (scm_debug_cell_accesses_p)
+      */
-	if (!scm_in_heap_p (cell))
+      if (scm_expensive_debug_cell_accesses_p)
-	  {
+	scm_i_expensive_validation_check (cell);
-	    fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
-		     (unsigned long) SCM_UNPACK (cell));
-	    abort ();
-	  }
       
       if (!SCM_GC_MARK_P (cell))
 	{
@@ -148,54 +182,47 @@ scm_assert_cell_valid (SCM cell)
 	  abort ();
 	}
 
-
+      scm_i_cell_validation_already_running = 0;  /* re-enable */
-      /* If desired, perform additional garbage collections after a user
-       * defined number of cell accesses.
-       */
-      if (scm_debug_cell_accesses_p && debug_cells_gc_interval)
-	{
-	  static unsigned int counter = 0;
-
-	  if (counter != 0)
-	    {
-	      --counter;
-	    }
-	  else
-	    {
-	      counter = debug_cells_gc_interval;
-	      scm_igc ("scm_assert_cell_valid");
-	    }
-	}
-      already_running = 0;  /* re-enable */
     }
 }
 
 
+
 SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
 	    (SCM flag),
 	    "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
-	    "If @var{flag} is @code{#t}, cell access checking is enabled,\n"
+	    "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
 	    "but no additional calls to garbage collection are issued.\n"
-	    "If @var{flag} is a number, cell access checking is enabled,\n"
+	    "If @var{flag} is a number, strict cell access checking is enabled,\n"
 	    "with an additional garbage collection after the given\n"
 	    "number of cell accesses.\n"
 	    "This procedure only exists when the compile-time flag\n"
 	    "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
 {
-  if (SCM_FALSEP (flag)) {
+  if (SCM_FALSEP (flag))
-    scm_debug_cell_accesses_p = 0;
+    {
-  } else if (SCM_EQ_P (flag, SCM_BOOL_T)) {
+      scm_debug_cell_accesses_p = 0;
-    debug_cells_gc_interval = 0;
+    }
-    scm_debug_cell_accesses_p = 1;
+  else if (SCM_EQ_P (flag, SCM_BOOL_T))
-  } else if (SCM_INUMP (flag)) {
+    {
-    long int f = SCM_INUM (flag);
+      scm_debug_cells_gc_interval = 0;
-    if (f <= 0) SCM_OUT_OF_RANGE (1, flag);
+      scm_debug_cell_accesses_p = 1;
-    debug_cells_gc_interval = f;
+      scm_expensive_debug_cell_accesses_p = 0;
-    scm_debug_cell_accesses_p = 1;
+    }
-  } else {
+  else if (SCM_INUMP (flag))
-    SCM_WRONG_TYPE_ARG (1, flag);
+    {
-  }
+      long int f = SCM_INUM (flag);
+      if (f <= 0)
+	SCM_OUT_OF_RANGE (1, flag);
+      scm_debug_cells_gc_interval = f;
+      scm_debug_cell_accesses_p = 1;
+      scm_expensive_debug_cell_accesses_p = 1;
+    }
+  else
+    {
+      SCM_WRONG_TYPE_ARG (1, flag);
+    }
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -497,6 +524,8 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
   --scm_ints_disabled;
 
   *free_cells = SCM_FREE_CELL_CDR (cell);
+
+
   return cell;
 }
 
@@ -525,7 +554,7 @@ scm_igc (const char *what)
   /* During the critical section, only the current thread may run. */
   SCM_CRITICAL_SECTION_START;
 
-  if (!scm_stack_base || scm_block_gc)
+  if (!scm_root || !scm_stack_base || scm_block_gc)
     {
       --scm_gc_running_p;
       return;
@@ -585,17 +614,15 @@ scm_igc (const char *what)
   SCM_CRITICAL_SECTION_END;
   scm_c_hook_run (&scm_after_gc_c_hook, 0);
   --scm_gc_running_p;
+
+  /*
+    For debugging purposes, you could do
+    scm_i_sweep_all_segments("debug"), but then the remains of the
+    cell aren't left to analyse.
+   */
 }
 
 
-
-
-
-
-
-
-
-
 /* {GC Protection Helper Functions}
  */
 
@@ -939,7 +966,7 @@ mark_gc_async (void * hook_data SCM_UNUSED,
    * after-gc-hook.
    */
 #if (SCM_DEBUG_CELL_ACCESSES == 1)
-  if (debug_cells_gc_interval == 0)
+  if (scm_debug_cells_gc_interval == 0)
     scm_system_async_mark (gc_async);
 #else
   scm_system_async_mark (gc_async);

libguile/gc.h

@@ -218,6 +218,7 @@ typedef unsigned long scm_t_c_bvec_long;
 #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 (x, t)
 
 
+
 /* 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
@@ -245,7 +246,11 @@ typedef unsigned long scm_t_c_bvec_long;
 
 
 #if (SCM_DEBUG_CELL_ACCESSES == 1)
-SCM_API unsigned int scm_debug_cell_accesses_p;
+/* Set this to != 0 if every cell that is accessed shall be checked:
+ */
+SCM_API int scm_debug_cell_accesses_p;
+SCM_API int scm_expensive_debug_cell_accesses_p;
+SCM_API int scm_debug_cells_gc_interval ;
 #endif
 
 SCM_API int scm_block_gc;
@@ -274,10 +279,11 @@ SCM_API size_t scm_max_segment_size;
   Deprecated scm_freelist, scm_master_freelist.
   No warning; this is not a user serviceable part.
  */
-SCM_API SCM scm_i_freelist;
+extern SCM scm_i_freelist;
-SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
+extern struct scm_t_cell_type_statistics scm_i_master_freelist;
-SCM_API SCM scm_i_freelist2;
+extern SCM scm_i_freelist2;
-SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
+extern struct scm_t_cell_type_statistics scm_i_master_freelist2;
+
 
 SCM_API unsigned long scm_gc_cells_swept;
 SCM_API unsigned long scm_gc_cells_collected;

libguile/inline.c

@@ -39,10 +39,13 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
+#include <stdio.h> 
 #include "libguile/scmconfig.h"
 
-
+#ifndef HAVE_INLINE
 #define HAVE_INLINE
+#endif
+
 #define EXTERN_INLINE
 #undef SCM_INLINE_H
 

libguile/inline.h

@@ -50,10 +50,6 @@
 */
 
 
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
-#include <stdio.h>
-#endif
-
 #include "libguile/pairs.h"
 #include "libguile/gc.h"
 
@@ -64,8 +60,6 @@ SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
 
 #ifdef HAVE_INLINE
 
-
-
 #ifndef EXTERN_INLINE
 #define EXTERN_INLINE extern inline
 #endif
@@ -74,6 +68,7 @@ extern unsigned scm_newcell2_count;
 extern unsigned scm_newcell_count;
 
 
+
 EXTERN_INLINE
 SCM
 scm_cell (scm_t_bits car, scm_t_bits cdr)
@@ -137,6 +132,10 @@ scm_cell (scm_t_bits car, scm_t_bits cdr)
 #endif
 
 
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+  if (scm_expensive_debug_cell_accesses_p )
+    scm_i_expensive_validation_check (z);
+#endif
   
   return z;
 }
@@ -201,5 +200,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
   return z;
 }
 
+
+
 #endif
 #endif

libguile/private-gc.h

@@ -236,5 +236,6 @@ void scm_gc_init_malloc (void);
 void scm_gc_init_freelist (void);
 void scm_gc_init_segments (void);
 void scm_gc_init_mark (void);
-     
+
+
 #endif

libguile/procs.c

@@ -139,7 +139,7 @@ scm_mark_subr_table ()
   long i;
   for (i = 0; i < scm_subr_table_size; ++i)
     {
-      SCM_SET_GC_MARK (scm_subr_table[i].name);
+      scm_gc_mark (scm_subr_table[i].name);
       if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
 	scm_gc_mark (*scm_subr_table[i].generic);
       if (SCM_NIMP (scm_subr_table[i].properties))