more code

libguile/gc-freelist.c

@@ -0,0 +1,210 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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.  */
+
+#include <assert.h>
+
+#include "libguile/private-gc.h"
+#include "libguile/gc.h"
+#include "libguile/deprecation.h"
+#include "libguile/private-gc.h"
+
+scm_t_cell_type_statistics scm_i_master_freelist;
+scm_t_cell_type_statistics scm_i_master_freelist2;
+
+
+
+
+/*
+
+In older versions of GUILE GC there was extensive support for
+debugging freelists. This was useful, since the freelist was kept
+inside the heap, and writing to an object that was GC'd would mangle
+the list. Mark bits are now separate, and checking for sane cell
+access can be done much more easily by simply checking if the mark bit
+is unset before allocation.  --hwn
+
+
+
+*/
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+#if defined(GUILE_DEBUG_FREELIST)
+
+SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
+            (),
+	    "DEPRECATED\n")
+#define FUNC_NAME s_scm_map_free_list
+{
+  scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n");
+  return SCM_UNSPECIFIED;
+}  
+
+SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
+            (SCM flag),
+	    "DEPRECATED.\n")
+#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
+{
+  scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n");
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+#endif /* defined (GUILE_DEBUG) */
+#endif /* deprecated */
+
+
+
+
+/*
+  This adjust FREELIST variables to decide wether or not to allocate
+  more heap in the next GC run. It uses scm_gc_cells_collected and scm_gc_cells_collected1
+ */
+
+void
+scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist)
+{
+  /* min yield is adjusted upwards so that next predicted total yield
+   * (allocated cells actually freed by GC) becomes
+   * `min_yield_fraction' of total heap size.  Note, however, that
+   * the absolute value of min_yield will correspond to `collected'
+   * on one master (the one which currently is triggering GC).
+   *
+   * The reason why we look at total yield instead of cells collected
+   * on one list is that we want to take other freelists into account.
+   * On this freelist, we know that (local) yield = collected cells,
+   * but that's probably not the case on the other lists.
+   *
+   * (We might consider computing a better prediction, for example
+   *  by computing an average over multiple GC:s.)
+   */
+  if (freelist->min_yield_fraction)
+    {
+      /* Pick largest of last two yields. */
+      long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100)
+		   - (long) SCM_MAX (scm_gc_cells_collected_1, scm_gc_cells_collected));
+#ifdef DEBUGINFO
+      fprintf (stderr, " after GC = %lu, delta = %ld\n",
+	       (long) scm_cells_allocated,
+	       (long) delta);
+#endif
+      if (delta > 0)
+	freelist->min_yield += delta;
+    }
+}
+
+
+static void
+scm_init_freelist (scm_t_cell_type_statistics *freelist,
+	       int span,
+	       int min_yield)
+{
+  freelist->heap_segment_idx = -1;
+  freelist->min_yield = 0;
+  freelist->min_yield_fraction = min_yield;
+  freelist->span = span;
+  freelist->collected = 0;
+  freelist->collected_1 = 0;
+  freelist->heap_size = 0;
+}
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+ size_t scm_default_init_heap_size_1;
+ int scm_default_min_yield_1;
+ size_t scm_default_init_heap_size_2;
+ int scm_default_min_yield_2;
+ size_t scm_default_max_segment_size;
+#endif
+
+void
+scm_gc_init_freelist (void)
+{
+  size_t init_heap_size_1
+    = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1);
+
+  size_t init_heap_size_2
+    = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);
+
+  scm_i_freelist = SCM_EOL;
+  scm_i_freelist2 = SCM_EOL;
+  
+  scm_init_freelist (&scm_i_master_freelist2, 2, 
+		     scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2));
+  scm_init_freelist (&scm_i_master_freelist, 1,
+		     scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1));
+
+
+  scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE);
+  
+  scm_i_make_initial_segment (init_heap_size_1, &scm_i_master_freelist);
+  scm_i_make_initial_segment (init_heap_size_2, &scm_i_master_freelist2);
+
+  
+#if (SCM_ENABLE_DEPRECATED == 1)
+  if ( scm_default_init_heap_size_1 ||
+       scm_default_min_yield_1||
+       scm_default_init_heap_size_2||
+       scm_default_min_yield_2||
+       scm_default_max_segment_size)
+    {
+      scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead.");
+    }
+#endif
+}
+
+
+void
+scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist)
+{
+  freelist->collected_1 = freelist->collected;
+  freelist->collected = 0;
+  
+  /*
+    at the end we simply start with the lowest segment again.
+   */
+  freelist->heap_segment_idx = -1;
+}
+
+int
+scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist)
+{
+  return SCM_MAX (freelist->collected,freelist->collected_1)  < freelist->min_yield;
+}

libguile/gc-malloc.c

