diff options
-rw-r--r-- | libguile/gc-freelist.c | 210 | ||||
-rw-r--r-- | libguile/gc-malloc.c | 407 | ||||
-rw-r--r-- | libguile/gc-mark.c | 562 | ||||
-rw-r--r-- | libguile/gc-segment.c | 562 | ||||
-rw-r--r-- | libguile/private-gc.h | 239 |
5 files changed, 1980 insertions, 0 deletions
diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c new file mode 100644 index 000000000..21720534a --- /dev/null +++ b/libguile/gc-freelist.c @@ -0,0 +1,210 @@ +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include <assert.h> + +#include "libguile/private-gc.h" +#include "libguile/gc.h" +#include "libguile/deprecation.h" +#include "libguile/private-gc.h" + +scm_t_cell_type_statistics scm_i_master_freelist; +scm_t_cell_type_statistics scm_i_master_freelist2; + + + + +/* + +In older versions of GUILE GC there was extensive support for +debugging freelists. This was useful, since the freelist was kept +inside the heap, and writing to an object that was GC'd would mangle +the list. Mark bits are now separate, and checking for sane cell +access can be done much more easily by simply checking if the mark bit +is unset before allocation. --hwn + + + +*/ + +#if (SCM_ENABLE_DEPRECATED == 1) +#if defined(GUILE_DEBUG_FREELIST) + +SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, + (), + "DEPRECATED\n") +#define FUNC_NAME s_scm_map_free_list +{ + scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n"); + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, + (SCM flag), + "DEPRECATED.\n") +#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x +{ + scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n"); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +#endif /* defined (GUILE_DEBUG) */ +#endif /* deprecated */ + + + + +/* + This adjust FREELIST variables to decide wether or not to allocate + more heap in the next GC run. It uses scm_gc_cells_collected and scm_gc_cells_collected1 + */ + +void +scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist) +{ + /* min yield is adjusted upwards so that next predicted total yield + * (allocated cells actually freed by GC) becomes + * `min_yield_fraction' of total heap size. Note, however, that + * the absolute value of min_yield will correspond to `collected' + * on one master (the one which currently is triggering GC). + * + * The reason why we look at total yield instead of cells collected + * on one list is that we want to take other freelists into account. + * On this freelist, we know that (local) yield = collected cells, + * but that's probably not the case on the other lists. + * + * (We might consider computing a better prediction, for example + * by computing an average over multiple GC:s.) + */ + if (freelist->min_yield_fraction) + { + /* Pick largest of last two yields. */ + long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100) + - (long) SCM_MAX (scm_gc_cells_collected_1, scm_gc_cells_collected)); +#ifdef DEBUGINFO + fprintf (stderr, " after GC = %lu, delta = %ld\n", + (long) scm_cells_allocated, + (long) delta); +#endif + if (delta > 0) + freelist->min_yield += delta; + } +} + + +static void +scm_init_freelist (scm_t_cell_type_statistics *freelist, + int span, + int min_yield) +{ + freelist->heap_segment_idx = -1; + freelist->min_yield = 0; + freelist->min_yield_fraction = min_yield; + freelist->span = span; + freelist->collected = 0; + freelist->collected_1 = 0; + freelist->heap_size = 0; +} + +#if (SCM_ENABLE_DEPRECATED == 1) + size_t scm_default_init_heap_size_1; + int scm_default_min_yield_1; + size_t scm_default_init_heap_size_2; + int scm_default_min_yield_2; + size_t scm_default_max_segment_size; +#endif + +void +scm_gc_init_freelist (void) +{ + size_t init_heap_size_1 + = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1); + + size_t init_heap_size_2 + = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2); + + scm_i_freelist = SCM_EOL; + scm_i_freelist2 = SCM_EOL; + + scm_init_freelist (&scm_i_master_freelist2, 2, + scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2)); + scm_init_freelist (&scm_i_master_freelist, 1, + scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1)); + + + scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE); + + scm_i_make_initial_segment (init_heap_size_1, &scm_i_master_freelist); + scm_i_make_initial_segment (init_heap_size_2, &scm_i_master_freelist2); + + +#if (SCM_ENABLE_DEPRECATED == 1) + if ( scm_default_init_heap_size_1 || + scm_default_min_yield_1|| + scm_default_init_heap_size_2|| + scm_default_min_yield_2|| + scm_default_max_segment_size) + { + scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead."); + } +#endif +} + + +void +scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist) +{ + freelist->collected_1 = freelist->collected; + freelist->collected = 0; + + /* + at the end we simply start with the lowest segment again. + */ + freelist->heap_segment_idx = -1; +} + +int +scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist) +{ + return SCM_MAX (freelist->collected,freelist->collected_1) < freelist->min_yield; +} diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c new file mode 100644 index 000000000..40d4ef907 --- /dev/null +++ b/libguile/gc-malloc.c @@ -0,0 +1,407 @@ +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include <stdio.h> +#include <errno.h> +#include <string.h> + +#ifdef __ia64__ +#include <ucontext.h> +extern unsigned long * __libc_ia64_register_backing_store_base; +#endif + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/stime.h" +#include "libguile/stackchk.h" +#include "libguile/struct.h" +#include "libguile/smob.h" +#include "libguile/unif.h" +#include "libguile/async.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/weaks.h" +#include "libguile/hashtab.h" +#include "libguile/tags.h" + +#include "libguile/validate.h" +#include "libguile/deprecation.h" +#include "libguile/gc.h" + +#include "libguile/private-gc.h" + +#ifdef GUILE_DEBUG_MALLOC +#include "libguile/debug-malloc.h" +#endif + +#ifdef HAVE_MALLOC_H +#include <malloc.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* + INIT_MALLOC_LIMIT is the initial amount of malloc usage which will + trigger a GC. + + After startup (at the guile> prompt), we have approximately 100k of + alloced memory, which won't go away on GC. Let's set the init such + that we get a nice yield on the next allocation: +*/ +#define SCM_DEFAULT_INIT_MALLOC_LIMIT 200000 +#define SCM_DEFAULT_MALLOC_MINYIELD 40 + + +static int scm_i_minyield_malloc; + +void +scm_gc_init_malloc (void) +{ + scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT", + SCM_DEFAULT_INIT_MALLOC_LIMIT); + scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC", + SCM_DEFAULT_MALLOC_MINYIELD); +} + + + +/* Function for non-cell memory management. + */ + +void * +scm_malloc (size_t size) +{ + void *ptr; + + if (size == 0) + return NULL; + + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_i_sweep_all_segments ("malloc"); + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_igc ("malloc"); + scm_i_sweep_all_segments ("malloc/gc"); + + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_memory_error ("malloc"); +} + +void * +scm_realloc (void *mem, size_t size) +{ + void *ptr; + + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_i_sweep_all_segments ("realloc"); + + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_igc ("realloc"); + scm_i_sweep_all_segments ("realloc"); + + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_memory_error ("realloc"); +} + +char * +scm_strndup (const char *str, size_t n) +{ + char *dst = scm_malloc (n+1); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} + +char * +scm_strdup (const char *str) +{ + return scm_strndup (str, strlen (str)); +} + +void +scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated += size; + + /* + we could finish the full sweep (without mark) here, but in + practice this turns out to be ineffective. + */ + + /* + A program that uses a lot of malloced collectable memory (vectors, + strings), will use a lot of memory off the cell-heap; it needs to + do GC more often (before cells are exhausted), otherwise swapping + and malloc management will tie it down. + */ + if (scm_mallocated > scm_mtrigger) + { + long prev_alloced = scm_mallocated; + float yield; + + scm_igc (what); + scm_i_sweep_all_segments("mtrigger"); + + yield = (prev_alloced - scm_mallocated) / (float) prev_alloced; + + /* + fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d", + prev_alloced, scm_mallocated, 100.0*yield, scm_i_minyield_malloc); + */ + + if (yield < scm_i_minyield_malloc / 100.0) + { + /* + We make the trigger a little larger, even; If you have a + program that builds up a lot of data in strings, then the + desired yield will never be satisfied. + + Instead of getting bogged down, we let the mtrigger grow + strongly with it. + */ + scm_mtrigger = (scm_mallocated * 110) / (100 - scm_i_minyield_malloc); + + /* + fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n", scm_mtrigger); + */ + + + } + } + +#ifdef GUILE_DEBUG_MALLOC + if (mem) + scm_malloc_register (mem, what); +#endif +} + +void +scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated -= size; + scm_gc_malloc_collected += size; + +#ifdef GUILE_DEBUG_MALLOC + if (mem) + scm_malloc_unregister (mem); +#endif +} + +void * +scm_gc_malloc (size_t size, const char *what) +{ + /* + The straightforward implementation below has the problem + that it might call the GC twice, once in scm_malloc and then + again in scm_gc_register_collectable_memory. We don't really + want the second GC since it will not find new garbage. + + + Note: this is a theoretical peeve. In reality, malloc() never + returns NULL. Usually, memory is overcommitted, and when you try + to write it the program is killed with signal 11. --hwn + */ + + void *ptr = scm_malloc (size); + scm_gc_register_collectable_memory (ptr, size, what); + return ptr; +} + +void * +scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what) +{ + /* XXX - see scm_gc_malloc. */ + + void *ptr = scm_realloc (mem, new_size); + scm_gc_unregister_collectable_memory (mem, old_size, what); + scm_gc_register_collectable_memory (ptr, new_size, what); + return ptr; +} + +void +scm_gc_free (void *mem, size_t size, const char *what) +{ + scm_gc_unregister_collectable_memory (mem, size, what); + free (mem); +} + +char * +scm_gc_strndup (const char *str, size_t n, const char *what) +{ + char *dst = scm_gc_malloc (n+1, what); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} + +char * +scm_gc_strdup (const char *str, const char *what) +{ + return scm_gc_strndup (str, strlen (str), what); +} + +#if SCM_ENABLE_DEPRECATED == 1 + +/* {Deprecated front end to malloc} + * + * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, + * scm_done_free + * + * These functions provide services comparable to malloc, realloc, and + * free. They should be used when allocating memory that will be under + * control of the garbage collector, i.e., if the memory may be freed + * during garbage collection. + * + * They are deprecated because they weren't really used the way + * outlined above, and making sure to return the right amount from + * smob free routines was sometimes difficult when dealing with nested + * data structures. We basically want everybody to review their code + * and use the more symmetrical scm_gc_malloc/scm_gc_free functions + * instead. In some cases, where scm_must_malloc has been used + * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free. + */ + +void * +scm_must_malloc (size_t size, const char *what) +{ + scm_c_issue_deprecation_warning + ("scm_must_malloc is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); + + return scm_gc_malloc (size, what); +} + +void * +scm_must_realloc (void *where, + size_t old_size, + size_t size, + const char *what) +{ + scm_c_issue_deprecation_warning + ("scm_must_realloc is deprecated. " + "Use scm_gc_realloc and scm_gc_free instead."); + + return scm_gc_realloc (where, old_size, size, what); +} + +char * +scm_must_strndup (const char *str, size_t length) +{ + scm_c_issue_deprecation_warning + ("scm_must_strndup is deprecated. " + "Use scm_gc_strndup and scm_gc_free instead."); + + return scm_gc_strndup (str, length, "string"); +} + +char * +scm_must_strdup (const char *str) +{ + scm_c_issue_deprecation_warning + ("scm_must_strdup is deprecated. " + "Use scm_gc_strdup and scm_gc_free instead."); + + return scm_gc_strdup (str, "string"); +} + +void +scm_must_free (void *obj) +#define FUNC_NAME "scm_must_free" +{ + scm_c_issue_deprecation_warning + ("scm_must_free is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); + +#ifdef GUILE_DEBUG_MALLOC + scm_malloc_unregister (obj); +#endif + if (obj) + free (obj); + else + SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL); +} +#undef FUNC_NAME + + +void +scm_done_malloc (long size) +{ + scm_c_issue_deprecation_warning + ("scm_done_malloc is deprecated. " + "Use scm_gc_register_collectable_memory instead."); + + scm_gc_register_collectable_memory (NULL, size, "foreign mallocs"); +} + +void +scm_done_free (long size) +{ + scm_c_issue_deprecation_warning + ("scm_done_free is deprecated. " + "Use scm_gc_unregister_collectable_memory instead."); + + scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs"); +} + +#endif /* SCM_ENABLE_DEPRECATED == 1 */ diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c new file mode 100644 index 000000000..49cb77e29 --- /dev/null +++ b/libguile/gc-mark.c @@ -0,0 +1,562 @@ +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <assert.h> + +#ifdef __ia64__ +#include <ucontext.h> +extern unsigned long * __libc_ia64_register_backing_store_base; +#endif + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/stime.h" +#include "libguile/stackchk.h" +#include "libguile/struct.h" +#include "libguile/smob.h" +#include "libguile/unif.h" +#include "libguile/async.h" +#include "libguile/ports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/weaks.h" +#include "libguile/hashtab.h" +#include "libguile/tags.h" +#include "libguile/private-gc.h" +#include "libguile/validate.h" +#include "libguile/deprecation.h" +#include "libguile/gc.h" + +#ifdef GUILE_DEBUG_MALLOC +#include "libguile/debug-malloc.h" +#endif + +#ifdef HAVE_MALLOC_H +#include <malloc.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + + + +#ifdef __ia64__ +# define SCM_MARK_BACKING_STORE() do { \ + ucontext_t ctx; \ + SCM_STACKITEM * top, * bot; \ + getcontext (&ctx); \ + scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ + ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ + / sizeof (SCM_STACKITEM))); \ + bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ + top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ + scm_mark_locations (bot, top - bot); } while (0) +#else +# define SCM_MARK_BACKING_STORE() +#endif + +/* + Entry point for this file. + */ +void +scm_mark_all (void) +{ + long j; + + + scm_i_clear_mark_space (); + +#ifndef USE_THREADS + + /* Mark objects on the C stack. */ + SCM_FLUSH_REGISTER_WINDOWS; + /* This assumes that all registers are saved into the jmp_buf */ + setjmp (scm_save_regs_gc_mark); + scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, + ( (size_t) (sizeof (SCM_STACKITEM) - 1 + + sizeof scm_save_regs_gc_mark) + / sizeof (SCM_STACKITEM))); + + { + unsigned long stack_len = scm_stack_size (scm_stack_base); +#ifdef SCM_STACK_GROWS_UP + scm_mark_locations (scm_stack_base, stack_len); +#else + scm_mark_locations (scm_stack_base - stack_len, stack_len); +#endif + } + SCM_MARK_BACKING_STORE(); + +#else /* USE_THREADS */ + + /* Mark every thread's stack and registers */ + scm_threads_mark_stacks (); + +#endif /* USE_THREADS */ + + j = SCM_NUM_PROTECTS; + while (j--) + scm_gc_mark (scm_sys_protects[j]); + + /* mark the registered roots */ + { + size_t i; + for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) + { + SCM l = SCM_VELTS (scm_gc_registered_roots)[i]; + for (; !SCM_NULLP (l); l = SCM_CDR (l)) + { + SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL)); + scm_gc_mark (*p); + } + } + } + + /* FIXME: we should have a means to register C functions to be run + * in different phases of GC + */ + scm_mark_subr_table (); + +#ifndef USE_THREADS + scm_gc_mark (scm_root->handle); +#endif +} + +/* {Mark/Sweep} + */ + + +/* + Mark an object precisely, then recurse. + */ +void +scm_gc_mark (SCM ptr) +{ + if (SCM_IMP (ptr)) + return ; + + if (SCM_GC_MARK_P (ptr)) + return; + + SCM_SET_GC_MARK (ptr); + scm_gc_mark_dependencies (ptr); +} + +/* + +Mark the dependencies of an object. + +TODO: + +Should prefetch objects before marking, i.e. if marking a cell, we +should prefetch the car, and then mark the cdr. This will improve CPU +cache misses, because the car is more likely to be in core when we +finish the cdr. + +See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing +garbage collector cache misses. + +Prefetch is supported on GCC >= 3.1 + + */ +void +scm_gc_mark_dependencies (SCM p) +#define FUNC_NAME "scm_gc_mark_dependencies" +{ + register long i; + register SCM ptr; + scm_t_bits cell_type; + + ptr = p; + scm_mark_dependencies_again: + + cell_type = SCM_GC_CELL_TYPE (ptr); + switch (SCM_ITAG7 (cell_type)) + { + case scm_tcs_cons_nimcar: + if (SCM_IMP (SCM_CDR (ptr))) + { + ptr = SCM_CAR (ptr); + goto gc_mark_nimp; + } + scm_gc_mark (SCM_CAR (ptr)); + ptr = SCM_CDR (ptr); + goto gc_mark_nimp; + case scm_tcs_cons_imcar: + ptr = SCM_CDR (ptr); + goto gc_mark_loop; + case scm_tc7_pws: + scm_gc_mark (SCM_SETTER (ptr)); + ptr = SCM_PROCEDURE (ptr); + goto gc_mark_loop; + case scm_tcs_struct: + { + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; + scm_t_bits * vtable_data = (scm_t_bits *) word0; + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + long len = SCM_SYMBOL_LENGTH (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); + scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); + scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); + } + if (len) + { + long x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + scm_gc_mark (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data++; x; --x, ++struct_data) + scm_gc_mark (SCM_PACK (*struct_data)); + else + scm_gc_mark (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto gc_mark_loop; + } + break; + case scm_tcs_closures: + if (SCM_IMP (SCM_ENV (ptr))) + { + ptr = SCM_CLOSCAR (ptr); + goto gc_mark_nimp; + } + scm_gc_mark (SCM_CLOSCAR (ptr)); + ptr = SCM_ENV (ptr); + goto gc_mark_nimp; + case scm_tc7_vector: + i = SCM_VECTOR_LENGTH (ptr); + if (i == 0) + break; + while (--i > 0) + if (SCM_NIMP (SCM_VELTS (ptr)[i])) + scm_gc_mark (SCM_VELTS (ptr)[i]); + ptr = SCM_VELTS (ptr)[0]; + goto gc_mark_loop; +#ifdef CCLO + case scm_tc7_cclo: + { + size_t i = SCM_CCLO_LENGTH (ptr); + size_t j; + for (j = 1; j != i; ++j) + { + SCM obj = SCM_CCLO_REF (ptr, j); + if (!SCM_IMP (obj)) + scm_gc_mark (obj); + } + ptr = SCM_CCLO_REF (ptr, 0); + goto gc_mark_loop; + } +#endif +#ifdef HAVE_ARRAYS + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_ivect: + case scm_tc7_uvect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_svect: +#ifdef HAVE_LONG_LONGS + case scm_tc7_llvect: +#endif +#endif + case scm_tc7_string: + break; + + case scm_tc7_wvect: + SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors); + scm_weak_vectors = ptr; + if (SCM_IS_WHVEC_ANY (ptr)) + { + long x; + long len; + int weak_keys; + int weak_values; + + len = SCM_VECTOR_LENGTH (ptr); + weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); + weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); + + for (x = 0; x < len; ++x) + { + SCM alist; + alist = SCM_VELTS (ptr)[x]; + + /* mark everything on the alist except the keys or + * values, according to weak_values and weak_keys. */ + while ( SCM_CONSP (alist) + && !SCM_GC_MARK_P (alist) + && SCM_CONSP (SCM_CAR (alist))) + { + SCM kvpair; + SCM next_alist; + + kvpair = SCM_CAR (alist); + next_alist = SCM_CDR (alist); + /* + * Do not do this: + * SCM_SET_GC_MARK (alist); + * SCM_SET_GC_MARK (kvpair); + * + * It may be that either the key or value is protected by + * an escaped reference to part of the spine of this alist. + * If we mark the spine here, and only mark one or neither of the + * key and value, they may never be properly marked. + * This leads to a horrible situation in which an alist containing + * freelist cells is exported. + * + * So only mark the spines of these arrays last of all marking. + * If somebody confuses us by constructing a weak vector + * with a circular alist then we are hosed, but at least we + * won't prematurely drop table entries. + */ + if (!weak_keys) + scm_gc_mark (SCM_CAR (kvpair)); + if (!weak_values) + scm_gc_mark (SCM_CDR (kvpair)); + alist = next_alist; + } + if (SCM_NIMP (alist)) + scm_gc_mark (alist); + } + } + break; + + case scm_tc7_symbol: + ptr = SCM_PROP_SLOTS (ptr); + goto gc_mark_loop; + case scm_tc7_variable: + ptr = SCM_CELL_OBJECT_1 (ptr); + goto gc_mark_loop; + case scm_tcs_subrs: + break; + case scm_tc7_port: + i = SCM_PTOBNUM (ptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (!(i < scm_numptob)) + SCM_MISC_ERROR ("undefined port type", SCM_EOL); +#endif + if (SCM_PTAB_ENTRY(ptr)) + scm_gc_mark (SCM_FILENAME (ptr)); + if (scm_ptobs[i].mark) + { + ptr = (scm_ptobs[i].mark) (ptr); + goto gc_mark_loop; + } + else + return; + break; + case scm_tc7_smob: + switch (SCM_TYP16 (ptr)) + { /* should be faster than going through scm_smobs */ + case scm_tc_free_cell: + /* We have detected a free cell. This can happen if non-object data + * on the C stack points into guile's heap and is scanned during + * conservative marking. */ + break; + case scm_tc16_big: + case scm_tc16_real: + case scm_tc16_complex: + break; + default: + i = SCM_SMOBNUM (ptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (!(i < scm_numsmob)) + SCM_MISC_ERROR ("undefined smob type", SCM_EOL); +#endif + if (scm_smobs[i].mark) + { + ptr = (scm_smobs[i].mark) (ptr); + goto gc_mark_loop; + } + else + return; + } + break; + default: + SCM_MISC_ERROR ("unknown type", SCM_EOL); + } + + /* + If we got here, then exhausted recursion options for PTR. we + return (careful not to mark PTR, it might be the argument that we + were called with.) + */ + return ; + +gc_mark_loop: + if (SCM_IMP (ptr)) + return; + + gc_mark_nimp: + { + int valid_cell = CELL_P (ptr); + + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (scm_debug_cell_accesses_p) + { + /* We are in debug mode. Check the ptr exhaustively. */ + + valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0); + } + +#endif + if (!valid_cell) + SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); + } + + if (SCM_GC_MARK_P (ptr)) + return; + + SCM_SET_GC_MARK (ptr); + goto scm_mark_dependencies_again; + +} +#undef FUNC_NAME + + + +/* Mark a region conservatively */ +void +scm_mark_locations (SCM_STACKITEM x[], unsigned long n) +{ + unsigned long m; + + for (m = 0; m < n; ++m) + { + SCM obj = * (SCM *) &x[m]; + long int segment = scm_i_find_heap_segment_containing_object (obj); + if (segment >= 0) + scm_gc_mark (obj); + } +} + + +/* The function scm_in_heap_p determines whether an SCM value can be regarded as a + * pointer to a cell on the heap. + */ +int +scm_in_heap_p (SCM value) +{ + long int segment = scm_i_find_heap_segment_containing_object (value); + return (segment >= 0); +} + + +#if SCM_ENABLE_DEPRECATED == 1 + +/* If an allocated cell is detected during garbage collection, this + * means that some code has just obtained the object but was preempted + * before the initialization of the object was completed. This meanst + * that some entries of the allocated cell may already contain SCM + * objects. Therefore, allocated cells are scanned conservatively. + */ + +scm_t_bits scm_tc16_allocated; + +static SCM +allocated_mark (SCM cell) +{ + unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell); + unsigned int span = scm_i_heap_segment_table[cell_segment]->span; + unsigned int i; + + for (i = 1; i != span * 2; ++i) + { + SCM obj = SCM_CELL_OBJECT (cell, i); + long int obj_segment = scm_i_find_heap_segment_containing_object (obj); + if (obj_segment >= 0) + scm_gc_mark (obj); + } + return SCM_BOOL_F; +} + +SCM +scm_deprecated_newcell (void) +{ + scm_c_issue_deprecation_warning + ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n"); + + return scm_cell (scm_tc16_allocated, 0); +} + +SCM +scm_deprecated_newcell2 (void) +{ + scm_c_issue_deprecation_warning + ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n"); + + return scm_double_cell (scm_tc16_allocated, 0, 0, 0); +} + +#endif /* SCM_ENABLE_DEPRECATED == 1 */ + + +void +scm_gc_init_mark(void) +{ +#if SCM_ENABLE_DEPRECATED == 1 + scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); + scm_set_smob_mark (scm_tc16_allocated, allocated_mark); +#endif +} + + diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c new file mode 100644 index 000000000..a3859df7b --- /dev/null +++ b/libguile/gc-segment.c @@ -0,0 +1,562 @@ +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include <assert.h> +#include <stdio.h> +#include <string.h> + +#include "libguile/_scm.h" +#include "libguile/pairs.h" +#include "libguile/gc.h" +#include "libguile/private-gc.h" + + + +#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \ + ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS) +#define SCM_GC_IN_CARD_HEADERP(x) \ + (scm_t_cell *) (x) < SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS + + +size_t scm_max_segment_size; + +scm_t_heap_segment * +scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl) +{ + scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment)); + + if (!shs) + { + fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n"); + abort (); + } + + shs->bounds[0] = NULL; + shs->bounds[1] = NULL; + shs->malloced = NULL; + shs->span = fl->span; + shs->freelist = fl; + shs->next_free_card = NULL; + + return shs; +} + + +/* + Fill SEGMENT with memory both for data and mark bits. + + RETURN: 1 on success, 0 failure + */ +int +scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested) +{ + /* + round upwards + */ + int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS); + int card_count =1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count; + + /* + one card extra due to alignment + */ + size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD + + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG + ; + scm_t_c_bvec_long * bvec_ptr = 0; + scm_t_cell * memory = 0; + + /* + We use malloc to alloc the heap. On GNU libc this is + equivalent to mmapping /dev/zero + */ + SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed)); + + if (memory == NULL) + return 0; + + segment->malloced = memory; + segment->bounds[0] = SCM_GC_CARD_UP (memory); + segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS; + + segment->freelist->heap_size += scm_i_segment_cell_count (segment); + + bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1]; + + + { + scm_t_cell * ptr = segment->bounds [0]; + + for (; + ptr < segment->bounds[1]; ptr += SCM_GC_CARD_N_CELLS) + { + SCM_GC_CELL_BVEC (ptr) = bvec_ptr; + if (segment->span == 2) + SCM_GC_SET_CARD_DOUBLECELL (ptr); + + bvec_ptr += SCM_GC_CARD_BVEC_SIZE_IN_LONGS; + + /* + Don't init the mem. This is handled by lazy sweeping. + */ + } + } + + segment->next_free_card = segment->bounds[0]; + segment->first_time = 1; + return 1; +} + +int +scm_i_segment_card_count (scm_t_heap_segment * seg) +{ + return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; +} + +/* + Return the number of available single-cell data cells. + */ +int +scm_i_segment_cell_count (scm_t_heap_segment * seg) +{ + return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) + + ((seg->span == 2) ? -1 : 0); +} + +void +scm_i_clear_segment_mark_space (scm_t_heap_segment *seg) +{ + scm_t_cell * markspace = seg->bounds[1]; + + memset (markspace, 0x00, + scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG); +} + +/* + RETURN: + + Freelist. +*/ +SCM +scm_i_sweep_some_cards (scm_t_heap_segment *seg) +{ + SCM cells = SCM_EOL; + int threshold = 512; + int collected = 0; + int (*sweeper) (scm_t_cell *, SCM *, int ) + = (seg->first_time) ? &scm_init_card_freelist : &scm_i_sweep_card; + + scm_t_cell * next_free = seg->next_free_card; + int cards_swept = 0; + + while (collected < threshold && next_free < seg->bounds[1]) + { + collected += (*sweeper) (next_free, &cells, seg->span); + next_free += SCM_GC_CARD_N_CELLS; + cards_swept ++; + } + + scm_gc_cells_swept += cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS); + scm_gc_cells_collected += collected * seg->span; + seg->freelist->collected += collected * seg->span; + + if(next_free == seg->bounds[1]) + { + seg->first_time = 0; + } + + seg->next_free_card = next_free; + return cells; +} + + +/* + Force a sweep of this entire segment. This doesn't modify sweep + statistics, it just frees the memory pointed to by to-be-swept + cells. + + Implementation is slightly ugh, and how do we handle the swept_cells + statistic? + */ +void +scm_i_sweep_segment (scm_t_heap_segment * seg) +{ + scm_t_cell * p = seg->next_free_card; + int yield = scm_gc_cells_collected; + int coll = seg->freelist->collected; + + while (scm_i_sweep_some_cards (seg) != SCM_EOL) + ; + + scm_gc_cells_collected = yield; + seg->freelist->collected = coll; + + seg->next_free_card =p; +} + +void +scm_i_sweep_all_segments (char const *reason) +{ + int i= 0; + + for (i = 0; i < scm_i_heap_segment_table_size; i++) + { + scm_i_sweep_segment (scm_i_heap_segment_table[i]); + } +} + + +/* + Heap segment table. + + The table is sorted by the address of the data itself. This makes + for easy lookups. This is not portable: according to ANSI C, + pointers can only be compared within the same object (i.e. the same + block of malloced memory.). For machines with weird architectures, + this should be revised. + + (Apparently, for this reason 1.6 and earlier had macros for pointer + comparison. ) + + perhaps it is worthwhile to remove the 2nd level of indirection in + the table, but this certainly makes for cleaner code. +*/ +scm_t_heap_segment ** scm_i_heap_segment_table; +size_t scm_i_heap_segment_table_size; +scm_t_cell *lowest_cell; +scm_t_cell *highest_cell; + + +void +scm_i_clear_mark_space (void) +{ + int i = 0; + for (; i < scm_i_heap_segment_table_size; i++) + { + scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]); + } +} + + +/* + RETURN: index of inserted segment. + */ +int +scm_i_insert_segment (scm_t_heap_segment * seg) +{ + size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *); + SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **) + realloc ((char *)scm_i_heap_segment_table, size))); + + /* + We can't alloc 4 more bytes. This is hopeless. + */ + if (!scm_i_heap_segment_table) + { + fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n"); + abort (); + } + + if (!lowest_cell) + { + lowest_cell = seg->bounds[0]; + highest_cell = seg->bounds[1]; + } + else + { + lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]); + highest_cell = SCM_MAX (highest_cell, seg->bounds[1]); + } + + + { + int i = 0; + int j = 0; + + while (i < scm_i_heap_segment_table_size + && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0]) + i++; + for (j = scm_i_heap_segment_table_size; j > i; --j) + scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1]; + + scm_i_heap_segment_table [i] = seg; + scm_i_heap_segment_table_size ++; + + return i; + } +} + +SCM +scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl) +{ + int i = fl->heap_segment_idx; + SCM collected =SCM_EOL; + + if (i == -1) + i++; + + for (; + i < scm_i_heap_segment_table_size; i++) + { + if (scm_i_heap_segment_table[i]->freelist != fl) + continue; + + collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]); + + + if (collected != SCM_EOL) /* Don't increment i */ + break; + } + + fl->heap_segment_idx = i; + + return collected; +} + + + + +void +scm_i_reset_segments (void) +{ + int i = 0; + for (; i < scm_i_heap_segment_table_size; i++) + { + scm_t_heap_segment * seg = scm_i_heap_segment_table[i]; + seg->next_free_card = seg->bounds[0]; + } +} + + +/* + Determine whether the given value does actually represent a cell in + some heap segment. If this is the case, the number of the heap + segment is returned. Otherwise, -1 is returned. Binary search is + used to determine the heap segment that contains the cell. + + + I think this function is too long to be inlined. --hwn +*/ +long int +scm_i_find_heap_segment_containing_object (SCM obj) +{ + if (!CELL_P (obj)) + return -1; + + if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell) + return -1; + + + { + scm_t_cell * ptr = SCM2PTR (obj); + unsigned long int i = 0; + unsigned long int j = scm_i_heap_segment_table_size - 1; + + if (ptr < scm_i_heap_segment_table[i]->bounds[0]) + return -1; + else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) + return -1; + else + { + while (i < j) + { + if (ptr < scm_i_heap_segment_table[i]->bounds[1]) + { + break; + } + else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr) + { + i = j; + break; + } + else + { + unsigned long int k = (i + j) / 2; + + if (k == i) + return -1; + else if (ptr < scm_i_heap_segment_table[k]->bounds[1]) + { + j = k; + ++i; + if (ptr < scm_i_heap_segment_table[i]->bounds[0]) + return -1; + } + else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr) + { + i = k; + --j; + if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) + return -1; + } + } + } + + if (!DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2) + return -1; + else if (SCM_GC_IN_CARD_HEADERP (ptr)) + return -1; + else + return i; + } + } +} + + +/* + Important entry point: try to grab some memory, and make it into a + segment. + + RETURN: the index of the segment. + */ +int +scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_error error_policy) +{ + size_t len; + + if (scm_gc_heap_lock) + { + /* Critical code sections (such as the garbage collector) aren't + * supposed to add heap segments. + */ + fprintf (stderr, "scm_i_get_new_heap_segment: Can not extend locked heap.\n"); + abort (); + } + + + /* Pick a size for the new heap segment. + * The rule for picking the size of a segment is explained in + * gc.h + */ + { + /* Assure that the new segment is predicted to be large enough. + * + * New yield should at least equal GC fraction of new heap size, i.e. + * + * y + dh > f * (h + dh) + * + * y : yield + * f : min yield fraction + * h : heap size + * dh : size of new heap segment + * + * This gives dh > (f * h - y) / (1 - f) + */ + + /* + where is is this explanation supposed to be? --hwn + */ + int f = freelist->min_yield_fraction; + unsigned long h = SCM_HEAP_SIZE; + size_t min_cells = (f * h - 100 * (long) scm_gc_cells_collected) / (99 - f); + + /* Make heap grow with factor 1.5 */ + len = freelist->heap_size / 2; +#ifdef DEBUGINFO + fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells); +#endif + + /* + Original code adds freelist->cluster_size here. + */ + if (len < min_cells) + len = min_cells; + len *= sizeof (scm_t_cell); + /* force new sampling */ + freelist->collected = LONG_MAX; + } + + if (len > scm_max_segment_size) + len = scm_max_segment_size; + + { + size_t smallest; + scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist); + + smallest = 1024 * 10; /* UGH. */ + + if (len < smallest) + len = smallest; + + /* Allocate with decaying ambition. */ + while ((len >= SCM_MIN_HEAP_SEG_SIZE) + && (len >= smallest)) + { + if (scm_i_initialize_heap_segment_data (seg, len)) + { + return scm_i_insert_segment (seg); + } + + len /= 2; + } + } + + if (error_policy == abort_on_error) + { + fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n"); + abort (); + } + return -1; +} + + +void +scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist) +{ + scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist); + + if (scm_i_initialize_heap_segment_data (seg, init_heap_size)) + { + freelist->heap_segment_idx = scm_i_insert_segment (seg); + } + + /* + Why the fuck try twice? --hwn + */ + if (!seg->malloced) + { + scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE); + } + + if (freelist->min_yield_fraction) + freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction + / 100); +} + diff --git a/libguile/private-gc.h b/libguile/private-gc.h new file mode 100644 index 000000000..52556bee6 --- /dev/null +++ b/libguile/private-gc.h @@ -0,0 +1,239 @@ +/* + (c) FSF 2002. +*/ + + +#ifndef PRIVATE_GC +#define PRIVATE_GC + +#include "_scm.h" + +/* {heap tuning parameters} + * + * These are parameters for controlling memory allocation. The heap + * is the area out of which scm_cons, and object headers are allocated. + * + * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a + * 64 bit machine. The units of the _SIZE parameters are bytes. + * Cons pairs and object headers occupy one heap cell. + * + * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is + * allocated initially the heap will grow by half its current size + * each subsequent time more heap is needed. + * + * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE + * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more + * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code + * is in scm_init_storage() and alloc_some_heap() in sys.c + * + * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by + * SCM_EXPHEAP(scm_heap_size) when more heap is needed. + * + * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap + * is needed. + */ + + +/* + * Heap size 45000 and 40% min yield gives quick startup and no extra + * heap allocation. Having higher values on min yield may lead to + * large heaps, especially if code behaviour is varying its + * maximum consumption between different freelists. + */ + +/* + These values used to be global C variables. However, they're also + available through the environment, and having a double interface is + confusing. Now they're #defines --hwn. + */ + +#define SCM_DEFAULT_INIT_HEAP_SIZE_1 256*1024 +#define SCM_DEFAULT_MIN_YIELD_1 40 +#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024 + +/* The following value may seem large, but note that if we get to GC at + * all, this means that we have a numerically intensive application + */ +#define SCM_DEFAULT_MIN_YIELD_2 40 +#define SCM_DEFAULT_MAX_SEGMENT_SIZE 2097000L /* a little less (adm) than 2 Mb */ + + + +#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD) +#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) + + +#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) + + + + +int scm_getenv_int (const char *var, int def); + + +typedef enum { return_on_error, abort_on_error } policy_on_error; + +/* gc-freelist*/ + +/* + FREELIST: + + A struct holding GC statistics on a particular type of cells. +*/ +typedef struct scm_t_cell_type_statistics { + + /* + heap segment where the last cell was allocated + */ + int heap_segment_idx; + + /* minimum yield on this list in order not to grow the heap + */ + long min_yield; + + /* defines min_yield as percent of total heap size + */ + int min_yield_fraction; + + /* number of cells per object on this list */ + int span; + + /* number of collected cells during last GC */ + unsigned long collected; + + /* number of collected cells during penultimate GC */ + unsigned long collected_1; + + /* total number of cells in heap segments + * belonging to this list. + */ + unsigned long heap_size; + +} scm_t_cell_type_statistics; + + +extern scm_t_cell_type_statistics scm_i_master_freelist; +extern scm_t_cell_type_statistics scm_i_master_freelist2; +extern unsigned long scm_gc_cells_collected_1; + +void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist); +void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist); +int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist); + +#define SCM_HEAP_SIZE \ + (scm_i_master_freelist.heap_size + scm_i_master_freelist2.heap_size) + + +#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) +#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B)) + +#define CELL_P(x) (SCM_ITAG3 (x) == scm_tc3_cons) + +/* + gc-mark + */ + + +void scm_mark_all (void); + + + +/* +gc-segment: +*/ + + + + +/* + + Cells are stored in a heap-segment: it is a contiguous chunk of + memory, that associated with one freelist. +*/ + +typedef struct scm_t_heap_segment +{ + /* + {lower, upper} bounds of the segment + + The upper bound is also the start of the mark space. + */ + scm_t_cell *bounds[2]; + + /* + If we ever decide to give it back, we could do it with this ptr. + + Note that giving back memory is not very useful; as long we don't + touch a chunk of memory, the virtual memory system will keep it + swapped out. We could simply forget about a block. + + (not that we do that, but anyway.) + */ + + void* malloced; + + scm_t_cell * next_free_card; + + /* address of the head-of-freelist pointer for this segment's cells. + All segments usually point to the same one, scm_i_freelist. */ + scm_t_cell_type_statistics *freelist; + + /* number of cells per object in this segment */ + int span; + + + /* + Is this the first time that the cells are accessed? + */ + int first_time; + +} scm_t_heap_segment; + + + +/* + + A table of segment records is kept that records the upper and + lower extents of the segment; this is used during the conservative + phase of gc to identify probably gc roots (because they point + into valid segments at reasonable offsets). + +*/ +extern scm_t_heap_segment ** scm_i_heap_segment_table; +extern size_t scm_i_heap_segment_table_size; + + +int scm_init_card_freelist (scm_t_cell * card, SCM *free_list,int); +int scm_i_sweep_card (scm_t_cell * card, SCM *free_list,int); +int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested); +int scm_i_segment_card_count (scm_t_heap_segment * seg); +int scm_i_segment_cell_count (scm_t_heap_segment * seg); + +void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg); +scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*); +SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg); +void scm_i_sweep_segment (scm_t_heap_segment * seg); + + +int scm_i_insert_segment (scm_t_heap_segment * seg); +long int scm_i_find_heap_segment_containing_object (SCM obj); +int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error); +void scm_i_clear_mark_space (void); +void scm_i_sweep_segments (void); +SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl); +void scm_i_reset_segments (void); +void scm_i_sweep_all_segments (char const *reason); +void scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist); + +extern long int scm_i_deprecated_memory_return; + + +/* + global init funcs. + */ +void scm_gc_init_malloc (void); +void scm_gc_init_freelist (void); +void scm_gc_init_segments (void); +void scm_gc_init_mark (void); + +#endif |