summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/gc-freelist.c210
-rw-r--r--libguile/gc-malloc.c407
-rw-r--r--libguile/gc-mark.c562
-rw-r--r--libguile/gc-segment.c562
-rw-r--r--libguile/private-gc.h239
5 files changed, 1980 insertions, 0 deletions
diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c
new file mode 100644
index 000000000..21720534a
--- /dev/null
+++ b/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;
+}
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
new file mode 100644
index 000000000..40d4ef907
--- /dev/null
+++ b/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 */
diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c
new file mode 100644
index 000000000..49cb77e29
--- /dev/null
+++ b/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
+}
+
+
diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c
new file mode 100644
index 000000000..a3859df7b
--- /dev/null
+++ b/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);
+}
+
diff --git a/libguile/private-gc.h b/libguile/private-gc.h
new file mode 100644
index 000000000..52556bee6
--- /dev/null
+++ b/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