@@ -0,0 +1,407 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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.  */
+
+
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+
+#include "libguile/private-gc.h"
+
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/*
+  INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
+  trigger a GC.
+  
+  After startup (at the guile> prompt), we have approximately 100k of
+  alloced memory, which won't go away on GC. Let's set the init such
+  that we get a nice yield on the next allocation:
+*/
+#define SCM_DEFAULT_INIT_MALLOC_LIMIT 200000
+#define SCM_DEFAULT_MALLOC_MINYIELD 40
+
+
+static int scm_i_minyield_malloc;
+
+void
+scm_gc_init_malloc (void)
+{
+  scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
+				 SCM_DEFAULT_INIT_MALLOC_LIMIT);
+  scm_i_minyield_malloc =  scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
+					   SCM_DEFAULT_MALLOC_MINYIELD);
+}
+
+
+
+/* Function for non-cell memory management.
+ */
+
+void *
+scm_malloc (size_t size)
+{
+  void *ptr;
+
+  if (size == 0)
+    return NULL;
+
+  SCM_SYSCALL (ptr = malloc (size));
+  if (ptr)
+    return ptr;
+
+  scm_i_sweep_all_segments ("malloc");
+  SCM_SYSCALL (ptr = malloc (size));
+  if (ptr)
+    return ptr;
+
+  scm_igc ("malloc");
+  scm_i_sweep_all_segments ("malloc/gc");
+
+  SCM_SYSCALL (ptr = malloc (size));
+  if (ptr)
+    return ptr;
+
+  scm_memory_error ("malloc");
+}
+
+void *
+scm_realloc (void *mem, size_t size)
+{
+  void *ptr;
+
+  SCM_SYSCALL (ptr = realloc (mem, size));
+  if (ptr)
+    return ptr;
+
+  scm_i_sweep_all_segments ("realloc");
+  
+  SCM_SYSCALL (ptr = realloc (mem, size));
+  if (ptr)
+    return ptr;
+
+  scm_igc ("realloc");
+  scm_i_sweep_all_segments ("realloc");
+  
+  SCM_SYSCALL (ptr = realloc (mem, size));
+  if (ptr)
+    return ptr;
+
+  scm_memory_error ("realloc");
+}
+
+char *
+scm_strndup (const char *str, size_t n)
+{
+  char *dst = scm_malloc (n+1);
+  memcpy (dst, str, n);
+  dst[n] = 0;
+  return dst;
+}
+
+char *
+scm_strdup (const char *str)
+{
+  return scm_strndup (str, strlen (str));
+}
+
+void
+scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
+{
+  scm_mallocated += size;
+
+  /*
+    we could finish the full sweep (without mark) here, but in
+    practice this turns out to be ineffective.
+   */
+
+  /*
+    A program that uses a lot of malloced collectable memory (vectors,
+    strings), will use a lot of memory off the cell-heap; it needs to
+    do GC more often (before cells are exhausted), otherwise swapping
+    and malloc management will tie it down.
+   */
+  if (scm_mallocated > scm_mtrigger)
+    {
+      long prev_alloced  = scm_mallocated;
+      float yield;
+      
+      scm_igc (what);
+      scm_i_sweep_all_segments("mtrigger");
+
+      yield  = (prev_alloced - scm_mallocated) / (float) prev_alloced;
+
+      /*
+      fprintf (stderr,  "prev %lud , now %lud, yield %4.2lf, want %d",
+	       prev_alloced, scm_mallocated, 100.0*yield, scm_i_minyield_malloc);
+      */
+
+      if (yield < scm_i_minyield_malloc /  100.0)
+	{
+	  /*
+	    We make the trigger a little larger, even; If you have a
+	    program that builds up a lot of data in strings, then the
+	    desired yield will never be satisfied.
+
+	    Instead of getting bogged down, we let the mtrigger grow
+	    strongly with it.
+	   */
+	  scm_mtrigger = (scm_mallocated * 110) / (100 - scm_i_minyield_malloc);
+	  
+	  /*
+	  fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n", scm_mtrigger);
+	  */
+
+	  
+	}
+    }
+  
+#ifdef GUILE_DEBUG_MALLOC
+  if (mem)
+    scm_malloc_register (mem, what);
+#endif
+}
+
+void
+scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
+{
+  scm_mallocated -= size;
+  scm_gc_malloc_collected += size;
+  
+#ifdef GUILE_DEBUG_MALLOC
+  if (mem)
+    scm_malloc_unregister (mem);
+#endif
+}
+
+void *
+scm_gc_malloc (size_t size, const char *what)
+{
+  /*
+    The straightforward implementation below has the problem
+     that it might call the GC twice, once in scm_malloc and then
+     again in scm_gc_register_collectable_memory.  We don't really
+     want the second GC since it will not find new garbage.
+
+
+     Note: this is a theoretical peeve. In reality, malloc() never
+     returns NULL. Usually, memory is overcommitted, and when you try
+     to write it the program is killed with signal 11. --hwn
+  */
+
+  void *ptr = scm_malloc (size);
+  scm_gc_register_collectable_memory (ptr, size, what);
+  return ptr;
+}
+
+void *
+scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
+{
+  /* XXX - see scm_gc_malloc. */
+
+  void *ptr = scm_realloc (mem, new_size);
+  scm_gc_unregister_collectable_memory (mem, old_size, what);
+  scm_gc_register_collectable_memory (ptr, new_size, what);
+  return ptr;
+}
+
+void
+scm_gc_free (void *mem, size_t size, const char *what)
+{
+  scm_gc_unregister_collectable_memory (mem, size, what);
+  free (mem);
+}
+
+char *
+scm_gc_strndup (const char *str, size_t n, const char *what)
+{
+  char *dst = scm_gc_malloc (n+1, what);
+  memcpy (dst, str, n);
+  dst[n] = 0;
+  return dst;
+}
+
+char *
+scm_gc_strdup (const char *str, const char *what)
+{
+  return scm_gc_strndup (str, strlen (str), what);
+}
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* {Deprecated front end to malloc}
+ *
+ * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
+ * scm_done_free
+ *
+ * These functions provide services comparable to malloc, realloc, and
+ * free.  They should be used when allocating memory that will be under
+ * control of the garbage collector, i.e., if the memory may be freed
+ * during garbage collection.
+ *
+ * They are deprecated because they weren't really used the way
+ * outlined above, and making sure to return the right amount from
+ * smob free routines was sometimes difficult when dealing with nested
+ * data structures.  We basically want everybody to review their code
+ * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
+ * instead.  In some cases, where scm_must_malloc has been used
+ * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
+ */
+
+void *
+scm_must_malloc (size_t size, const char *what)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_must_malloc is deprecated.  "
+     "Use scm_gc_malloc and scm_gc_free instead.");
+
+  return scm_gc_malloc (size, what);
+}
+
+void *
+scm_must_realloc (void *where,
+		  size_t old_size,
+		  size_t size,
+		  const char *what)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_must_realloc is deprecated.  "
+     "Use scm_gc_realloc and scm_gc_free instead.");
+
+  return scm_gc_realloc (where, old_size, size, what);
+}
+
+char *
+scm_must_strndup (const char *str, size_t length)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_must_strndup is deprecated.  "
+     "Use scm_gc_strndup and scm_gc_free instead.");
+
+  return scm_gc_strndup (str, length, "string");
+}
+
+char *
+scm_must_strdup (const char *str)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_must_strdup is deprecated.  "
+     "Use scm_gc_strdup and scm_gc_free instead.");
+
+  return scm_gc_strdup (str, "string");
+}
+
+void
+scm_must_free (void *obj)
+#define FUNC_NAME "scm_must_free"
+{
+  scm_c_issue_deprecation_warning
+    ("scm_must_free is deprecated.  "
+     "Use scm_gc_malloc and scm_gc_free instead.");
+
+#ifdef GUILE_DEBUG_MALLOC
+  scm_malloc_unregister (obj);
+#endif
+  if (obj)
+    free (obj);
+  else
+    SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+void
+scm_done_malloc (long size)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_done_malloc is deprecated.  "
+     "Use scm_gc_register_collectable_memory instead.");
+
+  scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
+}
+
+void
+scm_done_free (long size)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_done_free is deprecated.  "
+     "Use scm_gc_unregister_collectable_memory instead.");
+
+  scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
+}
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */

