summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog10
-rw-r--r--libguile/Makefile.am10
-rw-r--r--libguile/continuations.c2
-rw-r--r--libguile/gc-card.c337
-rw-r--r--libguile/gc.c2325
-rw-r--r--libguile/gc.h147
-rw-r--r--libguile/gdbint.c29
-rw-r--r--libguile/guardians.c12
-rw-r--r--libguile/init.c4
-rw-r--r--libguile/inline.c5
-rw-r--r--libguile/inline.h109
-rw-r--r--libguile/numbers.c6
-rw-r--r--libguile/pairs.c2
-rw-r--r--libguile/print.c2
-rw-r--r--libguile/procs.c2
-rw-r--r--libguile/regex-posix.c9
-rw-r--r--libguile/struct.c6
-rw-r--r--libguile/symbols.c11
-rw-r--r--libguile/weaks.c17
19 files changed, 777 insertions, 2268 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 9522a54c3..7ec6feb57 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,13 @@
+2002-08-04 Han-Wen <hanwen@cs.uu.nl>
+
+ * numbers.c (big2str): return "0" for 0 iso. ""
+
+ * gc-segment.c, gc-malloc.c gc-mark.c, gc-freelist.c, gc-card.c, private-gc.h:
+ new file
+
+ * gc.c: completely revised and cleaned up the GC. It now uses lazy
+ sweeping. More documentation in workbook/newgc.text
+
2002-07-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
* random.c (rstate_free): Return zero.
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index c8b16a572..87694b67b 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -64,7 +64,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
chars.c continuations.c convert.c debug.c deprecation.c \
dynwind.c environments.c eq.c error.c eval.c evalext.c extensions.c \
feature.c fluids.c fports.c \
- gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \
+ gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c gc-freelist.c \
+ gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \
gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \
hashtab.c hooks.c init.c inline.c ioext.c iselect.c keywords.c \
lang.c list.c \
@@ -79,7 +80,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
continuations.x debug.x deprecation.x dynl.x dynwind.x \
environments.x eq.x \
error.x eval.x evalext.x extensions.x feature.x fluids.x fports.x \
- gc.x goops.x \
+ gc.x gc-mark.x gc-segment.x gc-malloc.x gc-card.x goops.x \
gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \
keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \
numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \
@@ -95,7 +96,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
boolean.doc chars.doc continuations.doc debug.doc dynl.doc \
dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc gc.doc goops.doc \
- gsubr.doc \
+ gsubr.doc gc-mark.doc gc-segment.doc gc-malloc.doc gc-card.doc \
guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \
iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \
mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \
@@ -130,7 +131,8 @@ install-exec-hook:
## working.
noinst_HEADERS = coop-threads.c coop-threads.h coop.c \
num2integral.i.c num2float.i.c convert.i.c \
- win32-uname.h win32-dirent.h win32-socket.h
+ win32-uname.h win32-dirent.h win32-socket.h\
+ private-gc.h
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(LIBLTDL) $(THREAD_LIBS_LOCAL)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 0cf76a32a..c44465bcc 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -270,7 +270,7 @@ scm_dynthrow (SCM cont, SCM val)
grow_stack (cont, val);
#else
dst -= continuation->num_stack_items;
- if (SCM_PTR_LE (dst, &stack_top_element))
+ if (dst <= &stack_top_element)
grow_stack (cont, val);
#endif /* def SCM_STACK_GROWS_UP */
diff --git a/libguile/gc-card.c b/libguile/gc-card.c
new file mode 100644
index 000000000..7daa6df4c
--- /dev/null
+++ b/libguile/gc-card.c
@@ -0,0 +1,337 @@
+/* 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 "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"
+
+
+#include "libguile/private-gc.h"
+
+long int scm_i_deprecated_memory_return;
+
+
+/*
+ Init all the free cells in CARD, prepending to *FREE_LIST.
+
+ Return: number of free cells found in this card.
+
+ It would be cleaner to have a separate function sweep_value(), but
+ that is too slow (functions with switch statements can't be
+ inlined).
+
+ */
+
+int
+scm_i_sweep_card (scm_t_cell * p, SCM *free_list, int span)
+#define FUNC_NAME "sweep_card"
+{
+ scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
+ scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
+ int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
+ int free_count = 0;
+
+ /*
+ I tried something fancy with shifting by one bit every word from
+ the bitvec in turn, but it wasn't any faster, but quite bit
+ hairier.
+ */
+ for (p += offset; p < end; p += span, offset += span)
+ {
+ SCM scmptr = PTR2SCM(p);
+ if (SCM_C_BVEC_GET (bitvec, offset))
+ continue;
+
+ switch (SCM_TYP7 (scmptr))
+ {
+ case scm_tcs_struct:
+ {
+ /* Structs need to be freed in a special order.
+ * This is handled by GC C hooks in struct.c.
+ */
+ SCM_SET_STRUCT_GC_CHAIN (p, scm_structs_to_free);
+ scm_structs_to_free = scmptr;
+ }
+ continue;
+
+ case scm_tcs_cons_imcar:
+ case scm_tcs_cons_nimcar:
+ case scm_tcs_closures:
+ case scm_tc7_pws:
+ break;
+ case scm_tc7_wvect:
+ case scm_tc7_vector:
+ {
+ unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
+ if (length > 0)
+ {
+ scm_gc_free (SCM_VECTOR_BASE (scmptr),
+ length * sizeof (scm_t_bits),
+ "vector");
+ }
+ break;
+ }
+#ifdef CCLO
+ case scm_tc7_cclo:
+ scm_gc_free (SCM_CCLO_BASE (scmptr),
+ SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
+ "compiled closure");
+ break;
+#endif
+#ifdef HAVE_ARRAYS
+ case scm_tc7_bvect:
+ {
+ unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
+ if (length > 0)
+ {
+ scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
+ (sizeof (long)
+ * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
+ "vector");
+ }
+ }
+ break;
+ case scm_tc7_byvect:
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
+ case scm_tc7_svect:
+#ifdef HAVE_LONG_LONGS
+ case scm_tc7_llvect:
+#endif
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ scm_gc_free (SCM_UVECTOR_BASE (scmptr),
+ (SCM_UVECTOR_LENGTH (scmptr)
+ * scm_uniform_element_size (scmptr)),
+ "vector");
+ break;
+#endif
+ case scm_tc7_string:
+ scm_gc_free (SCM_STRING_CHARS (scmptr),
+ SCM_STRING_LENGTH (scmptr) + 1, "string");
+ break;
+ case scm_tc7_symbol:
+ scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
+ SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
+ break;
+ case scm_tc7_variable:
+ break;
+ case scm_tcs_subrs:
+ /* the various "subrs" (primitives) are never freed */
+ continue;
+ case scm_tc7_port:
+ if SCM_OPENP (scmptr)
+ {
+ int k = SCM_PTOBNUM (scmptr);
+ size_t mm;
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(k < scm_numptob))
+ SCM_MISC_ERROR ("undefined port type", SCM_EOL);
+#endif
+ /* Keep "revealed" ports alive. */
+ if (scm_revealed_count (scmptr) > 0)
+ continue;
+
+ /* Yes, I really do mean scm_ptobs[k].free */
+ /* rather than ftobs[k].close. .close */
+ /* is for explicit CLOSE-PORT by user */
+ mm = scm_ptobs[k].free (scmptr);
+
+ if (mm != 0)
+ {
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_c_issue_deprecation_warning
+ ("Returning non-0 from a port free function is "
+ "deprecated. Use scm_gc_free et al instead.");
+ scm_c_issue_deprecation_warning_fmt
+ ("(You just returned non-0 while freeing a %s.)",
+ SCM_PTOBNAME (k));
+ scm_i_deprecated_memory_return += mm;
+#else
+ abort ();
+#endif
+ }
+
+ SCM_SETSTREAM (scmptr, 0);
+ scm_remove_from_port_table (scmptr);
+ scm_gc_ports_collected++;
+ SCM_CLR_PORT_OPEN_FLAG (scmptr);
+ }
+ break;
+ case scm_tc7_smob:
+ switch SCM_TYP16 (scmptr)
+ {
+ case scm_tc_free_cell:
+ case scm_tc16_real:
+ break;
+#ifdef SCM_BIGDIG
+ case scm_tc16_big:
+ scm_gc_free (SCM_BDIGITS (scmptr),
+ ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
+ / SCM_CHAR_BIT)), "bignum");
+ break;
+#endif /* def SCM_BIGDIG */
+ case scm_tc16_complex:
+ scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
+ "complex");
+ break;
+ default:
+ {
+ int k;
+ k = SCM_SMOBNUM (scmptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(k < scm_numsmob))
+ SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
+#endif
+ if (scm_smobs[k].free)
+ {
+ size_t mm;
+ mm = scm_smobs[k].free (scmptr);
+ if (mm != 0)
+ {
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_c_issue_deprecation_warning
+ ("Returning non-0 from a smob free function is "
+ "deprecated. Use scm_gc_free et al instead.");
+ scm_c_issue_deprecation_warning_fmt
+ ("(You just returned non-0 while freeing a %s.)",
+ SCM_SMOBNAME (k));
+ scm_i_deprecated_memory_return += mm;
+#else
+ abort();
+#endif
+ }
+ }
+ break;
+ }
+ }
+ break;
+ default:
+ SCM_MISC_ERROR ("unknown type", SCM_EOL);
+ }
+
+
+ SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
+ SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
+ *free_list = PTR2SCM (p);
+ free_count ++;
+ }
+ return free_count;
+}
+#undef FUNC_NAME
+
+
+/*
+ Like sweep, but no complicated logic to do the sweeping.
+ */
+int
+scm_init_card_freelist (scm_t_cell * card, SCM *free_list, int span)
+{
+ scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
+ scm_t_cell *p = end - span;
+
+ /*
+ ASSUMPTION: n_header_cells <= 2.
+ */
+ for (; p > card; p -= span)
+ {
+ SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
+ SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
+ *free_list = PTR2SCM (p);
+ }
+
+ return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
+}
+
+
+#if 0
+/*
+ These functions are meant to be called from GDB as a debug aid.
+
+ I've left them as a convenience for future generations.
+ */
+
+
+int scm_gc_marked_p (SCM obj);
+scm_t_cell * scm_gc_get_card (SCM obj);
+long * scm_gc_get_bvec (SCM obj);
+
+typedef struct scm_t_list_cell_struct {
+ scm_t_bits car;
+ struct scm_t_list_cell_struct * cdr;
+} scm_t_list_cell;
+
+int
+scm_gc_marked_p (SCM obj)
+{
+ return SCM_GC_MARK_P(obj);
+}
+
+scm_t_cell *
+scm_gc_get_card (SCM obj)
+{
+ return SCM_GC_CELL_CARD(obj);
+}
+
+long *
+scm_gc_get_bvec (SCM obj)
+{
+ return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
+}
+#endif
diff --git a/libguile/gc.c b/libguile/gc.c
index fd7a0562e..0a4a1cfad 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -42,15 +42,11 @@
/* #define DEBUGINFO */
-/* SECTION: This code is compiled once.
- */
-
-#ifndef MARK_DEPENDENCIES
-
#include <stdio.h>
#include <errno.h>
#include <string.h>
+#include <assert.h>
#ifdef __ia64__
#include <ucontext.h>
@@ -73,6 +69,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#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"
@@ -89,22 +86,10 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include <unistd.h>
#endif
-#ifdef __STDC__
-#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
-
-
-#define CELL_P(x) (SCM_ITAG3 (x) == scm_tc3_cons)
unsigned int scm_gc_running_p = 0;
-
-
#if (SCM_DEBUG_CELL_ACCESSES == 1)
/* Set this to != 0 if every cell that is accessed shall be checked:
@@ -125,55 +110,60 @@ static unsigned int debug_cells_gc_interval = 0;
* find places in the C code where references are dropped for extremely short
* periods.
*/
+
void
scm_assert_cell_valid (SCM cell)
{
static unsigned int already_running = 0;
- if (scm_debug_cell_accesses_p && !already_running)
+ if (!already_running)
{
already_running = 1; /* set to avoid recursion */
- if (!scm_cellp (cell))
+ /*
+ During GC, no user-code should be run, and the guile core should
+ use non-protected accessors.
+ */
+ if (scm_gc_running_p)
+ abort();
+
+ /*
+ Only scm_in_heap_p is wildly expensive.
+ */
+ if (scm_debug_cell_accesses_p)
+ if (!scm_in_heap_p (cell))
+ {
+ fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
+ (unsigned long) SCM_UNPACK (cell));
+ abort ();
+ }
+
+ if (!SCM_GC_MARK_P (cell))
{
- fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lux\n",
+ fprintf (stderr,
+ "scm_assert_cell_valid: this object is unmarked. \n"
+ "It has been garbage-collected in the last GC run: "
+ "%lux\n",
(unsigned long) SCM_UNPACK (cell));
abort ();
}
- else if (!scm_gc_running_p)
+
+
+ /* If desired, perform additional garbage collections after a user
+ * defined number of cell accesses.
+ */
+ if (scm_debug_cell_accesses_p && debug_cells_gc_interval)
{
- /* Dirk::FIXME:: During garbage collection there occur references to
- free cells. This is allright during conservative marking, but
- should not happen otherwise (I think). The case of free cells
- accessed during conservative marking is handled in function
- scm_mark_locations. However, there still occur accesses to free
- cells during gc. I don't understand why this happens. If it is
- a bug and gets fixed, the following test should also work while
- gc is running.
- */
- if (SCM_FREE_CELL_P (cell))
+ static unsigned int counter = 0;
+
+ if (counter != 0)
{
- fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lux\n",
- (unsigned long) SCM_UNPACK (cell));
- abort ();
+ --counter;
}
-
- /* If desired, perform additional garbage collections after a user
- * defined number of cell accesses.
- */
- if (debug_cells_gc_interval)
+ else
{
- static unsigned int counter = 0;
-
- if (counter != 0)
- {
- --counter;
- }
- else
- {
- counter = debug_cells_gc_interval;
- scm_igc ("scm_assert_cell_valid");
- }
+ counter = debug_cells_gc_interval;
+ scm_igc ("scm_assert_cell_valid");
}
}
already_running = 0; /* re-enable */
@@ -209,154 +199,34 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
-#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
-
-
-
-/* {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.
- *
- * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
- * trigger a GC.
- *
- * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must
- * be reclaimed by a GC triggered by a malloc. If less than this is
- * reclaimed, the trigger threshold is raised. [I don't know what a
- * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
- * work around a oscillation that caused almost constant GC.]
- */
+#else
/*
- * 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.
- */
-
-#define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS)
-#define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L)
-#define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS)
-size_t scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1)
- / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE);
-int scm_default_min_yield_1 = 40;
-
-#define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2))
-size_t scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1)
- / SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE);
-/* 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
+ Provide a stub, so people can use their Scheme code on non-debug
+ versions of GUILE as well.
*/
-int scm_default_min_yield_2 = 40;
-
-size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */
-
-#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE)
-#ifdef _QC
-# define SCM_HEAP_SEG_SIZE 32768L
-#else
-# ifdef sequent
-# define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_t_cell))
-# else
-# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell))
-# endif
-#endif
-/* Make heap grow with factor 1.5 */
-#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
-#define SCM_INIT_MALLOC_LIMIT 100000
-#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
-
-/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_t_cell * span)
- aligned inner bounds for allocated storage */
-
-#ifdef PROT386
-/*in 386 protected mode we must only adjust the offset */
-# define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
-# define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
-#else
-# ifdef _UNICOS
-# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
-# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
-# else
-# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & ((long)(p)+sizeof(scm_t_cell)*(span)-1L))
-# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & (long)(p))
-# endif /* UNICOS */
-#endif /* PROT386 */
+SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
+ (SCM flag),
+ "This function is used to turn on checking for a debug version of GUILE. This version does not support this functionality\n")
+#define FUNC_NAME s_scm_set_debug_cell_accesses_x
+{
+
+ /*
+ do nothing
+ */
-#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
+ scm_remember_upto_here (flag);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
-#define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1)
-#define CLUSTER_SIZE_IN_BYTES(freelist) \
- (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE)
+#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
-/* scm_freelists
- */
-typedef struct scm_t_freelist {
- /* collected cells */
- SCM cells;
- /* number of cells left to collect before cluster is full */
- unsigned int left_to_collect;
- /* number of clusters which have been allocated */
- unsigned int clusters_allocated;
- /* a list of freelists, each of size cluster_size,
- * except the last one which may be shorter
- */
- SCM clusters;
- SCM *clustertail;
- /* this is the number of objects in each cluster, including the spine cell */
- unsigned int cluster_size;
- /* indicates that we should grow heap instead of GC:ing
- */
- int grow_heap_p;
- /* 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_freelist;
-
-SCM scm_freelist = SCM_EOL;
-scm_t_freelist scm_master_freelist = {
- SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0, 0
-};
-SCM scm_freelist2 = SCM_EOL;
-scm_t_freelist scm_master_freelist2 = {
- SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0, 0
-};
+SCM scm_i_freelist = SCM_EOL;
+SCM scm_i_freelist2 = SCM_EOL;
+
/* scm_mtrigger
* is the number of bytes of malloc allocation needed to trigger gc.
@@ -389,15 +259,13 @@ SCM scm_structs_to_free;
unsigned long scm_cells_allocated = 0;
unsigned long scm_mallocated = 0;
unsigned long scm_gc_cells_collected;
-unsigned long scm_gc_yield;
-static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */
+unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */
unsigned long scm_gc_malloc_collected;
unsigned long scm_gc_ports_collected;
unsigned long scm_gc_time_taken = 0;
static unsigned long t_before_gc;
static unsigned long t_before_sweep;
unsigned long scm_gc_mark_time_taken = 0;
-unsigned long scm_gc_sweep_time_taken = 0;
unsigned long scm_gc_times = 0;
unsigned long scm_gc_cells_swept = 0;
double scm_gc_cells_marked_acc = 0.;
@@ -410,321 +278,17 @@ SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
-SCM_SYMBOL (sym_gc_sweep_time_taken, "gc-sweep-time-taken");
SCM_SYMBOL (sym_times, "gc-times");
SCM_SYMBOL (sym_cells_marked, "cells-marked");
SCM_SYMBOL (sym_cells_swept, "cells-swept");
-typedef struct scm_t_heap_seg_data
-{
- /* lower and upper bounds of the segment */
- SCM_CELLPTR bounds[2];
-
- /* address of the head-of-freelist pointer for this segment's cells.
- All segments usually point to the same one, scm_freelist. */
- scm_t_freelist *freelist;
-
- /* number of cells per object in this segment */
- int span;
-} scm_t_heap_seg_data;
-
-
-
-static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_t_freelist *);
-
-typedef enum { return_on_error, abort_on_error } policy_on_error;
-static void alloc_some_heap (scm_t_freelist *, policy_on_error);
-
-
-#define SCM_HEAP_SIZE \
- (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
-#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
-
-#define BVEC_GROW_SIZE 256
-#define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE)
-#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_t_c_bvec_limb))
-
-/* mark space allocation */
-
-typedef struct scm_t_mark_space
-{
- scm_t_c_bvec_limb *bvec_space;
- struct scm_t_mark_space *next;
-} scm_t_mark_space;
-
-static scm_t_mark_space *current_mark_space;
-static scm_t_mark_space **mark_space_ptr;
-static ptrdiff_t current_mark_space_offset;
-static scm_t_mark_space *mark_space_head;
-
-static scm_t_c_bvec_limb *
-get_bvec ()
-#define FUNC_NAME "get_bvec"
-{
- scm_t_c_bvec_limb *res;
-
- if (!current_mark_space)
- {
- SCM_SYSCALL (current_mark_space = (scm_t_mark_space *) malloc (sizeof (scm_t_mark_space)));
- if (!current_mark_space)
- SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
-
- current_mark_space->bvec_space = NULL;
- current_mark_space->next = NULL;
-
- *mark_space_ptr = current_mark_space;
- mark_space_ptr = &(current_mark_space->next);
-
- return get_bvec ();
- }
-
- if (!(current_mark_space->bvec_space))
- {
- SCM_SYSCALL (current_mark_space->bvec_space =
- (scm_t_c_bvec_limb *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1));
- if (!(current_mark_space->bvec_space))
- SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
-
- current_mark_space_offset = 0;
-
- return get_bvec ();
- }
-
- if (current_mark_space_offset == BVEC_GROW_SIZE_IN_LIMBS)
- {
- current_mark_space = NULL;
-
- return get_bvec ();
- }
-
- res = current_mark_space->bvec_space + current_mark_space_offset;
- current_mark_space_offset += SCM_GC_CARD_BVEC_SIZE_IN_LIMBS;
-
- return res;
-}
-#undef FUNC_NAME
-
-
-static void
-clear_mark_space ()
-{
- scm_t_mark_space *ms;
-
- for (ms = mark_space_head; ms; ms = ms->next)
- memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES);
-}
-
-
-
-/* Debugging functions. */
-
-#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-
-static long int heap_segment (SCM obj); /* forw decl: non-debugging func */
-
-static void
-map_free_list (scm_t_freelist *master, SCM freelist)
-{
- long last_seg = -1, count = 0;
- SCM f;
-
- for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f))
- {
- long int this_seg = heap_segment (f);
-
- if (this_seg == -1)
- {
- fprintf (stderr,
- "map_free_list: can't find segment containing cell %lux\n",
- (unsigned long int) SCM_UNPACK (f));
- abort ();
- }
- else if (this_seg != last_seg)
- {
- if (last_seg != -1)
- fprintf (stderr, " %5ld %d-cells in segment %ld\n",
- (long) count, master->span, (long) last_seg);
- last_seg = this_seg;
- count = 0;
- }
- count++;
- }
- if (last_seg != -1)
- fprintf (stderr, " %5ld %d-cells in segment %ld\n",
- (long) count, master->span, (long) last_seg);
-}
-
-SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
- (),
- "Print debugging information about the free-list.\n"
- "@code{map-free-list} is only included in\n"
- "@code{--enable-guile-debug} builds of Guile.")
-#define FUNC_NAME s_scm_map_free_list
-{
- size_t i;
-
- fprintf (stderr, "%ld segments total (%d:%ld",
- (long) scm_n_heap_segs,
- scm_heap_table[0].span,
- (long) (scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0]));
-
- for (i = 1; i != scm_n_heap_segs; i++)
- fprintf (stderr, ", %d:%ld",
- scm_heap_table[i].span,
- (long) (scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0]));
- fprintf (stderr, ")\n");
- map_free_list (&scm_master_freelist, scm_freelist);
- map_free_list (&scm_master_freelist2, scm_freelist2);
- fflush (stderr);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static long last_cluster;
-static long last_size;
-
-static long
-free_list_length (char *title, long i, SCM freelist)
-{
- SCM ls;
- long n = 0;
- for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls))
- if (SCM_FREE_CELL_P (ls))
- ++n;
- else
- {
- fprintf (stderr, "bad cell in %s at position %ld\n", title, (long) n);
- abort ();
- }
- if (n != last_size)
- {
- if (i > 0)
- {
- if (last_cluster == i - 1)
- fprintf (stderr, "\t%ld\n", (long) last_size);
- else
- fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size);
- }
- if (i >= 0)
- fprintf (stderr, "%s %ld", title, (long) i);
- else
- fprintf (stderr, "%s\t%ld\n", title, (long) n);
- last_cluster = i;
- last_size = n;
- }
- return n;
-}
-
-static void
-free_list_lengths (char *title, scm_t_freelist *master, SCM freelist)
-{
- SCM clusters;
- long i = 0, len, n = 0;
- fprintf (stderr, "%s\n\n", title);
- n += free_list_length ("free list", -1, freelist);
- for (clusters = master->clusters;
- SCM_NNULLP (clusters);
- clusters = SCM_CDR (clusters))
- {
- len = free_list_length ("cluster", i++, SCM_CAR (clusters));
- n += len;
- }
- if (last_cluster == i - 1)
- fprintf (stderr, "\t%ld\n", (long) last_size);
- else
- fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size);
- fprintf (stderr, "\ntotal %ld objects\n\n", (long) n);
-}
-SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0,
- (),
- "Print debugging information about the free-list.\n"
- "@code{free-list-length} is only included in\n"
- "@code{--enable-guile-debug} builds of Guile.")
-#define FUNC_NAME s_scm_free_list_length
-{
- free_list_lengths ("1-cells", &scm_master_freelist, scm_freelist);
- free_list_lengths ("2-cells", &scm_master_freelist2, scm_freelist2);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#endif /* defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) */
-#ifdef GUILE_DEBUG_FREELIST
-
-/* Non-zero if freelist debugging is in effect. Set this via
- `gc-set-debug-check-freelist!'. */
-static int scm_debug_check_freelist = 0;
/* Number of calls to SCM_NEWCELL since startup. */
-static unsigned long scm_newcell_count;
-static unsigned long scm_newcell2_count;
+unsigned scm_newcell_count;
+unsigned scm_newcell2_count;
-/* Search freelist for anything that isn't marked as a free cell.
- Abort if we find something. */
-static void
-scm_check_freelist (SCM freelist)
-{
- SCM f;
- long i = 0;
-
- for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++)
- if (!SCM_FREE_CELL_P (f))
- {
- fprintf (stderr, "Bad cell in freelist on newcell %lu: %lu'th elt\n",
- (long) scm_newcell_count, (long) i);
- abort ();
- }
-}
-
-SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
- (SCM flag),
- "If @var{flag} is @code{#t}, check the freelist for consistency\n"
- "on each cell allocation. This procedure only exists when the\n"
- "@code{GUILE_DEBUG_FREELIST} compile-time flag was selected.")
-#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
-{
- /* [cmm] I did a double-take when I read this code the first time.
- well, FWIW. */
- SCM_VALIDATE_BOOL_COPY (1, flag, scm_debug_check_freelist);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#endif /* GUILE_DEBUG_FREELIST */
-
-
-
-static unsigned long
-master_cells_allocated (scm_t_freelist *master)
-{
- /* the '- 1' below is to ignore the cluster spine cells. */
- long objects = master->clusters_allocated * (master->cluster_size - 1);
- if (SCM_NULLP (master->clusters))
- objects -= master->left_to_collect;
- return master->span * objects;
-}
-
-static unsigned long
-freelist_length (SCM freelist)
-{
- long n;
- for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist))
- ++n;
- return n;
-}
-
-static unsigned long
-compute_cells_allocated ()
-{
- return (scm_cells_allocated
- + master_cells_allocated (&scm_master_freelist)
- + master_cells_allocated (&scm_master_freelist2)
- - scm_master_freelist.span * freelist_length (scm_freelist)
- - scm_master_freelist2.span * freelist_length (scm_freelist2));
-}
/* {Scheme Interface to GC}
*/
@@ -732,12 +296,11 @@ compute_cells_allocated ()
SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
(),
"Return an association list of statistics about Guile's current\n"
- "use of storage.")
+ "use of storage.\n")
#define FUNC_NAME s_scm_gc_stats
{
- long i;
- long n;
- SCM heap_segs;
+ long i = 0;
+ SCM heap_segs = SCM_EOL ;
unsigned long int local_scm_mtrigger;
unsigned long int local_scm_mallocated;
unsigned long int local_scm_heap_size;
@@ -745,26 +308,26 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
unsigned long int local_scm_gc_time_taken;
unsigned long int local_scm_gc_times;
unsigned long int local_scm_gc_mark_time_taken;
- unsigned long int local_scm_gc_sweep_time_taken;
double local_scm_gc_cells_swept;
double local_scm_gc_cells_marked;
SCM answer;
-
+ unsigned long *bounds = 0;
+ int table_size = scm_i_heap_segment_table_size;
SCM_DEFER_INTS;
- ++scm_block_gc;
-
- retry:
- heap_segs = SCM_EOL;
- n = scm_n_heap_segs;
- for (i = scm_n_heap_segs; i--; )
- heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]),
- scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])),
- heap_segs);
- if (scm_n_heap_segs != n)
- goto retry;
+ /*
+ temporarily store the numbers, so as not to cause GC.
+ */
+
+ bounds = malloc (sizeof (int) * table_size * 2);
+ if (!bounds)
+ abort();
+ for (i = table_size; i--; )
+ {
+ bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0];
+ bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1];
+ }
- --scm_block_gc;
/* Below, we cons to produce the resulting list. We want a snapshot of
* the heap situation before consing.
@@ -772,14 +335,27 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated;
local_scm_heap_size = SCM_HEAP_SIZE;
- local_scm_cells_allocated = compute_cells_allocated ();
+
+ local_scm_cells_allocated = scm_cells_allocated;
+
local_scm_gc_time_taken = scm_gc_time_taken;
local_scm_gc_mark_time_taken = scm_gc_mark_time_taken;
- local_scm_gc_sweep_time_taken = scm_gc_sweep_time_taken;
local_scm_gc_times = scm_gc_times;
- local_scm_gc_cells_swept = scm_gc_cells_swept_acc;
- local_scm_gc_cells_marked = scm_gc_cells_marked_acc;
+
+ local_scm_gc_cells_swept = scm_gc_cells_swept_acc + scm_gc_cells_swept;
+ local_scm_gc_cells_marked = scm_gc_cells_marked_acc
+ +(double) scm_gc_cells_swept
+ -(double) scm_gc_cells_collected;
+
+
+ for (i = table_size; i--;)
+ {
+ heap_segs = scm_cons (scm_cons (scm_ulong2num (bounds[2*i]),
+ scm_ulong2num (bounds[2*i+1])),
+ heap_segs);
+ }
+
answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
@@ -787,42 +363,46 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)),
scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)),
- scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)),
scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)),
scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)),
scm_cons (sym_heap_segments, heap_segs),
SCM_UNDEFINED);
SCM_ALLOW_INTS;
+
+ free (bounds);
return answer;
}
#undef FUNC_NAME
-
static void
gc_start_stats (const char *what SCM_UNUSED)
{
t_before_gc = scm_c_get_internal_run_time ();
+
+ scm_gc_cells_marked_acc += (double) scm_gc_cells_swept
+ - (double) scm_gc_cells_collected;
+ scm_gc_cells_swept_acc += scm_gc_cells_swept;
+
scm_gc_cells_swept = 0;
+ scm_gc_cells_collected_1 = scm_gc_cells_collected;
+
+ /*
+ CELLS SWEPT is another word for the number of cells that were
+ examined during GC. YIELD is the number that we cleaned
+ out. MARKED is the number that weren't cleaned.
+ */
scm_gc_cells_collected = 0;
- scm_gc_yield_1 = scm_gc_yield;
- scm_gc_yield = (scm_cells_allocated
- + master_cells_allocated (&scm_master_freelist)
- + master_cells_allocated (&scm_master_freelist2));
scm_gc_malloc_collected = 0;
scm_gc_ports_collected = 0;
}
-
static void
gc_end_stats ()
{
unsigned long t = scm_c_get_internal_run_time ();
scm_gc_time_taken += (t - t_before_gc);
- scm_gc_sweep_time_taken += (t - t_before_sweep);
- ++scm_gc_times;
- scm_gc_cells_marked_acc += scm_gc_cells_swept - scm_gc_cells_collected;
- scm_gc_cells_swept_acc += scm_gc_cells_swept;
+ ++scm_gc_times;
}
@@ -852,119 +432,61 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
-/* {C Interface For When GC is Triggered}
- */
-
-static void
-adjust_min_yield (scm_t_freelist *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_yield_1, scm_gc_yield));
-#ifdef DEBUGINFO
- fprintf (stderr, " after GC = %lu, delta = %ld\n",
- (long) scm_cells_allocated,
- (long) delta);
-#endif
- if (delta > 0)
- freelist->min_yield += delta;
- }
-}
-
/* When we get POSIX threads support, the master will be global and
* common while the freelist will be individual for each thread.
*/
SCM
-scm_gc_for_newcell (scm_t_freelist *master, SCM *freelist)
+scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
{
SCM cell;
+
++scm_ints_disabled;
- do
+
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist))
{
- if (SCM_NULLP (master->clusters))
- {
- if (master->grow_heap_p || scm_block_gc)
- {
- /* In order to reduce gc frequency, try to allocate a new heap
- * segment first, even if gc might find some free cells. If we
- * can't obtain a new heap segment, we will try gc later.
- */
- master->grow_heap_p = 0;
- alloc_some_heap (master, return_on_error);
- }
- if (SCM_NULLP (master->clusters))
- {
- /* The heap was not grown, either because it wasn't scheduled to
- * grow, or because there was not enough memory available. In
- * both cases we have to try gc to get some free cells.
- */
-#ifdef DEBUGINFO
- fprintf (stderr, "allocated = %lu, ",
- (long) (scm_cells_allocated
- + master_cells_allocated (&scm_master_freelist)
- + master_cells_allocated (&scm_master_freelist2)));
-#endif
- scm_igc ("cells");
- adjust_min_yield (master);
- if (SCM_NULLP (master->clusters))
- {
- /* gc could not free any cells. Now, we _must_ allocate a
- * new heap segment, because there is no other possibility
- * to provide a new cell for the caller.
- */
- alloc_some_heap (master, abort_on_error);
- }
- }
- }
- cell = SCM_CAR (master->clusters);
- master->clusters = SCM_CDR (master->clusters);
- ++master->clusters_allocated;
+ freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
+ *free_cells = scm_i_sweep_some_segments (freelist);
}
- while (SCM_NULLP (cell));
-#ifdef GUILE_DEBUG_FREELIST
- scm_check_freelist (cell);
-#endif
+ if (*free_cells == SCM_EOL && !scm_block_gc)
+ {
+ /*
+ with the advent of lazy sweep, GC yield is only know just
+ before doing the GC.
+ */
+ scm_i_adjust_min_yield (freelist);
+
+ /*
+ out of fresh cells. Try to get some new ones.
+ */
- --scm_ints_disabled;
- *freelist = SCM_FREE_CELL_CDR (cell);
- return cell;
-}
+ scm_igc ("cells");
+
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ }
+
+ if (*free_cells == SCM_EOL)
+ {
+ /*
+ failed getting new cells. Get new juice or die.
+ */
+ freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ }
+
+ if (*free_cells == SCM_EOL)
+ abort ();
+ cell = *free_cells;
-#if 0
-/* This is a support routine which can be used to reserve a cluster
- * for some special use, such as debugging. It won't be useful until
- * free cells are preserved between garbage collections.
- */
+ --scm_ints_disabled;
-void
-scm_alloc_cluster (scm_t_freelist *master)
-{
- SCM freelist, cell;
- cell = scm_gc_for_newcell (master, &freelist);
- SCM_SETCDR (cell, freelist);
+ *free_cells = SCM_FREE_CELL_CDR (cell);
return cell;
}
-#endif
scm_t_c_hook scm_before_gc_c_hook;
@@ -973,34 +495,21 @@ scm_t_c_hook scm_before_sweep_c_hook;
scm_t_c_hook scm_after_sweep_c_hook;
scm_t_c_hook scm_after_gc_c_hook;
-#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
-
void
scm_igc (const char *what)
{
- long j;
-
++scm_gc_running_p;
scm_c_hook_run (&scm_before_gc_c_hook, 0);
+
#ifdef DEBUGINFO
+ fprintf (stderr,"gc reason %s\n", what);
+
fprintf (stderr,
- SCM_NULLP (scm_freelist)
+ SCM_NULLP (scm_i_freelist)
? "*"
- : (SCM_NULLP (scm_freelist2) ? "o" : "m"));
+ : (SCM_NULLP (scm_i_freelist2) ? "o" : "m"));
#endif
+
/* During the critical section, only the current thread may run. */
SCM_CRITICAL_SECTION_START;
@@ -1019,828 +528,12 @@ scm_igc (const char *what)
++scm_gc_heap_lock;
- scm_c_hook_run (&scm_before_mark_c_hook, 0);
-
- 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
+ /*
+ Let's finish the sweep. The conservative GC might point into the
+ garbage, and marking that would create a mess.
*/
- scm_mark_subr_table ();
-
-#ifndef USE_THREADS
- scm_gc_mark (scm_root->handle);
-#endif
-
- t_before_sweep = scm_c_get_internal_run_time ();
- scm_gc_mark_time_taken += (t_before_sweep - t_before_gc);
-
- scm_c_hook_run (&scm_before_sweep_c_hook, 0);
-
- scm_gc_sweep ();
-
- scm_c_hook_run (&scm_after_sweep_c_hook, 0);
-
- --scm_gc_heap_lock;
- gc_end_stats ();
-
- SCM_CRITICAL_SECTION_END;
- scm_c_hook_run (&scm_after_gc_c_hook, 0);
- --scm_gc_running_p;
-}
-
-
-
-/* {Mark/Sweep}
- */
-
-#define MARK scm_gc_mark
-#define FNAME "scm_gc_mark"
-
-#endif /*!MARK_DEPENDENCIES*/
-
-/* Mark an object precisely.
- */
-void
-MARK (SCM p)
-#define FUNC_NAME FNAME
-{
- register long i;
- register SCM ptr;
- scm_t_bits cell_type;
-
-#ifndef MARK_DEPENDENCIES
-# define RECURSE scm_gc_mark
-#else
- /* go through the usual marking, but not for self-cycles. */
-# define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0)
-#endif
- ptr = p;
-
-#ifdef MARK_DEPENDENCIES
- goto gc_mark_loop_first_time;
-#endif
-
-/* A simple hack for debugging. Chose the second branch to get a
- meaningful backtrace for crashes inside the GC.
-*/
-#if 1
-#define goto_gc_mark_loop goto gc_mark_loop
-#define goto_gc_mark_nimp goto gc_mark_nimp
-#else
-#define goto_gc_mark_loop RECURSE(ptr); return
-#define goto_gc_mark_nimp RECURSE(ptr); return
-#endif
-
-gc_mark_loop:
- if (SCM_IMP (ptr))
- return;
-
-gc_mark_nimp:
-
-#ifdef MARK_DEPENDENCIES
- if (SCM_EQ_P (ptr, p))
- return;
-
- scm_gc_mark (ptr);
- return;
-
-gc_mark_loop_first_time:
-#endif
-
-#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
- /* We are in debug mode. Check the ptr exhaustively. */
- if (!scm_cellp (ptr))
- SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
-#else
- /* In non-debug mode, do at least some cheap testing. */
- if (!CELL_P (ptr))
- SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
-#endif
-
-#ifndef MARK_DEPENDENCIES
-
- if (SCM_GCMARKP (ptr))
- return;
-
- SCM_SETGCMARK (ptr);
-
-#endif
-
- 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;
- }
- RECURSE (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:
- RECURSE (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)
- {
- RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
- RECURSE (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')
- RECURSE (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)
- RECURSE (SCM_PACK (*struct_data));
- else
- RECURSE (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;
- }
- RECURSE (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]))
- RECURSE (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))
- RECURSE (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_GCMARKP (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_SETGCMARK (alist);
- * SCM_SETGCMARK (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)
- RECURSE (SCM_CAR (kvpair));
- if (!weak_values)
- RECURSE (SCM_CDR (kvpair));
- alist = next_alist;
- }
- if (SCM_NIMP (alist))
- RECURSE (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) || (defined (GUILE_DEBUG_FREELIST))
- if (!(i < scm_numptob))
- SCM_MISC_ERROR ("undefined port type", SCM_EOL);
-#endif
- if (SCM_PTAB_ENTRY(ptr))
- RECURSE (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) || (defined (GUILE_DEBUG_FREELIST))
- 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);
- }
-#undef RECURSE
-}
-#undef FUNC_NAME
-
-#ifndef MARK_DEPENDENCIES
-
-#undef MARK
-#undef FNAME
-
-/* And here we define `scm_gc_mark_dependencies', by including this
- * same file in itself.
- */
-#define MARK scm_gc_mark_dependencies
-#define FNAME "scm_gc_mark_dependencies"
-#define MARK_DEPENDENCIES
-#include "gc.c"
-#undef MARK_DEPENDENCIES
-#undef MARK
-#undef FNAME
-
-
-/* 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 in order to
- * determine the heap segment that contains the cell.*/
-/* FIXME: To be used within scm_mark_locations and scm_cellp this function
- * should be an inline function. */
-static long int
-heap_segment (SCM obj)
-{
- if (!CELL_P (obj))
- return -1;
- else
- {
- SCM_CELLPTR ptr = SCM2PTR (obj);
- unsigned long int i = 0;
- unsigned long int j = scm_n_heap_segs - 1;
-
- if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
- return -1;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
- return -1;
- else
- {
- while (i < j)
- {
- if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[1]))
- {
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- {
- i = j;
- break;
- }
- else
- {
- unsigned long int k = (i + j) / 2;
-
- if (k == i)
- return -1;
- else if (SCM_PTR_LT (ptr, scm_heap_table[k].bounds[1]))
- {
- j = k;
- ++i;
- if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
- return -1;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
- return -1;
- }
- }
- }
-
- if (!DOUBLECELL_ALIGNED_P (obj) && scm_heap_table[i].span == 2)
- return -1;
- else if (SCM_GC_IN_CARD_HEADERP (ptr))
- return -1;
- else
- return i;
- }
- }
-}
-
-
-/* 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 = heap_segment (obj);
- if (segment >= 0)
- scm_gc_mark (obj);
- }
-}
-
-
-/* The function scm_cellp determines whether an SCM value can be regarded as a
- * pointer to a cell on the heap.
- */
-int
-scm_cellp (SCM value)
-{
- long int segment = heap_segment (value);
- return (segment >= 0);
-}
-
-
-static void
-gc_sweep_freelist_start (scm_t_freelist *freelist)
-{
- freelist->cells = SCM_EOL;
- freelist->left_to_collect = freelist->cluster_size;
- freelist->clusters_allocated = 0;
- freelist->clusters = SCM_EOL;
- freelist->clustertail = &freelist->clusters;
- freelist->collected_1 = freelist->collected;
- freelist->collected = 0;
-}
-
-static void
-gc_sweep_freelist_finish (scm_t_freelist *freelist)
-{
- long collected;
- *freelist->clustertail = freelist->cells;
- if (!SCM_NULLP (freelist->cells))
- {
- SCM c = freelist->cells;
- SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c));
- SCM_SET_CELL_WORD_1 (c, SCM_EOL);
- freelist->collected +=
- freelist->span * (freelist->cluster_size - freelist->left_to_collect);
- }
- scm_gc_cells_collected += freelist->collected;
-
- /* Although freelist->min_yield is used to test freelist->collected
- * (which is the local GC yield for freelist), it is adjusted so
- * that *total* yield is freelist->min_yield_fraction of total heap
- * size. This means that a too low yield is compensated by more
- * heap on the list which is currently doing most work, which is
- * just what we want.
- */
- collected = SCM_MAX (freelist->collected_1, freelist->collected);
- freelist->grow_heap_p = (collected < freelist->min_yield);
-}
-
-#define NEXT_DATA_CELL(ptr, span) \
- do { \
- scm_t_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \
- (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \
- CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \
- : nxt__); \
- } while (0)
-
-void
-scm_gc_sweep ()
-#define FUNC_NAME "scm_gc_sweep"
-{
- register SCM_CELLPTR ptr;
- register SCM nfreelist;
- register scm_t_freelist *freelist;
- register unsigned long m;
- register int span;
- size_t i;
- size_t seg_size;
-
- m = 0;
-
- gc_sweep_freelist_start (&scm_master_freelist);
- gc_sweep_freelist_start (&scm_master_freelist2);
-
- for (i = 0; i < scm_n_heap_segs; i++)
- {
- register long left_to_collect;
- register size_t j;
-
- /* Unmarked cells go onto the front of the freelist this heap
- segment points to. Rather than updating the real freelist
- pointer as we go along, we accumulate the new head in
- nfreelist. Then, if it turns out that the entire segment is
- free, we free (i.e., malloc's free) the whole segment, and
- simply don't assign nfreelist back into the real freelist. */
- freelist = scm_heap_table[i].freelist;
- nfreelist = freelist->cells;
- left_to_collect = freelist->left_to_collect;
- span = scm_heap_table[i].span;
-
- ptr = CELL_UP (scm_heap_table[i].bounds[0], span);
- seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr;
-
- /* use only data cells in seg_size */
- seg_size = (seg_size / SCM_GC_CARD_N_CELLS) * (SCM_GC_CARD_N_DATA_CELLS / span) * span;
-
- scm_gc_cells_swept += seg_size;
-
- for (j = seg_size + span; j -= span; ptr += span)
- {
- SCM scmptr;
-
- if (SCM_GC_IN_CARD_HEADERP (ptr))
- {
- SCM_CELLPTR nxt;
-
- /* cheat here */
- nxt = ptr;
- NEXT_DATA_CELL (nxt, span);
- j += span;
-
- ptr = nxt - span;
- continue;
- }
-
- scmptr = PTR2SCM (ptr);
-
- if (SCM_GCMARKP (scmptr))
- continue;
-
- switch SCM_TYP7 (scmptr)
- {
- case scm_tcs_struct:
- {
- /* Structs need to be freed in a special order.
- * This is handled by GC C hooks in struct.c.
- */
- SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free);
- scm_structs_to_free = scmptr;
- }
- continue;
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- case scm_tcs_closures:
- case scm_tc7_pws:
- break;
- case scm_tc7_wvect:
- case scm_tc7_vector:
- {
- unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
- if (length > 0)
- {
- scm_gc_free (SCM_VECTOR_BASE (scmptr),
- length * sizeof (scm_t_bits),
- "vector");
- }
- break;
- }
-#ifdef CCLO
- case scm_tc7_cclo:
- scm_gc_free (SCM_CCLO_BASE (scmptr),
- SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
- "compiled closure");
- break;
-#endif
-#ifdef HAVE_ARRAYS
- case scm_tc7_bvect:
- {
- unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
- if (length > 0)
- {
- scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
- (sizeof (long)
- * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
- "vector");
- }
- }
- break;
- case scm_tc7_byvect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- scm_gc_free (SCM_UVECTOR_BASE (scmptr),
- (SCM_UVECTOR_LENGTH (scmptr)
- * scm_uniform_element_size (scmptr)),
- "vector");
- break;
-#endif
- case scm_tc7_string:
- scm_gc_free (SCM_STRING_CHARS (scmptr),
- SCM_STRING_LENGTH (scmptr) + 1, "string");
- break;
- case scm_tc7_symbol:
- scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
- SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
- break;
- case scm_tc7_variable:
- break;
- case scm_tcs_subrs:
- /* the various "subrs" (primitives) are never freed */
- continue;
- case scm_tc7_port:
- if SCM_OPENP (scmptr)
- {
- int k = SCM_PTOBNUM (scmptr);
- size_t mm;
-#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
- if (!(k < scm_numptob))
- SCM_MISC_ERROR ("undefined port type", SCM_EOL);
-#endif
- /* Keep "revealed" ports alive. */
- if (scm_revealed_count (scmptr) > 0)
- continue;
- /* Yes, I really do mean scm_ptobs[k].free */
- /* rather than ftobs[k].close. .close */
- /* is for explicit CLOSE-PORT by user */
- mm = scm_ptobs[k].free (scmptr);
-
- if (mm != 0)
- {
-#if SCM_ENABLE_DEPRECATED == 1
- scm_c_issue_deprecation_warning
- ("Returning non-0 from a port free function is "
- "deprecated. Use scm_gc_free et al instead.");
- scm_c_issue_deprecation_warning_fmt
- ("(You just returned non-0 while freeing a %s.)",
- SCM_PTOBNAME (k));
- m += mm;
-#else
- abort ();
-#endif
- }
-
- SCM_SETSTREAM (scmptr, 0);
- scm_remove_from_port_table (scmptr);
- scm_gc_ports_collected++;
- SCM_CLR_PORT_OPEN_FLAG (scmptr);
- }
- break;
- case scm_tc7_smob:
- switch SCM_TYP16 (scmptr)
- {
- case scm_tc_free_cell:
- case scm_tc16_real:
- break;
-#ifdef SCM_BIGDIG
- case scm_tc16_big:
- scm_gc_free (SCM_BDIGITS (scmptr),
- ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
- / SCM_CHAR_BIT)), "bignum");
- break;
-#endif /* def SCM_BIGDIG */
- case scm_tc16_complex:
- scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
- "complex");
- break;
- default:
- {
- int k;
- k = SCM_SMOBNUM (scmptr);
-#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
- if (!(k < scm_numsmob))
- SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
-#endif
- if (scm_smobs[k].free)
- {
- size_t mm;
- mm = scm_smobs[k].free (scmptr);
- if (mm != 0)
- {
-#if SCM_ENABLE_DEPRECATED == 1
- scm_c_issue_deprecation_warning
- ("Returning non-0 from a smob free function is "
- "deprecated. Use scm_gc_free et al instead.");
- scm_c_issue_deprecation_warning_fmt
- ("(You just returned non-0 while freeing a %s.)",
- SCM_SMOBNAME (k));
- m += mm;
-#else
- abort();
-#endif
- }
- }
- break;
- }
- }
- break;
- default:
- SCM_MISC_ERROR ("unknown type", SCM_EOL);
- }
-
- if (!--left_to_collect)
- {
- SCM_SET_CELL_WORD_0 (scmptr, nfreelist);
- *freelist->clustertail = scmptr;
- freelist->clustertail = SCM_CDRLOC (scmptr);
-
- nfreelist = SCM_EOL;
- freelist->collected += span * freelist->cluster_size;
- left_to_collect = freelist->cluster_size;
- }
- else
- {
- /* Stick the new cell on the front of nfreelist. It's
- critical that we mark this cell as freed; otherwise, the
- conservative collector might trace it as some other type
- of object. */
- SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
- SCM_SET_FREE_CELL_CDR (scmptr, nfreelist);
- nfreelist = scmptr;
- }
- }
-
-#ifdef GC_FREE_SEGMENTS
- if (n == seg_size)
- {
- register long j;
-
- freelist->heap_size -= seg_size;
- free ((char *) scm_heap_table[i].bounds[0]);
- scm_heap_table[i].bounds[0] = 0;
- for (j = i + 1; j < scm_n_heap_segs; j++)
- scm_heap_table[j - 1] = scm_heap_table[j];
- scm_n_heap_segs -= 1;
- i--; /* We need to scan the segment just moved. */
- }
- else
-#endif /* ifdef GC_FREE_SEGMENTS */
- {
- /* Update the real freelist pointer to point to the head of
- the list of free cells we've built for this segment. */
- freelist->cells = nfreelist;
- freelist->left_to_collect = left_to_collect;
- }
-
-#ifdef GUILE_DEBUG_FREELIST
- scm_map_free_list ();
-#endif
- }
-
- gc_sweep_freelist_finish (&scm_master_freelist);
- gc_sweep_freelist_finish (&scm_master_freelist2);
-
- /* When we move to POSIX threads private freelists should probably
- be GC-protected instead. */
- scm_freelist = SCM_EOL;
- scm_freelist2 = SCM_EOL;
-
- scm_cells_allocated = (SCM_HEAP_SIZE - scm_gc_cells_collected);
- scm_gc_yield -= scm_cells_allocated;
-
- if (scm_mallocated < m)
+ scm_i_sweep_all_segments("GC");
+ if (scm_mallocated < scm_i_deprecated_memory_return)
{
/* The byte count of allocated objects has underflowed. This is
probably because you forgot to report the sizes of objects you
@@ -1853,535 +546,43 @@ scm_gc_sweep ()
"about object sizes\n");
abort ();
}
+ scm_mallocated -= scm_i_deprecated_memory_return;
- scm_mallocated -= m;
- scm_gc_malloc_collected = m;
-}
-#undef FUNC_NAME
-
-
-
-/* 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_igc ("malloc");
- 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_igc ("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;
-
- if (scm_mallocated > scm_mtrigger)
- {
- scm_igc (what);
- if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS)
- {
- if (scm_mallocated > scm_mtrigger)
- scm_mtrigger = scm_mallocated + scm_mallocated / 2;
- else
- scm_mtrigger += scm_mtrigger / 2;
- }
- }
-
-#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;
-
-#ifdef GUILE_DEBUG_MALLOC
- if (mem)
- scm_malloc_unregister (mem);
-#endif
-}
-
-void *
-scm_gc_malloc (size_t size, const char *what)
-{
- /* XXX - 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.
- */
-
- 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 */
-
-
-/* {Heap Segments}
- *
- * Each heap segment is an array of objects of a particular size.
- * Every segment has an associated (possibly shared) freelist.
- * 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). */
-
-/* scm_expmem
- * is true if the first segment was smaller than INIT_HEAP_SEG.
- * If scm_expmem is set to one, subsequent segment allocations will
- * allocate segments of size SCM_EXPHEAP(scm_heap_size).
- */
-int scm_expmem = 0;
-
-size_t scm_max_segment_size;
-
-/* scm_heap_org
- * is the lowest base address of any heap segment.
- */
-SCM_CELLPTR scm_heap_org;
-
-scm_t_heap_seg_data * scm_heap_table = 0;
-static size_t heap_segment_table_size = 0;
-size_t scm_n_heap_segs = 0;
-
-/* init_heap_seg
- * initializes a new heap segment and returns the number of objects it contains.
- *
- * The segment origin and segment size in bytes are input parameters.
- * The freelist is both input and output.
- *
- * This function presumes that the scm_heap_table has already been expanded
- * to accomodate a new segment record and that the markbit space was reserved
- * for all the cards in this segment.
- */
-
-#define INIT_CARD(card, span) \
- do { \
- SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \
- if ((span) == 2) \
- SCM_GC_SET_CARD_DOUBLECELL (card); \
- } while (0)
-
-static size_t
-init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist)
-{
- register SCM_CELLPTR ptr;
- SCM_CELLPTR seg_end;
- size_t new_seg_index;
- ptrdiff_t n_new_cells;
- int span = freelist->span;
+
+
+ scm_c_hook_run (&scm_before_mark_c_hook, 0);
- if (seg_org == NULL)
- return 0;
+ scm_mark_all ();
+
+ t_before_sweep = scm_c_get_internal_run_time ();
+ scm_gc_mark_time_taken += (t_before_sweep - t_before_gc);
- /* Align the begin ptr up.
- */
- ptr = SCM_GC_CARD_UP (seg_org);
+ scm_c_hook_run (&scm_before_sweep_c_hook, 0);
- /* Compute the ceiling on valid object pointers w/in this segment.
- */
- seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size);
+ /*
+ Moved this lock upwards so that we can alloc new heap at the end of a sweep.
- /* Find the right place and insert the segment record.
+ DOCME: why should the heap be locked anyway?
*/
- new_seg_index = 0;
- while (new_seg_index < scm_n_heap_segs
- && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org))
- new_seg_index++;
-
- {
- int i;
- for (i = scm_n_heap_segs; i > new_seg_index; --i)
- scm_heap_table[i] = scm_heap_table[i - 1];
- }
-
- ++scm_n_heap_segs;
-
- scm_heap_table[new_seg_index].span = span;
- scm_heap_table[new_seg_index].freelist = freelist;
- scm_heap_table[new_seg_index].bounds[0] = ptr;
- scm_heap_table[new_seg_index].bounds[1] = seg_end;
-
- /*n_new_cells*/
- n_new_cells = seg_end - ptr;
-
- freelist->heap_size += n_new_cells;
-
- /* Partition objects in this segment into clusters */
- {
- SCM clusters;
- SCM *clusterp = &clusters;
-
- NEXT_DATA_CELL (ptr, span);
- while (ptr < seg_end)
- {
- scm_t_cell *nxt = ptr;
- scm_t_cell *prv = NULL;
- scm_t_cell *last_card = NULL;
- int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1;
- NEXT_DATA_CELL(nxt, span);
-
- /* Allocate cluster spine
- */
- *clusterp = PTR2SCM (ptr);
- SCM_SETCAR (*clusterp, PTR2SCM (nxt));
- clusterp = SCM_CDRLOC (*clusterp);
- ptr = nxt;
-
- while (n_data_cells--)
- {
- scm_t_cell *card = SCM_GC_CELL_CARD (ptr);
- SCM scmptr = PTR2SCM (ptr);
- nxt = ptr;
- NEXT_DATA_CELL (nxt, span);
- prv = ptr;
-
- if (card != last_card)
- {
- INIT_CARD (card, span);
- last_card = card;
- }
-
- SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
- SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt));
-
- ptr = nxt;
- }
-
- SCM_SET_FREE_CELL_CDR (PTR2SCM (prv), SCM_EOL);
- }
-
- /* sanity check */
- {
- scm_t_cell *ref = seg_end;
- NEXT_DATA_CELL (ref, span);
- if (ref != ptr)
- /* [cmm] looks like the segment size doesn't divide cleanly by
- cluster size. bad cmm! */
- abort();
- }
-
- /* Patch up the last cluster pointer in the segment
- * to join it to the input freelist.
- */
- *clusterp = freelist->clusters;
- freelist->clusters = clusters;
- }
+ --scm_gc_heap_lock;
-#ifdef DEBUGINFO
- fprintf (stderr, "H");
-#endif
- return size;
-}
+ scm_gc_sweep ();
-static size_t
-round_to_cluster_size (scm_t_freelist *freelist, size_t len)
-{
- size_t cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist);
+ scm_c_hook_run (&scm_after_sweep_c_hook, 0);
+ gc_end_stats ();
- return
- (len + cluster_size_in_bytes - 1) / cluster_size_in_bytes * cluster_size_in_bytes
- + ALIGNMENT_SLACK (freelist);
+ SCM_CRITICAL_SECTION_END;
+ scm_c_hook_run (&scm_after_gc_c_hook, 0);
+ --scm_gc_running_p;
}
-static void
-alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy)
-#define FUNC_NAME "alloc_some_heap"
-{
- SCM_CELLPTR ptr;
- 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, "alloc_some_heap: Can not extend locked heap.\n");
- abort ();
- }
-
- if (scm_n_heap_segs == heap_segment_table_size)
- {
- /* We have to expand the heap segment table to have room for the new
- * segment. Do not yet increment scm_n_heap_segs -- that is done by
- * init_heap_seg only if the allocation of the segment itself succeeds.
- */
- size_t new_table_size = scm_n_heap_segs + 1;
- size_t size = new_table_size * sizeof (scm_t_heap_seg_data);
- scm_t_heap_seg_data *new_heap_table;
-
- SCM_SYSCALL (new_heap_table = ((scm_t_heap_seg_data *)
- realloc ((char *)scm_heap_table, size)));
- if (!new_heap_table)
- {
- if (error_policy == abort_on_error)
- {
- fprintf (stderr, "alloc_some_heap: Could not grow heap segment table.\n");
- abort ();
- }
- else
- {
- return;
- }
- }
- else
- {
- scm_heap_table = new_heap_table;
- heap_segment_table_size = new_table_size;
- }
- }
-
- /* 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)
- */
- int f = freelist->min_yield_fraction;
- unsigned long h = SCM_HEAP_SIZE;
- size_t min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f);
- len = SCM_EXPHEAP (freelist->heap_size);
-#ifdef DEBUGINFO
- fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
-#endif
- if (len < min_cells)
- len = min_cells + freelist->cluster_size;
- 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;
- smallest = CLUSTER_SIZE_IN_BYTES (freelist);
- if (len < smallest)
- len = smallest;
- /* Allocate with decaying ambition. */
- while ((len >= SCM_MIN_HEAP_SEG_SIZE)
- && (len >= smallest))
- {
- size_t rounded_len = round_to_cluster_size (freelist, len);
- SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (rounded_len));
- if (ptr)
- {
- init_heap_seg (ptr, rounded_len, freelist);
- return;
- }
- len /= 2;
- }
- }
- if (error_policy == abort_on_error)
- {
- fprintf (stderr, "alloc_some_heap: Could not grow heap.\n");
- abort ();
- }
-}
-#undef FUNC_NAME
+
/* {GC Protection Helper Functions}
@@ -2607,58 +808,19 @@ cleanup (int status, void *arg)
}
-static int
-make_initial_segment (size_t init_heap_size, scm_t_freelist *freelist)
-{
- size_t rounded_size = round_to_cluster_size (freelist, init_heap_size);
- if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
- rounded_size,
- freelist))
- {
- rounded_size = round_to_cluster_size (freelist, SCM_HEAP_SEG_SIZE);
- if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
- rounded_size,
- freelist))
- return 1;
- }
- else
- scm_expmem = 1;
-
- if (freelist->min_yield_fraction)
- freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
- / 100);
- freelist->grow_heap_p = (freelist->heap_size < freelist->min_yield);
-
- return 0;
-}
-
-
-static void
-init_freelist (scm_t_freelist *freelist,
- int span,
- long cluster_size,
- int min_yield)
-{
- freelist->clusters = SCM_EOL;
- freelist->cluster_size = cluster_size + 1;
- freelist->left_to_collect = 0;
- freelist->clusters_allocated = 0;
- freelist->min_yield = 0;
- freelist->min_yield_fraction = min_yield;
- freelist->span = span;
- freelist->collected = 0;
- freelist->collected_1 = 0;
- freelist->heap_size = 0;
-}
+/*
+ MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
+ */
/* Get an integer from an environment variable. */
-static int
-scm_i_getenv_int (const char *var, int def)
+int
+scm_getenv_int (const char *var, int def)
{
- char *end, *val = getenv (var);
- long res;
+ char *end = 0;
+ char *val = getenv (var);
+ long res = def;
if (!val)
return def;
res = strtol (val, &end, 10);
@@ -2671,10 +833,6 @@ scm_i_getenv_int (const char *var, int def)
int
scm_init_storage ()
{
- unsigned long gc_trigger_1;
- unsigned long gc_trigger_2;
- size_t init_heap_size_1;
- size_t init_heap_size_2;
size_t j;
j = SCM_NUM_PROTECTS;
@@ -2682,32 +840,12 @@ scm_init_storage ()
scm_sys_protects[--j] = SCM_BOOL_F;
scm_block_gc = 1;
- scm_freelist = SCM_EOL;
- scm_freelist2 = SCM_EOL;
- gc_trigger_1 = scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1);
- init_freelist (&scm_master_freelist, 1, SCM_CLUSTER_SIZE_1, gc_trigger_1);
- gc_trigger_2 = scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2);
- init_freelist (&scm_master_freelist2, 2, SCM_CLUSTER_SIZE_2, gc_trigger_2);
- scm_max_segment_size = scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size);
-
- scm_expmem = 0;
+ scm_gc_init_freelist();
+ scm_gc_init_malloc ();
j = SCM_HEAP_SEG_SIZE;
- scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
- scm_heap_table = ((scm_t_heap_seg_data *)
- scm_malloc (sizeof (scm_t_heap_seg_data) * 2));
- heap_segment_table_size = 2;
-
- mark_space_ptr = &mark_space_head;
-
- init_heap_size_1 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1);
- init_heap_size_2 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2);
- if (make_initial_segment (init_heap_size_1, &scm_master_freelist) ||
- make_initial_segment (init_heap_size_2, &scm_master_freelist2))
- return 1;
- /* scm_hplims[0] can change. do not remove scm_heap_org */
- scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0], 1);
+
scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
@@ -2799,63 +937,13 @@ mark_gc_async (void * hook_data SCM_UNUSED,
return NULL;
}
-#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 = heap_segment (cell);
- unsigned int span = scm_heap_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 = heap_segment (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_init_gc ()
{
SCM after_gc_thunk;
-#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
+
+ scm_gc_init_mark ();
scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
scm_c_define ("after-gc-hook", scm_after_gc_hook);
@@ -2869,7 +957,30 @@ scm_init_gc ()
#include "libguile/gc.x"
}
-#endif /*MARK_DEPENDENCIES*/
+
+void
+scm_gc_sweep (void)
+#define FUNC_NAME "scm_gc_sweep"
+{
+ scm_i_deprecated_memory_return = 0;
+
+ scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist);
+ scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2);
+
+ /*
+ NOTHING HERE: LAZY SWEEPING !
+ */
+ scm_i_reset_segments ();
+
+ /* When we move to POSIX threads private freelists should probably
+ be GC-protected instead. */
+ scm_i_freelist = SCM_EOL;
+ scm_i_freelist2 = SCM_EOL;
+}
+
+#undef FUNC_NAME
+
+
/*
Local Variables:
diff --git a/libguile/gc.h b/libguile/gc.h
index 0296ea0e0..bd86ad1f0 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -58,11 +58,17 @@ typedef struct scm_t_cell
scm_t_bits word_1;
} scm_t_cell;
+/*
+ CARDS
+
+ A card is a small `page' of memory; it will be the unit for lazy
+ sweeping, generations, etc. The first cell of a card contains a
+ pointer to the mark bitvector, so that we can find the bitvector efficiently: we
+ knock off some lowerorder bits.
+
+ The size on a 32 bit machine is 256 cells = 2kb. The card
+*/
-/* SCM_CELLPTR is a pointer to a cons cell which may be compared or
- * differenced.
- */
-typedef scm_t_cell * SCM_CELLPTR;
/* Cray machines have pointers that are incremented once for each word,
@@ -73,39 +79,32 @@ typedef scm_t_cell * SCM_CELLPTR;
* pointers to scm_vector elts, functions, &c are not munged.
*/
#ifdef _UNICOS
-# define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x) >> 3))
+# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
#else
-# define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x)))
+# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
#endif /* def _UNICOS */
+
#define SCM_GC_CARD_N_HEADER_CELLS 1
#define SCM_GC_CARD_N_CELLS 256
+#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
-#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_limb *) ((card)->word_0))
+#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
#define SCM_GC_SET_CARD_BVEC(card, bvec) \
((card)->word_0 = (scm_t_bits) (bvec))
-#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell))
-#define SCM_GC_CARD_N_DATA_CELLS (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
-
-#define SCM_GC_CARD_BVEC_SIZE_IN_LIMBS \
- ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LIMB_BITS - 1) / SCM_C_BVEC_LIMB_BITS)
-
-#define SCM_GC_IN_CARD_HEADERP(x) \
- SCM_PTR_LT ((scm_t_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS)
-
#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
#define SCM_GC_SET_CARD_FLAGS(card, flags) \
((card)->word_1 = (scm_t_bits) (flags))
-#define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L))
+#define SCM_GC_CLEAR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L))
#define SCM_GC_GET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
#define SCM_GC_SET_CARD_FLAG(card, shift) \
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
-#define SCM_GC_CLR_CARD_FLAG(card, shift) \
+#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
#define SCM_GC_CARDF_DOUBLECELL 0
@@ -116,31 +115,31 @@ typedef scm_t_cell * SCM_CELLPTR;
/* card addressing. for efficiency, cards are *always* aligned to
SCM_GC_CARD_SIZE. */
-#define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_SIZE - 1)
+#define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell) - 1)
#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
-#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
-#define SCM_GC_CELL_SPAN(x) ((SCM_GC_CARD_DOUBLECELLP (SCM_GC_CELL_CARD (x))) ? 2 : 1)
+#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CELL_CLR_BIT(x) SCM_C_BVEC_CLR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
+#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_CARD_SIZE - 1)
+#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
/* low level bit banging aids */
-
-typedef unsigned long scm_t_c_bvec_limb;
+typedef unsigned long scm_t_c_bvec_long;
#if (SIZEOF_LONG == 8)
-# define SCM_C_BVEC_LIMB_BITS 64
+# define SCM_C_BVEC_LONG_BITS 64
# define SCM_C_BVEC_OFFSET_SHIFT 6
# define SCM_C_BVEC_POS_MASK 63
# define SCM_CELL_SIZE_SHIFT 4
+# define SCM_SIZEOF_LONG SIZEOF_LONG
#else
-# define SCM_C_BVEC_LIMB_BITS 32
+# define SCM_C_BVEC_LONG_BITS 32
+# define SCM_SIZEOF_LONG SIZEOF_LONG
# define SCM_C_BVEC_OFFSET_SHIFT 5
# define SCM_C_BVEC_POS_MASK 31
# define SCM_CELL_SIZE_SHIFT 3
@@ -150,23 +149,12 @@ typedef unsigned long scm_t_c_bvec_limb;
#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
-#define SCM_C_BVEC_CLR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
-
-#define SCM_C_BVEC_BITS2BYTES(bits) \
- (sizeof (scm_t_c_bvec_limb) * ((((bits) & SCM_C_BVEC_POS_MASK) ? 1L : 0L) + SCM_C_BVEC_OFFSET (bits)))
-
-#define SCM_C_BVEC_SET_BYTES(bvec, bytes) (memset (bvec, 0xff, bytes))
-#define SCM_C_BVEC_SET_ALL_BITS(bvec, bits) SCM_C_BVEC_SET_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits))
-
-#define SCM_C_BVEC_CLR_BYTES(bvec, bytes) (memset (bvec, 0, bytes))
-#define SCM_C_BVEC_CLR_ALL_BITS(bvec, bits) SCM_C_BVEC_CLR_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits))
+#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
/* testing and changing GC marks */
-
-#define SCM_GCMARKP(x) SCM_GC_CELL_GET_BIT (x)
-#define SCM_SETGCMARK(x) SCM_GC_CELL_SET_BIT (x)
-#define SCM_CLRGCMARK(x) SCM_GC_CELL_CLR_BIT (x)
-
+#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
+#define SCM_SET_GC_MARK(x) SCM_GC_CELL_SET_BIT (x)
+#define SCM_CLEAR_GC_MARK(x) SCM_GC_CELL_CLEAR_BIT (x)
/* Low level cell data accessing macros. These macros should only be used
* from within code related to garbage collection issues, since they will
@@ -181,7 +169,7 @@ typedef unsigned long scm_t_c_bvec_limb;
#define SCM_GC_SET_CELL_WORD(x, n, v) \
(((scm_t_bits *) SCM2PTR (x)) [n] = (scm_t_bits) (v))
#define SCM_GC_SET_CELL_OBJECT(x, n, v) \
- (((scm_t_bits *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
+ (((scm_t_bits *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
#define SCM_GC_CELL_TYPE(x) SCM_GC_CELL_WORD (x, 0)
@@ -235,8 +223,14 @@ typedef unsigned long scm_t_c_bvec_limb;
* the freelist. Due to this structure, freelist cells are not cons cells
* and thus may not be accessed using SCM_CAR and SCM_CDR. */
-#define SCM_FREE_CELL_P(x) \
- (!SCM_IMP (x) && (SCM_GC_CELL_TYPE (x) == scm_tc_free_cell))
+/*
+ SCM_FREECELL_P removed ; the semantics are ambiguous with lazy
+ sweeping. Could mean "this cell is no longer in use (will be swept)"
+ or "this cell has just been swept, and is not yet in use".
+ */
+
+#define SCM_FREECELL_P this_macro_has_been_removed_see_gc_header_file
+
#define SCM_FREE_CELL_CDR(x) \
(SCM_GC_CELL_OBJECT ((x), 1))
#define SCM_SET_FREE_CELL_CDR(x, v) \
@@ -248,49 +242,54 @@ typedef unsigned long scm_t_c_bvec_limb;
#define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1))
-/* SCM_PTR_LT and friends define how to compare two SCM_CELLPTRs (which may
- * point to cells in different heap segments).
- */
-#define SCM_PTR_LT(x, y) ((x) < (y))
-#define SCM_PTR_GT(x, y) (SCM_PTR_LT (y, x))
-#define SCM_PTR_LE(x, y) (!SCM_PTR_GT (x, y))
-#define SCM_PTR_GE(x, y) (!SCM_PTR_LT (x, y))
-#define SCM_MARKEDP SCM_GCMARKP
-#define SCM_NMARKEDP(x) (!SCM_MARKEDP (x))
-
#if (SCM_DEBUG_CELL_ACCESSES == 1)
SCM_API unsigned int scm_debug_cell_accesses_p;
#endif
-SCM_API struct scm_t_heap_seg_data *scm_heap_table;
-SCM_API size_t scm_n_heap_segs;
SCM_API int scm_block_gc;
SCM_API int scm_gc_heap_lock;
SCM_API unsigned int scm_gc_running_p;
+#if (SCM_ENABLE_DEPRECATED == 1)
SCM_API size_t scm_default_init_heap_size_1;
SCM_API int scm_default_min_yield_1;
SCM_API size_t scm_default_init_heap_size_2;
SCM_API int scm_default_min_yield_2;
SCM_API size_t scm_default_max_segment_size;
+#else
+#define scm_default_init_heap_size_1 deprecated
+#define scm_default_min_yield_1 deprecated
+#define scm_default_init_heap_size_2 deprecated
+#define scm_default_min_yield_2 deprecated
+#define scm_default_max_segment_size deprecated
+#endif
+
SCM_API size_t scm_max_segment_size;
-SCM_API SCM_CELLPTR scm_heap_org;
-SCM_API SCM scm_freelist;
-SCM_API struct scm_t_freelist scm_master_freelist;
-SCM_API SCM scm_freelist2;
-SCM_API struct scm_t_freelist scm_master_freelist2;
+
+/*
+ Deprecated scm_freelist, scm_master_freelist.
+ No warning; this is not a user serviceable part.
+ */
+SCM_API SCM scm_i_freelist;
+SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
+SCM_API SCM scm_i_freelist2;
+SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
+
+SCM_API unsigned long scm_gc_cells_swept;
+SCM_API unsigned long scm_gc_cells_collected;
SCM_API unsigned long scm_gc_cells_collected;
-SCM_API unsigned long scm_gc_yield;
SCM_API unsigned long scm_gc_malloc_collected;
SCM_API unsigned long scm_gc_ports_collected;
SCM_API unsigned long scm_cells_allocated;
SCM_API unsigned long scm_mallocated;
SCM_API unsigned long scm_mtrigger;
+
+
SCM_API SCM scm_after_gc_hook;
SCM_API scm_t_c_hook scm_before_gc_c_hook;
@@ -300,32 +299,32 @@ SCM_API scm_t_c_hook scm_after_sweep_c_hook;
SCM_API scm_t_c_hook scm_after_gc_c_hook;
#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-SCM_API SCM scm_map_free_list (void);
-SCM_API SCM scm_free_list_length (void);
+#define scm_map_free_list deprecated
+#define scm_free_list_length deprecated
#endif
-#ifdef GUILE_DEBUG_FREELIST
+
+#if (SCM_ENABLE_DEPRECATED == 1) && defined (GUILE_DEBUG_FREELIST)
SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
#endif
-
#if (SCM_DEBUG_CELL_ACCESSES == 1)
SCM_API void scm_assert_cell_valid (SCM);
-SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);
#endif
+
+SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);
+
+
SCM_API SCM scm_object_address (SCM obj);
SCM_API SCM scm_gc_stats (void);
SCM_API SCM scm_gc (void);
-SCM_API void scm_gc_for_alloc (struct scm_t_freelist *freelist);
-SCM_API SCM scm_gc_for_newcell (struct scm_t_freelist *master, SCM *freelist);
-#if 0
-SCM_API void scm_alloc_cluster (struct scm_t_freelist *master);
-#endif
+SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist);
+SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist);
SCM_API void scm_igc (const char *what);
SCM_API void scm_gc_mark (SCM p);
SCM_API void scm_gc_mark_dependencies (SCM p);
SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n);
-SCM_API int scm_cellp (SCM value);
+SCM_API int scm_in_heap_p (SCM value);
SCM_API void scm_gc_sweep (void);
SCM_API void *scm_malloc (size_t size);
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 54e594e51..5a4caebe8 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -142,14 +142,14 @@ static void
unmark_port (SCM port)
{
SCM stream, string;
- port_mark_p = SCM_GCMARKP (port);
- SCM_CLRGCMARK (port);
+ port_mark_p = SCM_GC_MARK_P (port);
+ SCM_CLEAR_GC_MARK (port);
stream = SCM_PACK (SCM_STREAM (port));
- stream_mark_p = SCM_GCMARKP (stream);
- SCM_CLRGCMARK (stream);
+ stream_mark_p = SCM_GC_MARK_P (stream);
+ SCM_CLEAR_GC_MARK (stream);
string = SCM_CDR (stream);
- string_mark_p = SCM_GCMARKP (string);
- SCM_CLRGCMARK (string);
+ string_mark_p = SCM_GC_MARK_P (string);
+ SCM_CLEAR_GC_MARK (string);
}
@@ -158,16 +158,19 @@ remark_port (SCM port)
{
SCM stream = SCM_PACK (SCM_STREAM (port));
SCM string = SCM_CDR (stream);
- if (string_mark_p) SCM_SETGCMARK (string);
- if (stream_mark_p) SCM_SETGCMARK (stream);
- if (port_mark_p) SCM_SETGCMARK (port);
+ if (string_mark_p)
+ SCM_SET_GC_MARK (string);
+ if (stream_mark_p)
+ SCM_SET_GC_MARK (stream);
+ if (port_mark_p)
+ SCM_SET_GC_MARK (port);
}
int
gdb_maybe_valid_type_p (SCM value)
{
- return SCM_IMP (value) || scm_cellp (value);
+ return SCM_IMP (value) || scm_in_heap_p (value);
}
@@ -211,8 +214,8 @@ gdb_read (char *str)
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
/* Read one object */
- tok_buf_mark_p = SCM_GCMARKP (tok_buf);
- SCM_CLRGCMARK (tok_buf);
+ tok_buf_mark_p = SCM_GC_MARK_P (tok_buf);
+ SCM_CLEAR_GC_MARK (tok_buf);
ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
if (SCM_GC_P)
{
@@ -229,7 +232,7 @@ gdb_read (char *str)
scm_permanent_object (ans);
exit:
if (tok_buf_mark_p)
- SCM_SETGCMARK (tok_buf);
+ SCM_SET_GC_MARK (tok_buf);
remark_port (gdb_input_port);
SCM_END_FOREIGN_BLOCK;
return status;
diff --git a/libguile/guardians.c b/libguile/guardians.c
index b69d0f5e9..e0651f8e2 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -447,19 +447,19 @@ mark_dependencies_in_tconc (t_tconc *tc)
SCM obj = SCM_CAR (pair);
next_pair = SCM_CDR (pair);
- if (! SCM_MARKEDP (obj))
+ if (! SCM_GC_MARK_P (obj))
{
/* a candidate for finalizing */
scm_gc_mark_dependencies (obj);
- if (SCM_MARKEDP (obj))
+ if (SCM_GC_MARK_P (obj))
{
/* uh oh. a cycle. transfer this object (the
spine cell, to be exact) to
self_centered_zombies, so we'll be able to
complain about it later. */
*prev_ptr = next_pair;
- SCM_SETGCMARK (pair);
+ SCM_SET_GC_MARK (pair);
SCM_SETCDR (pair, self_centered_zombies);
self_centered_zombies = pair;
}
@@ -494,7 +494,7 @@ mark_and_zombify (t_guardian *g)
{
SCM next_pair = SCM_CDR (pair);
- if (!SCM_MARKEDP (SCM_CAR (pair)))
+ if (!SCM_GC_MARK_P (SCM_CAR (pair)))
{
/* got you, zombie! */
@@ -504,7 +504,7 @@ mark_and_zombify (t_guardian *g)
if (GREEDY_P (g))
/* if the guardian is greedy, mark this zombie now. this
way it won't be zombified again this time around. */
- SCM_SETGCMARK (SCM_CAR (pair));
+ SCM_SET_GC_MARK (SCM_CAR (pair));
/* into the zombie list! */
TCONC_IN (g->zombies, SCM_CAR (pair), pair);
@@ -519,7 +519,7 @@ mark_and_zombify (t_guardian *g)
don't care about objects pointed to by the list cars, since we
know they are already marked). */
for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair))
- SCM_SETGCMARK (pair);
+ SCM_SET_GC_MARK (pair);
}
diff --git a/libguile/init.c b/libguile/init.c
index 432983ea3..80e36cb5c 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -453,7 +453,9 @@ scm_init_guile_1 (SCM_STACKITEM *base)
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- scm_init_storage (); /* requires smob_prehistory */
+ if (scm_init_storage ()) /* requires smob_prehistory */
+ abort ();
+
scm_struct_prehistory (); /* requires storage */
scm_symbols_prehistory (); /* requires storage */
scm_weaks_prehistory (); /* requires storage */
diff --git a/libguile/inline.c b/libguile/inline.c
index 3ec21e55c..914f309b2 100644
--- a/libguile/inline.c
+++ b/libguile/inline.c
@@ -41,9 +41,10 @@
#include "libguile/scmconfig.h"
-#ifndef HAVE_INLINE
#define HAVE_INLINE
+#define EXTERN_INLINE
+#undef SCM_INLINE_H
+
#include "libguile/inline.h"
-#endif
diff --git a/libguile/inline.h b/libguile/inline.h
index 19566bcce..c1df037c3 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -49,35 +49,73 @@
"inline.c".
*/
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+#include <stdio.h>
+#endif
+
#include "libguile/pairs.h"
#include "libguile/gc.h"
+
+SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+
#ifdef HAVE_INLINE
-static inline SCM
+
+
+#ifndef EXTERN_INLINE
+#define EXTERN_INLINE extern inline
+#endif
+
+extern unsigned scm_newcell2_count;
+extern unsigned scm_newcell_count;
+
+
+EXTERN_INLINE
+SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
SCM z;
-#ifdef GUILE_DEBUG_FREELIST
- scm_newcell_count++;
- if (scm_debug_check_freelist)
+ if (SCM_NULLP (scm_i_freelist))
{
- scm_check_freelist (scm_freelist);
- scm_gc();
+ z = scm_gc_for_newcell (&scm_i_master_freelist, &scm_i_freelist);
}
-#endif
-
- if (SCM_NULLP (scm_freelist))
+ else
{
- z = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist);
+ z = scm_i_freelist;
+ scm_i_freelist = SCM_FREE_CELL_CDR (scm_i_freelist);
}
- else
+
+ /*
+ We update scm_cells_allocated from this function. If we don't
+ update this explicitly, we will have to walk a freelist somewhere
+ later on, which seems a lot more expensive.
+ */
+ scm_cells_allocated += 1;
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
{
- z = scm_freelist;
- scm_freelist = SCM_FREE_CELL_CDR (scm_freelist);
+ if (SCM_GC_MARK_P (z))
+ {
+ fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
+ abort();
+ }
+ else if (SCM_GC_CELL_TYPE(z) != scm_tc_free_cell)
+ {
+ fprintf(stderr, "cell from freelist is not a free cell.\n");
+ abort();
+ }
+
+ SCM_SET_GC_MARK (z);
}
+#endif
+
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't for
@@ -98,34 +136,31 @@ scm_cell (scm_t_bits car, scm_t_bits cdr)
#endif
#endif
+
+
return z;
}
-static inline SCM
+EXTERN_INLINE
+SCM
scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr)
{
SCM z;
-#ifdef GUILE_DEBUG_FREELIST
- scm_newcell2_count++;
- if (scm_debug_check_freelist)
- {
- scm_check_freelist (scm_freelist2);
- scm_gc();
- }
-#endif
- if (SCM_NULLP (scm_freelist2))
+ if (SCM_NULLP (scm_i_freelist2))
{
- z = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
+ z = scm_gc_for_newcell (&scm_i_master_freelist2, &scm_i_freelist2);
}
else
{
- z = scm_freelist2;
- scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2);
+ z = scm_i_freelist2;
+ scm_i_freelist2 = SCM_FREE_CELL_CDR (scm_i_freelist2);
}
+ scm_cells_allocated += 2;
+
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't for
@@ -148,15 +183,23 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
#endif
#endif
- return z;
-}
-#else /* !HAVE_INLINE */
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
+ {
+ if (SCM_GC_MARK_P (z))
+ {
+ fprintf(stderr,
+ "scm_double_cell tried to allocate a marked cell.\n");
+ abort();
+ }
+
+ SCM_SET_GC_MARK (z);
+ }
+#endif
-SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr);
+ return z;
+}
#endif
-
#endif
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 09b81c7da..53a40a0bd 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2288,6 +2288,12 @@ big2str (SCM b, unsigned int radix)
SCM_BIGDIG radpow = 1, radmod = 0;
SCM ss = scm_allocate_string (j);
char *s = SCM_STRING_CHARS (ss), c;
+
+ if (i == 0)
+ {
+ return scm_makfrom0str ("0");
+ }
+
while ((long) radpow * radix < SCM_BIGRAD)
{
radpow *= radix;
diff --git a/libguile/pairs.c b/libguile/pairs.c
index 0b66ee5ca..5fed8d078 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -54,7 +54,7 @@
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
-#include "libguile/ports.h"
+/~#include "libguile/ports.h"
#include "libguile/strings.h"
void scm_error_pair_access (SCM non_pair)
diff --git a/libguile/print.c b/libguile/print.c
index 63389f1f5..a5e0fc818 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -739,7 +739,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
{
scm_puts ("#<unknown-", port);
scm_puts (hdr, port);
- if (scm_cellp (ptr))
+ if (scm_in_heap_p (ptr))
{
scm_puts (" (0x", port);
scm_intprint (SCM_CELL_WORD_0 (ptr), 16, port);
diff --git a/libguile/procs.c b/libguile/procs.c
index 690f88a14..948934de2 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -139,7 +139,7 @@ scm_mark_subr_table ()
long i;
for (i = 0; i < scm_subr_table_size; ++i)
{
- SCM_SETGCMARK (scm_subr_table[i].name);
+ SCM_SET_GC_MARK (scm_subr_table[i].name);
if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
scm_gc_mark (*scm_subr_table[i].generic);
if (SCM_NIMP (scm_subr_table[i].properties))
diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c
index ddb73ea03..bd7c341e2 100644
--- a/libguile/regex-posix.c
+++ b/libguile/regex-posix.c
@@ -270,14 +270,13 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
/* The match vector must include a cell for the string that was matched,
so add 1. */
mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED);
- SCM_VELTS(mvec)[0] = str;
+ SCM_VECTOR_SET(mvec,0, str);
for (i = 0; i < nmatches; ++i)
if (matches[i].rm_so == -1)
- SCM_VELTS(mvec)[i+1] = scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1));
+ SCM_VECTOR_SET(mvec,i+1, scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1)));
else
- SCM_VELTS(mvec)[i+1]
- = scm_cons (scm_long2num (matches[i].rm_so + offset),
- scm_long2num (matches[i].rm_eo + offset));
+ SCM_VECTOR_SET(mvec,i+1,scm_cons (scm_long2num (matches[i].rm_so + offset),
+ scm_long2num (matches[i].rm_eo + offset)));
}
free (matches);
SCM_ALLOW_INTS;
diff --git a/libguile/struct.c b/libguile/struct.c
index e8585896e..308af78e7 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -378,7 +378,7 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
{
SCM vtable = SCM_STRUCT_VTABLE (chain);
if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
- SCM_SETGCMARK (vtable);
+ SCM_SET_GC_MARK (vtable);
chain = SCM_STRUCT_GC_CHAIN (chain);
}
/* Free unmarked structs. */
@@ -388,9 +388,9 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
{
SCM obj = chain;
chain = SCM_STRUCT_GC_CHAIN (chain);
- if (SCM_GCMARKP (obj))
+ if (SCM_GC_MARK_P (obj))
{
- SCM_CLRGCMARK (obj);
+ SCM_CLEAR_GC_MARK (obj);
SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
newchain = obj;
}
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 73635dea4..ecc701bdf 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -120,19 +120,14 @@ scm_mem2symbol (const char *name, size_t len)
{
/* The symbol was not found - create it. */
-
- SCM symbol;
- SCM cell;
- SCM slot;
-
- symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
+ SCM symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
(scm_t_bits) scm_gc_strndup (name, len,
"symbol"),
raw_hash,
SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
- slot = SCM_VELTS (symbols) [hash];
- cell = scm_cons (symbol, SCM_UNDEFINED);
+ SCM slot = SCM_VELTS (symbols) [hash];
+ SCM cell = scm_cons (symbol, SCM_UNDEFINED);
SCM_VECTOR_SET (symbols, hash, scm_cons (cell, slot));
return symbol;
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 90b573185..9c34a645f 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -278,11 +278,11 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
alist = ptr[j];
while ( SCM_CONSP (alist)
- && !SCM_GCMARKP (alist)
+ && !SCM_GC_MARK_P (alist)
&& SCM_CONSP (SCM_CAR (alist)))
{
- SCM_SETGCMARK (alist);
- SCM_SETGCMARK (SCM_CAR (alist));
+ SCM_SET_GC_MARK (alist);
+ SCM_SET_GC_MARK (SCM_CAR (alist));
alist = SCM_CDR (alist);
}
}
@@ -292,6 +292,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
return 0;
}
+#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
static void *
scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
@@ -308,7 +309,7 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
ptr = SCM_GC_WRITABLE_VELTS (w);
n = SCM_VECTOR_LENGTH (w);
for (j = 0; j < n; ++j)
- if (SCM_FREE_CELL_P (ptr[j]))
+ if (UNMARKED_CELL_P (ptr[j]))
ptr[j] = SCM_BOOL_F;
}
else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
@@ -329,16 +330,16 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
fixup = ptr + j;
alist = *fixup;
- while ( SCM_CONSP (alist)
- && SCM_CONSP (SCM_CAR (alist)))
+ while (SCM_CONSP (alist)
+ && SCM_CONSP (SCM_CAR (alist)))
{
SCM key;
SCM value;
key = SCM_CAAR (alist);
value = SCM_CDAR (alist);
- if ( (weak_keys && SCM_FREE_CELL_P (key))
- || (weak_values && SCM_FREE_CELL_P (value)))
+ if ( (weak_keys && UNMARKED_CELL_P (key))
+ || (weak_values && UNMARKED_CELL_P (value)))
{
*fixup = SCM_CDR (alist);
}