mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

more code

Browse source
This commit is contained in:
Han-Wen Nienhuys 2002-08-04 00:18:33 +00:00
parent c8a1bdc460
commit c7743d027a
5 changed files with 1980 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

210
libguile/gc-freelist.c Normal file
View file

@ -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;
}

407
libguile/gc-malloc.c Normal file
View file

@ -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 */

562
libguile/gc-mark.c Normal file
View file

@ -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
}

562
libguile/gc-segment.c Normal file
View file

@ -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);
}

239
libguile/private-gc.h Normal file
View file

@ -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