libguile/gc-mark.c

@@ -0,0 +1,562 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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.  */
+
+
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+#include <assert.h>
+
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+#include "libguile/private-gc.h"
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+
+
+
+#ifdef __ia64__
+# define SCM_MARK_BACKING_STORE() do {                                \
+    ucontext_t ctx;                                                   \
+    SCM_STACKITEM * top, * bot;                                       \
+    getcontext (&ctx);                                                \
+    scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
+      ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
+       / sizeof (SCM_STACKITEM)));                                    \
+    bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base;  \
+    top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp;                \
+    scm_mark_locations (bot, top - bot); } while (0)
+#else
+# define SCM_MARK_BACKING_STORE()
+#endif
+
+/*
+  Entry point for this file.
+ */
+void
+scm_mark_all (void)
+{
+  long j;
+
+  
+  scm_i_clear_mark_space ();
+
+#ifndef USE_THREADS
+
+  /* Mark objects on the C stack. */
+  SCM_FLUSH_REGISTER_WINDOWS;
+  /* This assumes that all registers are saved into the jmp_buf */
+  setjmp (scm_save_regs_gc_mark);
+  scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+		      (   (size_t) (sizeof (SCM_STACKITEM) - 1 +
+				       sizeof scm_save_regs_gc_mark)
+			  / sizeof (SCM_STACKITEM)));
+
+  {
+    unsigned long stack_len = scm_stack_size (scm_stack_base);
+#ifdef SCM_STACK_GROWS_UP
+    scm_mark_locations (scm_stack_base, stack_len);
+#else
+    scm_mark_locations (scm_stack_base - stack_len, stack_len);
+#endif
+  }
+  SCM_MARK_BACKING_STORE();
+
+#else /* USE_THREADS */
+
+  /* Mark every thread's stack and registers */
+  scm_threads_mark_stacks ();
+
+#endif /* USE_THREADS */
+
+  j = SCM_NUM_PROTECTS;
+  while (j--)
+    scm_gc_mark (scm_sys_protects[j]);
+
+  /* mark the registered roots */
+  {
+    size_t i;
+    for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i)
+      {
+	SCM l = SCM_VELTS (scm_gc_registered_roots)[i];
+	for (; !SCM_NULLP (l); l = SCM_CDR (l))
+	  {
+	    SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
+	    scm_gc_mark (*p);
+	  }
+      }
+  }
+
+  /* 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
+}
+
+/* {Mark/Sweep}
+ */
+
+
+/*
+  Mark an object precisely, then recurse.
+ */
+void
+scm_gc_mark (SCM ptr)
+{
+  if (SCM_IMP (ptr))
+    return ;
+  
+  if (SCM_GC_MARK_P (ptr))
+    return;
+
+  SCM_SET_GC_MARK (ptr);
+  scm_gc_mark_dependencies (ptr);
+}
+
+/*
+
+Mark the dependencies of an object.
+
+TODO:
+
+Should prefetch objects before marking, i.e. if marking a cell, we
+should prefetch the car, and then mark the cdr. This will improve CPU
+cache misses, because the car is more likely to be in core when we
+finish the cdr.
+
+See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
+garbage collector cache misses.
+
+Prefetch is supported on GCC >= 3.1 
+
+ */
+void
+scm_gc_mark_dependencies (SCM p)
+#define FUNC_NAME "scm_gc_mark_dependencies"
+{
+  register long i;
+  register SCM ptr;
+  scm_t_bits cell_type;
+
+  ptr = p;
+ scm_mark_dependencies_again:
+  
+  cell_type = SCM_GC_CELL_TYPE (ptr);
+  switch (SCM_ITAG7 (cell_type))
+    {
+    case scm_tcs_cons_nimcar:
+      if (SCM_IMP (SCM_CDR (ptr)))
+	{
+	  ptr = SCM_CAR (ptr);
+	  goto gc_mark_nimp;
+	}
+      scm_gc_mark (SCM_CAR (ptr));
+      ptr = SCM_CDR (ptr);
+      goto gc_mark_nimp;
+    case scm_tcs_cons_imcar:
+      ptr = SCM_CDR (ptr);
+      goto gc_mark_loop;
+    case scm_tc7_pws:
+      scm_gc_mark (SCM_SETTER (ptr));
+      ptr = SCM_PROCEDURE (ptr);
+      goto gc_mark_loop;
+    case scm_tcs_struct:
+      {
+	/* XXX - use less explicit code. */
+	scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
+	scm_t_bits * vtable_data = (scm_t_bits *) word0;
+	SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
+	long len = SCM_SYMBOL_LENGTH (layout);
+	char * fields_desc = SCM_SYMBOL_CHARS (layout);
+	scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
+
+	if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+	  {
+	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
+	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
+	  }
+	if (len)
+	  {
+	    long x;
+
+	    for (x = 0; x < len - 2; x += 2, ++struct_data)
+	      if (fields_desc[x] == 'p')
+		scm_gc_mark (SCM_PACK (*struct_data));
+	    if (fields_desc[x] == 'p')
+	      {
+		if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+		  for (x = *struct_data++; x; --x, ++struct_data)
+		    scm_gc_mark (SCM_PACK (*struct_data));
+		else
+		  scm_gc_mark (SCM_PACK (*struct_data));
+	      }
+	  }
+	/* mark vtable */
+	ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
+	goto gc_mark_loop;
+      }
+      break;
+    case scm_tcs_closures:
+      if (SCM_IMP (SCM_ENV (ptr)))
+	{
+	  ptr = SCM_CLOSCAR (ptr);
+	  goto gc_mark_nimp;
+	}
+      scm_gc_mark (SCM_CLOSCAR (ptr));
+      ptr = SCM_ENV (ptr);
+      goto gc_mark_nimp;
+    case scm_tc7_vector:
+      i = SCM_VECTOR_LENGTH (ptr);
+      if (i == 0)
+	break;
+      while (--i > 0)
+	if (SCM_NIMP (SCM_VELTS (ptr)[i]))
+	  scm_gc_mark (SCM_VELTS (ptr)[i]);
+      ptr = SCM_VELTS (ptr)[0];
+      goto gc_mark_loop;
+#ifdef CCLO
+    case scm_tc7_cclo:
+      {
+	size_t i = SCM_CCLO_LENGTH (ptr);
+	size_t j;
+	for (j = 1; j != i; ++j)
+	  {
+	    SCM obj = SCM_CCLO_REF (ptr, j);
+	    if (!SCM_IMP (obj))
+	      scm_gc_mark (obj);
+	  }
+	ptr = SCM_CCLO_REF (ptr, 0);
+	goto gc_mark_loop;
+      }
+#endif
+#ifdef HAVE_ARRAYS
+    case scm_tc7_bvect:
+    case scm_tc7_byvect:
+    case scm_tc7_ivect:
+    case scm_tc7_uvect:
+    case scm_tc7_fvect:
+    case scm_tc7_dvect:
+    case scm_tc7_cvect:
+    case scm_tc7_svect:
+#ifdef HAVE_LONG_LONGS
+    case scm_tc7_llvect:
+#endif
+#endif
+    case scm_tc7_string:
+      break;
+
+    case scm_tc7_wvect:
+      SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
+      scm_weak_vectors = ptr;
+      if (SCM_IS_WHVEC_ANY (ptr))
+	{
+	  long x;
+	  long len;
+	  int weak_keys;
+	  int weak_values;
+
+	  len = SCM_VECTOR_LENGTH (ptr);
+	  weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
+	  weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
+
+	  for (x = 0; x < len; ++x)
+	    {
+	      SCM alist;
+	      alist = SCM_VELTS (ptr)[x];
+
+	      /* mark everything on the alist except the keys or
+	       * values, according to weak_values and weak_keys.  */
+	      while (   SCM_CONSP (alist)
+		     && !SCM_GC_MARK_P (alist)
+		     && SCM_CONSP (SCM_CAR (alist)))
+		{
+		  SCM kvpair;
+		  SCM next_alist;
+
+		  kvpair = SCM_CAR (alist);
+		  next_alist = SCM_CDR (alist);
+		  /*
+		   * Do not do this:
+		   * 	SCM_SET_GC_MARK (alist);
+		   *	SCM_SET_GC_MARK (kvpair);
+		   *
+		   * It may be that either the key or value is protected by
+		   * an escaped reference to part of the spine of this alist.
+		   * If we mark the spine here, and only mark one or neither of the
+		   * key and value, they may never be properly marked.
+		   * This leads to a horrible situation in which an alist containing
+		   * freelist cells is exported.
+		   *
+		   * So only mark the spines of these arrays last of all marking.
+		   * If somebody confuses us by constructing a weak vector
+		   * with a circular alist then we are hosed, but at least we
+		   * won't prematurely drop table entries.
+		   */
+		  if (!weak_keys)
+		    scm_gc_mark (SCM_CAR (kvpair));
+		  if (!weak_values)
+		    scm_gc_mark (SCM_CDR (kvpair));
+		  alist = next_alist;
+		}
+	      if (SCM_NIMP (alist))
+		scm_gc_mark (alist);
+	    }
+	}
+      break;
+
+    case scm_tc7_symbol:
+      ptr = SCM_PROP_SLOTS (ptr);
+      goto gc_mark_loop;
+    case scm_tc7_variable:
+      ptr = SCM_CELL_OBJECT_1 (ptr);
+      goto gc_mark_loop;
+    case scm_tcs_subrs:
+      break;
+    case scm_tc7_port:
+      i = SCM_PTOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1) 
+      if (!(i < scm_numptob))
+	SCM_MISC_ERROR ("undefined port type", SCM_EOL);
+#endif
+      if (SCM_PTAB_ENTRY(ptr))
+	scm_gc_mark (SCM_FILENAME (ptr));
+      if (scm_ptobs[i].mark)
+	{
+	  ptr = (scm_ptobs[i].mark) (ptr);
+	  goto gc_mark_loop;
+	}
+      else
+	return;
+      break;
+    case scm_tc7_smob:
+      switch (SCM_TYP16 (ptr))
+	{ /* should be faster than going through scm_smobs */
+	case scm_tc_free_cell:
+	  /* We have detected a free cell.  This can happen if non-object data
+	   * on the C stack points into guile's heap and is scanned during
+	   * conservative marking.  */
+	  break;
+	case scm_tc16_big:
+	case scm_tc16_real:
+	case scm_tc16_complex:
+	  break;
+	default:
+	  i = SCM_SMOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+	  if (!(i < scm_numsmob))
+	    SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
+#endif
+	  if (scm_smobs[i].mark)
+	    {
+	      ptr = (scm_smobs[i].mark) (ptr);
+	      goto gc_mark_loop;
+	    }
+	  else
+	    return;
+	}
+      break;
+    default:
+      SCM_MISC_ERROR ("unknown type", SCM_EOL);
+    }
+
+  /*
+    If we got here, then exhausted recursion options for PTR.  we
+    return (careful not to mark PTR, it might be the argument that we
+    were called with.)
+   */
+  return ;
+  
+gc_mark_loop:
+  if (SCM_IMP (ptr))
+    return;
+
+ gc_mark_nimp:
+  {
+    int valid_cell = CELL_P (ptr);
+
+    
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+    if (scm_debug_cell_accesses_p)
+      {
+    /* We are in debug mode.  Check the ptr exhaustively. */
+	
+	valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
+      }
+    
+#endif
+    if (!valid_cell)
+      SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
+  }
+  
+ if (SCM_GC_MARK_P (ptr))
+    return;
+
+  SCM_SET_GC_MARK (ptr);
+  goto   scm_mark_dependencies_again;
+  
+}
+#undef FUNC_NAME
+
+
+
+/* Mark a region conservatively */
+void
+scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
+{
+  unsigned long m;
+
+  for (m = 0; m < n; ++m)
+    {
+      SCM obj = * (SCM *) &x[m];
+      long int segment = scm_i_find_heap_segment_containing_object (obj);
+      if (segment >= 0)
+	scm_gc_mark (obj);
+    }
+}
+
+
+/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
+ * pointer to a cell on the heap.
+ */
+int
+scm_in_heap_p (SCM value)
+{
+  long int segment = scm_i_find_heap_segment_containing_object (value);
+  return (segment >= 0);
+}
+
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* If an allocated cell is detected during garbage collection, this
+ * means that some code has just obtained the object but was preempted
+ * before the initialization of the object was completed.  This meanst
+ * that some entries of the allocated cell may already contain SCM
+ * objects.  Therefore, allocated cells are scanned conservatively.
+ */
+
+scm_t_bits scm_tc16_allocated;
+
+static SCM
+allocated_mark (SCM cell)
+{
+  unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
+  unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
+  unsigned int i;
+
+  for (i = 1; i != span * 2; ++i)
+    {
+      SCM obj = SCM_CELL_OBJECT (cell, i);
+      long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
+      if (obj_segment >= 0)
+	scm_gc_mark (obj);
+    }
+  return SCM_BOOL_F;
+}
+
+SCM
+scm_deprecated_newcell (void)
+{
+  scm_c_issue_deprecation_warning 
+    ("SCM_NEWCELL is deprecated.  Use `scm_cell' instead.\n");
+
+  return scm_cell (scm_tc16_allocated, 0);
+}
+
+SCM
+scm_deprecated_newcell2 (void)
+{
+  scm_c_issue_deprecation_warning 
+    ("SCM_NEWCELL2 is deprecated.  Use `scm_double_cell' instead.\n");
+
+  return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
+}
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */
+
+
+void
+scm_gc_init_mark(void)
+{
+#if SCM_ENABLE_DEPRECATED == 1
+  scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
+  scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
+#endif
+}
+
+

libguile/gc-segment.c

@@ -0,0 +1,562 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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.  */
+
+#include <assert.h> 
+#include <stdio.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/pairs.h"
+#include "libguile/gc.h"
+#include "libguile/private-gc.h"
+
+
+
+#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \
+    ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS)
+#define SCM_GC_IN_CARD_HEADERP(x) \
+  (scm_t_cell *) (x) <  SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS
+
+
+size_t scm_max_segment_size;
+
+scm_t_heap_segment *
+scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
+{
+  scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));
+
+  if (!shs)
+    {
+      fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
+      abort ();
+    }
+  
+  shs->bounds[0] = NULL;
+  shs->bounds[1] = NULL;
+  shs->malloced = NULL;
+  shs->span = fl->span;
+  shs->freelist  = fl;
+  shs->next_free_card = NULL;
+  
+  return shs;
+}
+
+
+/*
+  Fill SEGMENT with memory both for data and mark bits.
+
+  RETURN:  1 on success, 0 failure  
+ */
+int 
+scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
+{
+  /*
+    round upwards
+   */
+  int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
+  int card_count =1 + (requested / sizeof (scm_t_cell)) /  card_data_cell_count; 
+
+  /*
+    one card extra due to alignment
+  */
+  size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
+    + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
+    ;
+  scm_t_c_bvec_long * bvec_ptr = 0;
+  scm_t_cell *  memory = 0;
+
+  /*
+    We use malloc to alloc the heap. On GNU libc this is 
+    equivalent to mmapping /dev/zero
+   */
+  SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));
+
+  if (memory == NULL)
+    return 0;
+
+  segment->malloced = memory;
+  segment->bounds[0] = SCM_GC_CARD_UP (memory);
+  segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
+
+  segment->freelist->heap_size += scm_i_segment_cell_count (segment);
+  
+  bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];
+
+
+  {
+    scm_t_cell *  ptr  = segment->bounds [0];
+
+    for (;
+	 ptr < segment->bounds[1]; ptr += SCM_GC_CARD_N_CELLS)
+      {
+	SCM_GC_CELL_BVEC (ptr) = bvec_ptr;
+	if (segment->span == 2) 
+	  SCM_GC_SET_CARD_DOUBLECELL (ptr);
+ 
+	bvec_ptr += SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
+
+	/*
+	  Don't init the mem. This is handled by lazy sweeping.
+	 */
+      }
+  }
+
+  segment->next_free_card = segment->bounds[0];
+  segment->first_time = 1;
+  return 1;
+}
+
+int
+scm_i_segment_card_count (scm_t_heap_segment * seg)
+{
+  return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
+}
+
+/*
+  Return the number of available single-cell data cells. 
+ */
+int
+scm_i_segment_cell_count (scm_t_heap_segment * seg)
+{
+  return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
+    + ((seg->span == 2) ? -1 : 0);
+}
+
+void
+scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
+{
+  scm_t_cell *  markspace = seg->bounds[1];
+
+  memset (markspace, 0x00,
+	  scm_i_segment_card_count (seg) *  SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
+}
+
+/*
+  RETURN:
+
+  Freelist. 
+*/
+SCM
+scm_i_sweep_some_cards (scm_t_heap_segment *seg)
+{
+  SCM cells = SCM_EOL;
+  int threshold = 512;
+  int collected = 0;
+  int (*sweeper) (scm_t_cell *, SCM *, int )
+    = (seg->first_time) ? &scm_init_card_freelist : &scm_i_sweep_card;
+
+  scm_t_cell * next_free = seg->next_free_card;
+  int cards_swept = 0;
+  
+  while (collected < threshold && next_free < seg->bounds[1])
+    {
+      collected += (*sweeper) (next_free, &cells, seg->span);
+      next_free += SCM_GC_CARD_N_CELLS;
+      cards_swept ++;
+    }
+
+  scm_gc_cells_swept +=  cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
+  scm_gc_cells_collected += collected * seg->span;
+  seg->freelist->collected += collected  * seg->span;
+
+  if(next_free == seg->bounds[1])
+    {
+      seg->first_time = 0;
+    }
+
+  seg->next_free_card = next_free;
+  return cells;
+}
+
+
+/*
+  Force a sweep of this entire segment. This doesn't modify sweep
+  statistics, it just frees the memory pointed to by to-be-swept
+  cells.
+
+  Implementation is slightly ugh, and how do we handle the swept_cells
+  statistic?
+ */
+void
+scm_i_sweep_segment (scm_t_heap_segment * seg)
+{
+  scm_t_cell * p = seg->next_free_card;
+  int yield = scm_gc_cells_collected;
+  int coll = seg->freelist->collected;
+
+  while (scm_i_sweep_some_cards (seg) != SCM_EOL)
+    ;
+
+  scm_gc_cells_collected = yield;
+  seg->freelist->collected = coll; 
+  
+  seg->next_free_card =p;
+}
+
+void
+scm_i_sweep_all_segments (char const  *reason)
+{
+  int i= 0; 
+
+  for (i = 0; i < scm_i_heap_segment_table_size; i++)
+    {
+      scm_i_sweep_segment (scm_i_heap_segment_table[i]);
+    }
+}
+
+
+/*
+  Heap segment table.
+
+  The table is sorted by the address of the data itself. This makes
+  for easy lookups. This is not portable: according to ANSI C,
+  pointers can only be compared within the same object (i.e. the same
+  block of malloced memory.). For machines with weird architectures,
+  this should be revised.
+  
+  (Apparently, for this reason 1.6 and earlier had macros for pointer
+  comparison. )
+  
+  perhaps it is worthwhile to remove the 2nd level of indirection in
+  the table, but this certainly makes for cleaner code.
+*/
+scm_t_heap_segment ** scm_i_heap_segment_table;
+size_t scm_i_heap_segment_table_size;
+scm_t_cell *lowest_cell;
+scm_t_cell *highest_cell; 
+
+
+void
+scm_i_clear_mark_space (void)
+{
+  int i = 0;
+  for (; i < scm_i_heap_segment_table_size; i++)
+    {
+      scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
+    }
+}
+
+
+/*
+  RETURN: index of inserted segment.
+ */
+int
+scm_i_insert_segment (scm_t_heap_segment * seg)
+{
+  size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
+  SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
+			       realloc ((char *)scm_i_heap_segment_table, size)));
+
+  /*
+    We can't alloc 4 more bytes. This is hopeless.
+   */
+  if (!scm_i_heap_segment_table)
+    {
+      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
+      abort ();
+    }
+
+  if (!lowest_cell)
+    {
+      lowest_cell = seg->bounds[0];
+      highest_cell = seg->bounds[1];
+    }
+  else
+    {
+      lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
+      highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
+    }
+
+  
+  {
+    int i = 0;
+    int j = 0;
+
+    while (i < scm_i_heap_segment_table_size
+	   && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
+      i++;
+    for (j = scm_i_heap_segment_table_size; j > i; --j)
+      scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
+
+    scm_i_heap_segment_table [i] = seg;
+    scm_i_heap_segment_table_size ++;
+
+    return i;
+  }
+}
+
+SCM
+scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
+{
+  int i = fl->heap_segment_idx;
+  SCM collected =SCM_EOL;
+  
+  if (i == -1)
+    i++;
+  
+  for (;
+       i < scm_i_heap_segment_table_size; i++)
+    {
+      if (scm_i_heap_segment_table[i]->freelist != fl)
+	continue;
+      
+      collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);
+
+
+      if (collected != SCM_EOL)       /* Don't increment i */
+	break;
+    }
+
+  fl->heap_segment_idx = i;
+  
+  return collected;
+}
+
+
+
+
+void
+scm_i_reset_segments (void)
+{
+  int i = 0;
+  for (; i < scm_i_heap_segment_table_size; i++)
+    {
+      scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
+      seg->next_free_card = seg->bounds[0];
+    }
+}
+
+
+/*
+  Determine whether the given value does actually represent a cell in
+  some heap segment.  If this is the case, the number of the heap
+  segment is returned.  Otherwise, -1 is returned.  Binary search is
+  used to determine the heap segment that contains the cell.
+
+
+  I think this function is too long to be inlined. --hwn
+*/
+long int
+scm_i_find_heap_segment_containing_object (SCM obj)
+{
+  if (!CELL_P (obj))
+    return -1;
+
+  if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell)
+    return -1;
+
+  
+    {
+      scm_t_cell *  ptr = SCM2PTR (obj);
+      unsigned long int i = 0;
+      unsigned long int j = scm_i_heap_segment_table_size - 1;
+
+      if (ptr < scm_i_heap_segment_table[i]->bounds[0])
+	return -1;
+      else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
+	return -1;
+      else
+	{
+	  while (i < j)
+	    {
+	      if (ptr < scm_i_heap_segment_table[i]->bounds[1])
+		{
+		  break;
+		}
+	      else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
+		{
+		  i = j;
+		  break;
+		}
+	      else
+		{
+		  unsigned long int k = (i + j) / 2;
+
+		  if (k == i)
+		    return -1;
+		  else if (ptr <  scm_i_heap_segment_table[k]->bounds[1])
+		    {
+		      j = k;
+		      ++i;
+		      if (ptr <  scm_i_heap_segment_table[i]->bounds[0])
+			return -1;
+		    }
+		  else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
+		    {
+		      i = k;
+		      --j;
+		      if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
+			return -1;
+		    }
+		}
+	    }
+
+	  if (!DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
+	    return -1;
+	  else if (SCM_GC_IN_CARD_HEADERP (ptr))
+	    return -1;
+	  else
+	    return i;
+	}
+    }
+}
+
+
+/*
+  Important entry point: try to grab some memory, and make it into a
+  segment.
+
+  RETURN: the index of the segment.
+ */
+int 
+scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_error error_policy)
+{
+  size_t len;
+
+  if (scm_gc_heap_lock)
+    {
+      /* Critical code sections (such as the garbage collector) aren't
+       * supposed to add heap segments.
+       */
+      fprintf (stderr, "scm_i_get_new_heap_segment: Can not extend locked heap.\n");
+      abort ();
+    }
+
+
+  /* Pick a size for the new heap segment.
+   * The rule for picking the size of a segment is explained in
+   * gc.h
+   */
+  {
+    /* Assure that the new segment is predicted to be large enough.
+     *
+     * New yield should at least equal GC fraction of new heap size, i.e.
+     *
+     *   y + dh > f * (h + dh)
+     *
+     *    y : yield
+     *    f : min yield fraction
+     *    h : heap size
+     *   dh : size of new heap segment
+     *
+     * This gives dh > (f * h - y) / (1 - f)
+     */
+
+    /*
+      where is is this explanation supposed to be?  --hwn
+     */
+    int f = freelist->min_yield_fraction;
+    unsigned long h = SCM_HEAP_SIZE;
+    size_t min_cells = (f * h - 100 * (long) scm_gc_cells_collected) / (99 - f);
+
+    /* Make heap grow with factor 1.5 */
+    len =  freelist->heap_size / 2;
+#ifdef DEBUGINFO
+    fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
+#endif
+
+    /*
+      Original code adds freelist->cluster_size here.
+     */
+    if (len < min_cells)
+      len = min_cells;  
+    len *= sizeof (scm_t_cell);
+    /* force new sampling */
+    freelist->collected = LONG_MAX;
+  }
+
+  if (len > scm_max_segment_size)
+    len = scm_max_segment_size;
+
+  {
+    size_t smallest;
+    scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
+    
+    smallest = 1024 * 10;  /* UGH.  */
+
+    if (len < smallest)
+      len = smallest;
+
+    /* Allocate with decaying ambition. */
+    while ((len >= SCM_MIN_HEAP_SEG_SIZE)
+	   && (len >= smallest))
+      {
+	if (scm_i_initialize_heap_segment_data (seg, len))
+	  {
+	    return scm_i_insert_segment (seg);
+	  }
+	
+	len /= 2;
+      }
+  }
+
+  if (error_policy == abort_on_error)
+    {
+      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
+      abort ();
+    }
+  return -1;
+}
+
+
+void
+scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist)
+{
+  scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
+ 
+  if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
+    {
+      freelist->heap_segment_idx = scm_i_insert_segment (seg);
+    }
+
+  /*
+    Why the fuck  try twice? --hwn
+   */
+  if (!seg->malloced)
+    {
+      scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
+    }
+
+  if (freelist->min_yield_fraction)
+    freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
+			    / 100);
+}
+

libguile/private-gc.h

@@ -0,0 +1,239 @@
+/*
+  (c) FSF 2002. 
+*/
+   
+
+#ifndef PRIVATE_GC
+#define PRIVATE_GC
+
+#include  "_scm.h"
+
+/* {heap tuning parameters}
+ *
+ * These are parameters for controlling memory allocation.  The heap
+ * is the area out of which scm_cons, and object headers are allocated.
+ *
+ * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
+ * 64 bit machine.  The units of the _SIZE parameters are bytes.
+ * Cons pairs and object headers occupy one heap cell.
+ *
+ * SCM_INIT_HEAP_SIZE is the initial size of heap.  If this much heap is
+ * allocated initially the heap will grow by half its current size
+ * each subsequent time more heap is needed.
+ *
+ * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
+ * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
+ * heap is needed.  SCM_HEAP_SEG_SIZE must fit into type size_t.  This code
+ * is in scm_init_storage() and alloc_some_heap() in sys.c
+ *
+ * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
+ * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
+ *
+ * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
+ * is needed.
+ */
+
+
+/*
+ * Heap size 45000 and 40% min yield gives quick startup and no extra
+ * heap allocation.  Having higher values on min yield may lead to
+ * large heaps, especially if code behaviour is varying its
+ * maximum consumption between different freelists.
+ */
+
+/*
+  These values used to be global C variables. However, they're also
+  available through the environment, and having a double interface is
+  confusing. Now they're #defines --hwn.
+ */
+
+#define SCM_DEFAULT_INIT_HEAP_SIZE_1  256*1024
+#define SCM_DEFAULT_MIN_YIELD_1 40
+#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024
+
+/* The following value may seem large, but note that if we get to GC at
+ * all, this means that we have a numerically intensive application
+ */
+#define SCM_DEFAULT_MIN_YIELD_2 40
+#define SCM_DEFAULT_MAX_SEGMENT_SIZE  2097000L /* a little less (adm) than 2 Mb */
+
+
+
+#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD)
+#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell))
+
+
+#define DOUBLECELL_ALIGNED_P(x)  (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
+
+
+
+
+int scm_getenv_int (const char *var, int def);
+
+
+typedef enum { return_on_error, abort_on_error } policy_on_error;
+
+/* gc-freelist*/
+
+/*
+  FREELIST:
+
+  A struct holding GC statistics on a particular type of cells.
+*/
+typedef struct scm_t_cell_type_statistics {
+
+  /*
+    heap segment where the last cell was allocated 
+  */
+  int heap_segment_idx;
+
+  /* minimum yield on this list in order not to grow the heap
+   */
+  long min_yield;
+
+  /* defines min_yield as percent of total heap size
+   */
+  int min_yield_fraction;
+  
+  /* number of cells per object on this list */
+  int span;
+
+  /* number of collected cells during last GC */
+  unsigned long collected;
+
+  /* number of collected cells during penultimate GC */
+  unsigned long collected_1;
+
+  /* total number of cells in heap segments
+   * belonging to this list.
+   */
+  unsigned long heap_size;
+
+} scm_t_cell_type_statistics;
+
+
+extern scm_t_cell_type_statistics scm_i_master_freelist;
+extern scm_t_cell_type_statistics scm_i_master_freelist2;
+extern unsigned long scm_gc_cells_collected_1;
+
+void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist);
+void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist);
+int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist);
+     
+#define SCM_HEAP_SIZE \
+  (scm_i_master_freelist.heap_size + scm_i_master_freelist2.heap_size)
+
+
+#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
+#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
+
+#define CELL_P(x)  (SCM_ITAG3 (x) == scm_tc3_cons)
+
+/*
+  gc-mark
+ */
+
+
+void scm_mark_all (void);
+
+
+
+/*
+gc-segment:
+*/
+
+
+
+
+/*
+
+ Cells are stored in a heap-segment: it is a contiguous chunk of
+ memory, that associated with one freelist. 
+*/
+
+typedef struct scm_t_heap_segment
+{
+  /*
+    {lower, upper} bounds of the segment
+
+    The upper bound is also the start of the mark space.
+  */
+  scm_t_cell *bounds[2];
+
+  /*
+    If we ever decide to give it back, we could do it with this ptr.
+
+    Note that giving back memory is not very useful; as long we don't
+    touch a chunk of memory, the virtual memory system will keep it
+    swapped out. We could simply forget about a block.
+
+    (not that we do that, but anyway.) 
+   */
+
+  void* malloced;
+
+  scm_t_cell * next_free_card;
+  
+  /* address of the head-of-freelist pointer for this segment's cells.
+     All segments usually point to the same one, scm_i_freelist.  */
+  scm_t_cell_type_statistics *freelist;
+  
+  /* number of cells per object in this segment */
+  int span;
+
+
+  /*
+    Is this the first time that the cells are accessed? 
+   */
+  int first_time;
+  
+} scm_t_heap_segment;
+
+
+
+/*
+
+  A table of segment records is kept that records the upper and
+  lower extents of the segment;  this is used during the conservative
+  phase of gc to identify probably gc roots (because they point
+  into valid segments at reasonable offsets).
+
+*/
+extern scm_t_heap_segment ** scm_i_heap_segment_table;
+extern size_t scm_i_heap_segment_table_size;
+
+
+int scm_init_card_freelist (scm_t_cell * card, SCM *free_list,int);
+int scm_i_sweep_card (scm_t_cell * card, SCM *free_list,int);
+int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested);
+int scm_i_segment_card_count (scm_t_heap_segment * seg);
+int scm_i_segment_cell_count (scm_t_heap_segment * seg);
+
+void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
+scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
+SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg);
+void scm_i_sweep_segment (scm_t_heap_segment * seg);
+
+     
+int scm_i_insert_segment (scm_t_heap_segment * seg);
+long int scm_i_find_heap_segment_containing_object (SCM obj);
+int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error);
+void scm_i_clear_mark_space (void);
+void scm_i_sweep_segments (void);
+SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl);
+void scm_i_reset_segments (void);
+void scm_i_sweep_all_segments (char const *reason);
+void scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist);
+
+extern long int scm_i_deprecated_memory_return;
+
+
+/*
+  global init funcs.
+ */
+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