mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
Merge from lcourtes@laas.fr--2005-mobile
Patches applied: * lcourtes@laas.fr--2005-mobile/guile-core--boehm-gc--1.9 (base, patch 1) - tag of lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--base-0 - Initial hack for Boehm's GC support: nothing works. git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-1
This commit is contained in:
Ludovic Courtes
Ludovic Courtès
parent
5695ccd43b
commit
26224b3f5d
15 changed files with 191 additions and 765 deletions
12
configure.in
12
configure.in
|
|
@ -947,6 +947,18 @@ AC_TRY_RUN(aux (l) unsigned long l;
|
|||
[],
|
||||
[AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)])
|
||||
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
# Boehm's GC library
|
||||
#
|
||||
#--------------------------------------------------------------------
|
||||
AC_CHECK_LIB([gc], [GC_collect_a_little],
|
||||
[LIBS="-lgc $LIBS"],
|
||||
[AC_MSG_ERROR([`libgc' (Boehm's GC library) not found.])])
|
||||
AC_CHECK_HEADER([gc/gc.h], [],
|
||||
[AC_MSG_ERROR([`libgc' (Boehm's GC library) header files not found.])])
|
||||
|
||||
|
||||
AC_CHECK_SIZEOF(float)
|
||||
if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
|
||||
AC_DEFINE(SCM_SINGLES, 1,
|
||||
|
|
|
|||
|
|
@ -96,8 +96,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
|
|||
chars.c continuations.c convert.c debug.c deprecation.c \
|
||||
deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \
|
||||
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
|
||||
futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
|
||||
gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c \
|
||||
futures.c gc.c gc-malloc.c \
|
||||
gdbint.c gh_data.c gh_eval.c gh_funcs.c \
|
||||
gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \
|
||||
guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \
|
||||
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
|
||||
|
|
@ -112,8 +112,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
|
|||
DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
|
||||
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
|
||||
dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \
|
||||
extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
|
||||
gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x \
|
||||
extensions.x feature.x fluids.x fports.x futures.x gc.x \
|
||||
goops.x gsubr.x guardians.x \
|
||||
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
|
||||
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
|
||||
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
|
||||
|
|
@ -130,8 +130,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
|
|||
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
|
||||
environments.doc eq.doc error.doc eval.doc evalext.doc \
|
||||
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
|
||||
gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \
|
||||
gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc \
|
||||
gc.doc goops.doc gsubr.doc \
|
||||
gc-malloc.doc guardians.doc hash.doc hashtab.doc \
|
||||
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
|
||||
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
|
||||
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
|
||||
|
|
|
|||
|
|
@ -133,6 +133,8 @@ scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED,
|
|||
void *dummy2 SCM_UNUSED,
|
||||
void *dummy3 SCM_UNUSED)
|
||||
{
|
||||
/* FIXME: What to do here? */
|
||||
#if 0
|
||||
SCM *statep, *fluidp;
|
||||
|
||||
/* Scan all fluids and deallocate the unmarked ones.
|
||||
|
|
@ -172,6 +174,7 @@ scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED,
|
|||
}
|
||||
}
|
||||
|
||||
#endif
|
||||
return NULL;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -105,31 +105,14 @@ void *
|
|||
scm_realloc (void *mem, size_t size)
|
||||
{
|
||||
void *ptr;
|
||||
scm_t_sweep_statistics sweep_stats;
|
||||
|
||||
SCM_SYSCALL (ptr = realloc (mem, size));
|
||||
if (ptr)
|
||||
return ptr;
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
|
||||
scm_gc_running_p = 1;
|
||||
/* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
|
||||
GC_gcollect ();
|
||||
|
||||
scm_i_sweep_all_segments ("realloc", &sweep_stats);
|
||||
|
||||
SCM_SYSCALL (ptr = realloc (mem, size));
|
||||
if (ptr)
|
||||
{
|
||||
scm_gc_running_p = 0;
|
||||
scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
|
||||
return ptr;
|
||||
}
|
||||
|
||||
scm_i_gc ("realloc");
|
||||
scm_i_sweep_all_segments ("realloc", &sweep_stats);
|
||||
|
||||
scm_gc_running_p = 0;
|
||||
scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
|
||||
|
||||
SCM_SYSCALL (ptr = realloc (mem, size));
|
||||
if (ptr)
|
||||
return ptr;
|
||||
|
|
@ -159,7 +142,7 @@ scm_calloc (size_t sz)
|
|||
SCM_SYSCALL (ptr = calloc (sz, 1));
|
||||
if (ptr)
|
||||
return ptr;
|
||||
|
||||
|
||||
ptr = scm_realloc (NULL, sz);
|
||||
memset (ptr, 0x0, sz);
|
||||
return ptr;
|
||||
|
|
@ -181,124 +164,22 @@ scm_strdup (const char *str)
|
|||
return scm_strndup (str, strlen (str));
|
||||
}
|
||||
|
||||
static void
|
||||
decrease_mtrigger (size_t size, const char * what)
|
||||
{
|
||||
scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
|
||||
|
||||
if (size > scm_mallocated)
|
||||
{
|
||||
fprintf (stderr, "`scm_mallocated' underflow. This means that more "
|
||||
"memory was unregistered\n"
|
||||
"via `scm_gc_unregister_collectable_memory ()' than "
|
||||
"registered.\n");
|
||||
abort ();
|
||||
}
|
||||
|
||||
scm_mallocated -= size;
|
||||
scm_gc_malloc_collected += size;
|
||||
scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
|
||||
}
|
||||
|
||||
static void
|
||||
increase_mtrigger (size_t size, const char *what)
|
||||
{
|
||||
size_t mallocated = 0;
|
||||
int overflow = 0, triggered = 0;
|
||||
|
||||
scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
|
||||
if (ULONG_MAX - size < scm_mallocated)
|
||||
overflow = 1;
|
||||
else
|
||||
{
|
||||
scm_mallocated += size;
|
||||
mallocated = scm_mallocated;
|
||||
if (scm_mallocated > scm_mtrigger)
|
||||
triggered = 1;
|
||||
}
|
||||
scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
|
||||
|
||||
if (overflow)
|
||||
scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
|
||||
|
||||
/*
|
||||
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 (triggered)
|
||||
{
|
||||
unsigned long prev_alloced;
|
||||
float yield;
|
||||
scm_t_sweep_statistics sweep_stats;
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
|
||||
scm_gc_running_p = 1;
|
||||
|
||||
prev_alloced = mallocated;
|
||||
scm_i_gc (what);
|
||||
scm_i_sweep_all_segments ("mtrigger", &sweep_stats);
|
||||
|
||||
yield = (((float) prev_alloced - (float) scm_mallocated)
|
||||
/ (float) prev_alloced);
|
||||
|
||||
scm_gc_malloc_yield_percentage = (int) (100 * yield);
|
||||
|
||||
#ifdef DEBUGINFO
|
||||
fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d",
|
||||
prev_alloced,
|
||||
scm_mallocated,
|
||||
100.0 * yield,
|
||||
scm_i_minyield_malloc);
|
||||
#endif
|
||||
|
||||
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.
|
||||
*/
|
||||
float no_overflow_trigger = scm_mallocated * 110.0;
|
||||
|
||||
no_overflow_trigger /= (float) (100.0 - scm_i_minyield_malloc);
|
||||
|
||||
|
||||
if (no_overflow_trigger >= (float) ULONG_MAX)
|
||||
scm_mtrigger = ULONG_MAX;
|
||||
else
|
||||
scm_mtrigger = (unsigned long) no_overflow_trigger;
|
||||
|
||||
#ifdef DEBUGINFO
|
||||
fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
|
||||
scm_mtrigger);
|
||||
#endif
|
||||
}
|
||||
|
||||
scm_gc_running_p = 0;
|
||||
scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
|
||||
{
|
||||
increase_mtrigger (size, what);
|
||||
#ifdef GUILE_DEBUG_MALLOC
|
||||
if (mem)
|
||||
scm_malloc_register (mem, what);
|
||||
scm_malloc_register (mem);
|
||||
#endif
|
||||
fprintf (stderr, "%s: nothing done\n", __FUNCTION__); /* FIXME: What to do? */
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
|
||||
{
|
||||
decrease_mtrigger (size, what);
|
||||
#ifdef GUILE_DEBUG_MALLOC
|
||||
if (mem)
|
||||
scm_malloc_unregister (mem);
|
||||
|
|
@ -319,8 +200,7 @@ scm_gc_malloc (size_t size, const char *what)
|
|||
to write it the program is killed with signal 11. --hwn
|
||||
*/
|
||||
|
||||
void *ptr = scm_malloc (size);
|
||||
scm_gc_register_collectable_memory (ptr, size, what);
|
||||
void *ptr = GC_MALLOC (size);
|
||||
return ptr;
|
||||
}
|
||||
|
||||
|
|
@ -338,26 +218,13 @@ scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
|
|||
{
|
||||
void *ptr;
|
||||
|
||||
/* XXX - see scm_gc_malloc. */
|
||||
|
||||
|
||||
/*
|
||||
scm_realloc() may invalidate the block pointed to by WHERE, eg. by
|
||||
unmapping it from memory or altering the contents. Since
|
||||
increase_mtrigger() might trigger a GC that would scan
|
||||
MEM, it is crucial that this call precedes realloc().
|
||||
*/
|
||||
|
||||
decrease_mtrigger (old_size, what);
|
||||
increase_mtrigger (new_size, what);
|
||||
|
||||
ptr = scm_realloc (mem, new_size);
|
||||
ptr = GC_REALLOC (mem, new_size);
|
||||
|
||||
#ifdef GUILE_DEBUG_MALLOC
|
||||
if (mem)
|
||||
scm_malloc_reregister (mem, ptr, what);
|
||||
#endif
|
||||
|
||||
|
||||
return ptr;
|
||||
}
|
||||
|
||||
|
|
@ -365,13 +232,13 @@ void
|
|||
scm_gc_free (void *mem, size_t size, const char *what)
|
||||
{
|
||||
scm_gc_unregister_collectable_memory (mem, size, what);
|
||||
free (mem);
|
||||
GC_FREE (mem);
|
||||
}
|
||||
|
||||
char *
|
||||
scm_gc_strndup (const char *str, size_t n, const char *what)
|
||||
{
|
||||
char *dst = scm_gc_malloc (n+1, what);
|
||||
char *dst = GC_MALLOC (n+1);
|
||||
memcpy (dst, str, n);
|
||||
dst[n] = 0;
|
||||
return dst;
|
||||
|
|
|
|||
355
libguile/gc.c
355
libguile/gc.c
|
|
@ -203,6 +203,12 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
|
|||
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
|
||||
|
||||
|
||||
/* Hooks. */
|
||||
scm_t_c_hook scm_before_gc_c_hook;
|
||||
scm_t_c_hook scm_before_mark_c_hook;
|
||||
scm_t_c_hook scm_before_sweep_c_hook;
|
||||
scm_t_c_hook scm_after_sweep_c_hook;
|
||||
scm_t_c_hook scm_after_gc_c_hook;
|
||||
|
||||
|
||||
/* scm_mtrigger
|
||||
|
|
@ -285,8 +291,6 @@ SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
|
|||
SCM tab = scm_make_hash_table (scm_from_int (57));
|
||||
SCM alist;
|
||||
|
||||
scm_i_all_segments_statistics (tab);
|
||||
|
||||
alist
|
||||
= scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
|
||||
|
||||
|
|
@ -317,29 +321,25 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
|
|||
double local_scm_gc_cells_marked;
|
||||
SCM answer;
|
||||
unsigned long *bounds = 0;
|
||||
int table_size = scm_i_heap_segment_table_size;
|
||||
SCM_CRITICAL_SECTION_START;
|
||||
|
||||
/*
|
||||
temporarily store the numbers, so as not to cause GC.
|
||||
*/
|
||||
|
||||
#if 0
|
||||
bounds = malloc (sizeof (unsigned long) * table_size * 2);
|
||||
if (!bounds)
|
||||
abort();
|
||||
for (i = table_size; i--; )
|
||||
{
|
||||
bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0];
|
||||
bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1];
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
return SCM_EOL; /* FIXME */
|
||||
#if 0
|
||||
/* Below, we cons to produce the resulting list. We want a snapshot of
|
||||
* the heap situation before consing.
|
||||
*/
|
||||
local_scm_mtrigger = scm_mtrigger;
|
||||
local_scm_mallocated = scm_mallocated;
|
||||
local_scm_heap_size = SCM_HEAP_SIZE;
|
||||
local_scm_heap_size = 0; /* SCM_HEAP_SIZE; */ /* FIXME */
|
||||
|
||||
local_scm_cells_allocated = scm_cells_allocated;
|
||||
|
||||
|
|
@ -395,42 +395,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
|
|||
|
||||
free (bounds);
|
||||
return answer;
|
||||
#endif
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static void
|
||||
gc_start_stats (const char *what SCM_UNUSED)
|
||||
{
|
||||
t_before_gc = scm_c_get_internal_run_time ();
|
||||
|
||||
scm_gc_malloc_collected = 0;
|
||||
scm_gc_ports_collected = 0;
|
||||
}
|
||||
|
||||
static void
|
||||
gc_end_stats (scm_t_sweep_statistics sweep_stats)
|
||||
{
|
||||
unsigned long t = scm_c_get_internal_run_time ();
|
||||
scm_gc_time_taken += (t - t_before_gc);
|
||||
|
||||
/*
|
||||
CELLS SWEPT is another word for the number of cells that were
|
||||
examined during GC. YIELD is the number that we cleaned
|
||||
out. MARKED is the number that weren't cleaned.
|
||||
*/
|
||||
scm_gc_cells_marked_acc += (double) sweep_stats.swept
|
||||
- (double) scm_gc_cells_collected;
|
||||
scm_gc_cells_swept_acc += (double) sweep_stats.swept;
|
||||
|
||||
scm_gc_cell_yield_percentage = (sweep_stats.collected * 100) / SCM_HEAP_SIZE;
|
||||
|
||||
scm_gc_cells_swept = sweep_stats.swept;
|
||||
scm_gc_cells_collected_1 = scm_gc_cells_collected;
|
||||
scm_gc_cells_collected = sweep_stats.collected;
|
||||
scm_cells_allocated -= sweep_stats.collected;
|
||||
|
||||
++scm_gc_times;
|
||||
}
|
||||
|
||||
|
||||
SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
|
||||
|
|
@ -467,186 +436,10 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
|
||||
/* The master is global and common while the freelist will be
|
||||
* individual for each thread.
|
||||
*/
|
||||
|
||||
SCM
|
||||
scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
|
||||
{
|
||||
SCM cell;
|
||||
int did_gc = 0;
|
||||
scm_t_sweep_statistics sweep_stats;
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
|
||||
scm_gc_running_p = 1;
|
||||
|
||||
*free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
|
||||
scm_cells_allocated -= sweep_stats.collected;
|
||||
|
||||
if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist))
|
||||
{
|
||||
freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
|
||||
*free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
|
||||
scm_cells_allocated -= sweep_stats.collected;
|
||||
}
|
||||
|
||||
if (*free_cells == SCM_EOL)
|
||||
{
|
||||
/*
|
||||
with the advent of lazy sweep, GC yield is only known just
|
||||
before doing the GC.
|
||||
*/
|
||||
scm_i_adjust_min_yield (freelist, sweep_stats);
|
||||
|
||||
/*
|
||||
out of fresh cells. Try to get some new ones.
|
||||
*/
|
||||
|
||||
did_gc = 1;
|
||||
scm_i_gc ("cells");
|
||||
|
||||
*free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
|
||||
scm_cells_allocated -= sweep_stats.collected;
|
||||
}
|
||||
|
||||
if (*free_cells == SCM_EOL)
|
||||
{
|
||||
/*
|
||||
failed getting new cells. Get new juice or die.
|
||||
*/
|
||||
freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
|
||||
*free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
|
||||
scm_cells_allocated -= sweep_stats.collected;
|
||||
}
|
||||
|
||||
if (*free_cells == SCM_EOL)
|
||||
abort ();
|
||||
|
||||
cell = *free_cells;
|
||||
|
||||
*free_cells = SCM_FREE_CELL_CDR (cell);
|
||||
|
||||
scm_gc_running_p = 0;
|
||||
scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
|
||||
|
||||
if (did_gc)
|
||||
scm_c_hook_run (&scm_after_gc_c_hook, 0);
|
||||
|
||||
return cell;
|
||||
}
|
||||
|
||||
|
||||
scm_t_c_hook scm_before_gc_c_hook;
|
||||
scm_t_c_hook scm_before_mark_c_hook;
|
||||
scm_t_c_hook scm_before_sweep_c_hook;
|
||||
scm_t_c_hook scm_after_sweep_c_hook;
|
||||
scm_t_c_hook scm_after_gc_c_hook;
|
||||
|
||||
/* Must be called while holding scm_i_sweep_mutex.
|
||||
*/
|
||||
|
||||
void
|
||||
scm_i_gc (const char *what)
|
||||
{
|
||||
scm_t_sweep_statistics sweep_stats;
|
||||
|
||||
scm_i_thread_put_to_sleep ();
|
||||
|
||||
scm_c_hook_run (&scm_before_gc_c_hook, 0);
|
||||
|
||||
#ifdef DEBUGINFO
|
||||
fprintf (stderr,"gc reason %s\n", what);
|
||||
|
||||
fprintf (stderr,
|
||||
scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist))
|
||||
? "*"
|
||||
: (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m"));
|
||||
#endif
|
||||
|
||||
gc_start_stats (what);
|
||||
|
||||
/*
|
||||
Set freelists to NULL so scm_cons() always triggers gc, causing
|
||||
the assertion above to fail.
|
||||
*/
|
||||
*SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
|
||||
*SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
|
||||
|
||||
/*
|
||||
Let's finish the sweep. The conservative GC might point into the
|
||||
garbage, and marking that would create a mess.
|
||||
*/
|
||||
scm_i_sweep_all_segments ("GC", &sweep_stats);
|
||||
|
||||
/* Invariant: the number of cells collected (i.e., freed) must always be
|
||||
lower than or equal to the number of cells "swept" (i.e., visited). */
|
||||
assert (sweep_stats.collected <= sweep_stats.swept);
|
||||
|
||||
if (scm_mallocated < scm_i_deprecated_memory_return)
|
||||
{
|
||||
/* The byte count of allocated objects has underflowed. This is
|
||||
probably because you forgot to report the sizes of objects you
|
||||
have allocated, by calling scm_done_malloc or some such. When
|
||||
the GC freed them, it subtracted their size from
|
||||
scm_mallocated, which underflowed. */
|
||||
fprintf (stderr,
|
||||
"scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
|
||||
"This is probably because the GC hasn't been correctly informed\n"
|
||||
"about object sizes\n");
|
||||
abort ();
|
||||
}
|
||||
scm_mallocated -= scm_i_deprecated_memory_return;
|
||||
|
||||
|
||||
/* Mark */
|
||||
|
||||
scm_c_hook_run (&scm_before_mark_c_hook, 0);
|
||||
scm_mark_all ();
|
||||
scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc);
|
||||
|
||||
/* Sweep
|
||||
|
||||
TODO: the after_sweep hook should probably be moved to just before
|
||||
the mark, since that's where the sweep is finished in lazy
|
||||
sweeping.
|
||||
|
||||
MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
|
||||
original meaning implied at least two things: that it would be
|
||||
called when
|
||||
|
||||
1. the freelist is re-initialized (no evaluation possible, though)
|
||||
|
||||
and
|
||||
|
||||
2. the heap is "fresh"
|
||||
(it is well-defined what data is used and what is not)
|
||||
|
||||
Neither of these conditions would hold just before the mark phase.
|
||||
|
||||
Of course, the lazy sweeping has muddled the distinction between
|
||||
scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
|
||||
there were no difference, it would still be useful to have two
|
||||
distinct classes of hook functions since this can prevent some
|
||||
bad interference when several modules adds gc hooks.
|
||||
*/
|
||||
|
||||
scm_c_hook_run (&scm_before_sweep_c_hook, 0);
|
||||
scm_gc_sweep ();
|
||||
scm_c_hook_run (&scm_after_sweep_c_hook, 0);
|
||||
|
||||
gc_end_stats (sweep_stats);
|
||||
|
||||
scm_i_thread_wake_up ();
|
||||
|
||||
/*
|
||||
For debugging purposes, you could do
|
||||
scm_i_sweep_all_segments("debug"), but then the remains of the
|
||||
cell aren't left to analyse.
|
||||
*/
|
||||
GC_gcollect ();
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -923,12 +716,8 @@ scm_init_storage ()
|
|||
while (j)
|
||||
scm_sys_protects[--j] = SCM_BOOL_F;
|
||||
|
||||
scm_gc_init_freelist();
|
||||
scm_gc_init_malloc ();
|
||||
|
||||
j = SCM_HEAP_SEG_SIZE;
|
||||
|
||||
|
||||
/* Initialise the list of ports. */
|
||||
scm_i_port_table = (scm_t_port **)
|
||||
malloc (sizeof (scm_t_port *) * scm_i_port_table_room);
|
||||
|
|
@ -1020,10 +809,109 @@ mark_gc_async (void * hook_data SCM_UNUSED,
|
|||
return NULL;
|
||||
}
|
||||
|
||||
char const *
|
||||
scm_i_tag_name (scm_t_bits tag)
|
||||
{
|
||||
if (tag >= 255)
|
||||
{
|
||||
if (tag == scm_tc_free_cell)
|
||||
return "free cell";
|
||||
|
||||
{
|
||||
int k = 0xff & (tag >> 8);
|
||||
return (scm_smobs[k].name);
|
||||
}
|
||||
}
|
||||
|
||||
switch (tag) /* 7 bits */
|
||||
{
|
||||
case scm_tcs_struct:
|
||||
return "struct";
|
||||
case scm_tcs_cons_imcar:
|
||||
return "cons (immediate car)";
|
||||
case scm_tcs_cons_nimcar:
|
||||
return "cons (non-immediate car)";
|
||||
case scm_tcs_closures:
|
||||
return "closures";
|
||||
case scm_tc7_pws:
|
||||
return "pws";
|
||||
case scm_tc7_wvect:
|
||||
return "weak vector";
|
||||
case scm_tc7_vector:
|
||||
return "vector";
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
return "compiled closure";
|
||||
#endif
|
||||
case scm_tc7_number:
|
||||
switch (tag)
|
||||
{
|
||||
case scm_tc16_real:
|
||||
return "real";
|
||||
break;
|
||||
case scm_tc16_big:
|
||||
return "bignum";
|
||||
break;
|
||||
case scm_tc16_complex:
|
||||
return "complex number";
|
||||
break;
|
||||
case scm_tc16_fraction:
|
||||
return "fraction";
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case scm_tc7_string:
|
||||
return "string";
|
||||
break;
|
||||
case scm_tc7_stringbuf:
|
||||
return "string buffer";
|
||||
break;
|
||||
case scm_tc7_symbol:
|
||||
return "symbol";
|
||||
break;
|
||||
case scm_tc7_variable:
|
||||
return "variable";
|
||||
break;
|
||||
case scm_tcs_subrs:
|
||||
return "subrs";
|
||||
break;
|
||||
case scm_tc7_port:
|
||||
return "port";
|
||||
break;
|
||||
case scm_tc7_smob:
|
||||
return "smob"; /* should not occur. */
|
||||
break;
|
||||
}
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
FIXME: Unimplemented procs!
|
||||
|
||||
*/
|
||||
|
||||
void
|
||||
scm_gc_mark (SCM o)
|
||||
{
|
||||
}
|
||||
|
||||
void
|
||||
scm_gc_mark_dependencies (SCM o)
|
||||
{
|
||||
}
|
||||
|
||||
void
|
||||
scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
|
||||
{
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
scm_init_gc ()
|
||||
{
|
||||
scm_gc_init_mark ();
|
||||
GC_init ();
|
||||
|
||||
scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
|
||||
scm_c_define ("after-gc-hook", scm_after_gc_hook);
|
||||
|
|
@ -1041,21 +929,8 @@ void
|
|||
scm_gc_sweep (void)
|
||||
#define FUNC_NAME "scm_gc_sweep"
|
||||
{
|
||||
scm_i_deprecated_memory_return = 0;
|
||||
|
||||
scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist);
|
||||
scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2);
|
||||
|
||||
/*
|
||||
NOTHING HERE: LAZY SWEEPING !
|
||||
*/
|
||||
scm_i_reset_segments ();
|
||||
|
||||
*SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
|
||||
*SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
|
||||
|
||||
/* Invalidate the freelists of other threads. */
|
||||
scm_i_thread_invalidate_freelists ();
|
||||
/* FIXME */
|
||||
fprintf (stderr, "%s: doing nothing\n", __FUNCTION__);
|
||||
}
|
||||
|
||||
#undef FUNC_NAME
|
||||
|
|
|
|||
107
libguile/gc.h
107
libguile/gc.h
|
|
@ -28,54 +28,12 @@
|
|||
#include "libguile/threads.h"
|
||||
|
||||
|
||||
|
||||
/* Cell allocation and garbage collection work rouhgly in the
|
||||
following manner:
|
||||
|
||||
Each thread has a 'freelist', which is a list of available cells.
|
||||
(It actually has two freelists, one for single cells and one for
|
||||
double cells. Everything works analogous for double cells.)
|
||||
|
||||
When a thread wants to allocate a cell and the freelist is empty,
|
||||
it refers to a global list of unswept 'cards'. A card is a small
|
||||
block of cells that are contigous in memory, together with the
|
||||
corresponding mark bits. A unswept card is one where the mark bits
|
||||
are set for cells that have been in use during the last global mark
|
||||
phase, but the unmarked cells of the card have not been scanned and
|
||||
freed yet.
|
||||
|
||||
The thread takes one of the unswept cards and sweeps it, thereby
|
||||
building a new freelist that it then uses. Sweeping a card will
|
||||
call the smob free functions of unmarked cells, for example, and
|
||||
thus, these free functions can run at any time, in any thread.
|
||||
|
||||
When there are no more unswept cards available, the thread performs
|
||||
a global garbage collection. For this, all other threads are
|
||||
stopped. A global mark is performed and all cards are put into the
|
||||
global list of unswept cards. Whennecessary, new cards are
|
||||
allocated and initialized at this time. The other threads are then
|
||||
started again.
|
||||
*/
|
||||
|
||||
typedef struct scm_t_cell
|
||||
{
|
||||
SCM word_0;
|
||||
SCM word_1;
|
||||
} scm_t_cell;
|
||||
|
||||
/*
|
||||
CARDS
|
||||
|
||||
A card is a small `page' of memory; it will be the unit for lazy
|
||||
sweeping, generations, etc. The first cell of a card contains a
|
||||
pointer to the mark bitvector, so that we can find the bitvector
|
||||
efficiently: we knock off some lowerorder bits.
|
||||
|
||||
The size on a 32 bit machine is 256 cells = 2kb. The card [XXX]
|
||||
*/
|
||||
|
||||
|
||||
|
||||
/* Cray machines have pointers that are incremented once for each
|
||||
* word, rather than each byte, the 3 most significant bits encode the
|
||||
* byte within the word. The following macros deal with this by
|
||||
|
|
@ -92,71 +50,6 @@ typedef struct scm_t_cell
|
|||
#endif /* def _UNICOS */
|
||||
|
||||
|
||||
#define SCM_GC_CARD_N_HEADER_CELLS 1
|
||||
#define SCM_GC_CARD_N_CELLS 256
|
||||
#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
|
||||
|
||||
#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
|
||||
#define SCM_GC_SET_CARD_BVEC(card, bvec) \
|
||||
((card)->word_0 = (SCM) (bvec))
|
||||
#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
|
||||
#define SCM_GC_SET_CARD_FLAGS(card, flags) \
|
||||
((card)->word_1 = (SCM) (flags))
|
||||
|
||||
#define SCM_GC_GET_CARD_FLAG(card, shift) \
|
||||
(SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
|
||||
#define SCM_GC_SET_CARD_FLAG(card, shift) \
|
||||
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
|
||||
#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
|
||||
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
|
||||
|
||||
/*
|
||||
Remove card flags. They hamper lazy initialization, and aren't used
|
||||
anyways.
|
||||
*/
|
||||
|
||||
/* card addressing. for efficiency, cards are *always* aligned to
|
||||
SCM_GC_CARD_SIZE. */
|
||||
|
||||
#define SCM_GC_CARD_SIZE_MASK (SCM_GC_SIZEOF_CARD-1)
|
||||
#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
|
||||
|
||||
#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
|
||||
#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
|
||||
#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
|
||||
#define SCM_GC_SET_CELL_BVEC(x, bvec) SCM_GC_SET_CARD_BVEC (SCM_GC_CELL_CARD (x), bvec)
|
||||
#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
|
||||
#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
|
||||
#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
|
||||
|
||||
/* low level bit banging aids */
|
||||
typedef unsigned long scm_t_c_bvec_long;
|
||||
|
||||
#if (SCM_SIZEOF_UNSIGNED_LONG == 8)
|
||||
# define SCM_C_BVEC_LONG_BITS 64
|
||||
# define SCM_C_BVEC_OFFSET_SHIFT 6
|
||||
# define SCM_C_BVEC_POS_MASK 63
|
||||
# define SCM_CELL_SIZE_SHIFT 4
|
||||
#else
|
||||
# define SCM_C_BVEC_LONG_BITS 32
|
||||
# define SCM_C_BVEC_OFFSET_SHIFT 5
|
||||
# define SCM_C_BVEC_POS_MASK 31
|
||||
# define SCM_CELL_SIZE_SHIFT 3
|
||||
#endif
|
||||
|
||||
#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT)
|
||||
|
||||
#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
|
||||
/* testing and changing GC marks */
|
||||
#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
|
||||
#define SCM_SET_GC_MARK(x) SCM_GC_CELL_SET_BIT (x)
|
||||
#define SCM_CLEAR_GC_MARK(x) SCM_GC_CELL_CLEAR_BIT (x)
|
||||
|
||||
/* Low level cell data accessing macros. These macros should only be used
|
||||
* from within code related to garbage collection issues, since they will
|
||||
|
|
|
|||
|
|
@ -112,6 +112,7 @@ static SCM gdb_output_port;
|
|||
static void
|
||||
unmark_port (SCM port)
|
||||
{
|
||||
#if 0
|
||||
SCM stream, string;
|
||||
port_mark_p = SCM_GC_MARK_P (port);
|
||||
SCM_CLEAR_GC_MARK (port);
|
||||
|
|
@ -121,12 +122,16 @@ unmark_port (SCM port)
|
|||
string = SCM_CDR (stream);
|
||||
string_mark_p = SCM_GC_MARK_P (string);
|
||||
SCM_CLEAR_GC_MARK (string);
|
||||
#else
|
||||
abort (); /* FIXME */
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
remark_port (SCM port)
|
||||
{
|
||||
#if 0
|
||||
SCM stream = SCM_PACK (SCM_STREAM (port));
|
||||
SCM string = SCM_CDR (stream);
|
||||
if (string_mark_p)
|
||||
|
|
@ -135,24 +140,29 @@ remark_port (SCM port)
|
|||
SCM_SET_GC_MARK (stream);
|
||||
if (port_mark_p)
|
||||
SCM_SET_GC_MARK (port);
|
||||
#else
|
||||
abort (); /* FIXME */
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
gdb_maybe_valid_type_p (SCM value)
|
||||
{
|
||||
return SCM_IMP (value) || scm_in_heap_p (value);
|
||||
return SCM_IMP (value); /* || scm_in_heap_p (value); */ /* FIXME: What to
|
||||
do? */
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
gdb_read (char *str)
|
||||
{
|
||||
#if 0
|
||||
SCM ans;
|
||||
int status = 0;
|
||||
RESET_STRING;
|
||||
/* Need to be restrictive about what to read? */
|
||||
if (SCM_GC_P)
|
||||
if (1) /* (SCM_GC_P) */ /* FIXME */
|
||||
{
|
||||
char *p;
|
||||
for (p = str; *p != '\0'; ++p)
|
||||
|
|
@ -207,6 +217,9 @@ exit:
|
|||
remark_port (gdb_input_port);
|
||||
SCM_END_FOREIGN_BLOCK;
|
||||
return status;
|
||||
#else
|
||||
abort ();
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
*/
|
||||
|
||||
|
||||
#if 0 /* FIXME: Not re-implemented for Boehm's GC. */
|
||||
|
||||
/* This is an implementation of guardians as described in
|
||||
* R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
|
||||
|
|
@ -351,3 +352,5 @@ scm_init_guardians ()
|
|||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -215,7 +215,8 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
|
|||
return 1;
|
||||
}
|
||||
|
||||
#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
|
||||
/* FIXME */
|
||||
#define UNMARKED_CELL_P(x) 0 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) */
|
||||
|
||||
/* keep track of hash tables that need to shrink after scan */
|
||||
static SCM to_rehash = SCM_EOL;
|
||||
|
|
@ -224,6 +225,7 @@ static SCM to_rehash = SCM_EOL;
|
|||
void
|
||||
scm_i_scan_weak_hashtables ()
|
||||
{
|
||||
#if 0 /* FIXME */
|
||||
SCM *next = &weak_hashtables;
|
||||
SCM h = *next;
|
||||
while (!scm_is_null (h))
|
||||
|
|
@ -252,6 +254,7 @@ scm_i_scan_weak_hashtables ()
|
|||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
||||
static void *
|
||||
|
|
|
|||
|
|
@ -517,7 +517,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
scm_init_vectors ();
|
||||
scm_init_version ();
|
||||
scm_init_weaks ();
|
||||
scm_init_guardians ();
|
||||
/* scm_init_guardians (); */
|
||||
scm_init_vports ();
|
||||
scm_init_eval ();
|
||||
scm_init_evalext ();
|
||||
|
|
|
|||
|
|
@ -38,6 +38,9 @@
|
|||
#include "libguile/pairs.h"
|
||||
|
||||
|
||||
#include <gc/gc.h>
|
||||
|
||||
|
||||
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
|
||||
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
||||
scm_t_bits ccr, scm_t_bits cdr);
|
||||
|
|
@ -64,71 +67,16 @@ static
|
|||
#endif
|
||||
SCM_C_INLINE
|
||||
#endif
|
||||
|
||||
SCM
|
||||
scm_cell (scm_t_bits car, scm_t_bits cdr)
|
||||
{
|
||||
SCM z;
|
||||
SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
|
||||
SCM cell = SCM_PACK ((scm_t_bits) (GC_malloc (sizeof (scm_t_cell))));
|
||||
|
||||
if (scm_is_null (*freelist))
|
||||
z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
|
||||
else
|
||||
{
|
||||
z = *freelist;
|
||||
*freelist = SCM_FREE_CELL_CDR (*freelist);
|
||||
}
|
||||
SCM_GC_SET_CELL_WORD (cell, 0, car);
|
||||
SCM_GC_SET_CELL_WORD (cell, 1, cdr);
|
||||
|
||||
/*
|
||||
We update scm_cells_allocated from this function. If we don't
|
||||
update this explicitly, we will have to walk a freelist somewhere
|
||||
later on, which seems a lot more expensive.
|
||||
*/
|
||||
scm_cells_allocated += 1;
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (scm_debug_cell_accesses_p)
|
||||
{
|
||||
if (SCM_GC_MARK_P (z))
|
||||
{
|
||||
fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
|
||||
abort();
|
||||
}
|
||||
else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell)
|
||||
{
|
||||
fprintf(stderr, "cell from freelist is not a free cell.\n");
|
||||
abort();
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
Always set mark. Otherwise cells that are alloced before
|
||||
scm_debug_cell_accesses_p is toggled seem invalid.
|
||||
*/
|
||||
SCM_SET_GC_MARK (z);
|
||||
|
||||
/*
|
||||
TODO: figure out if this use of mark bits is valid with
|
||||
threading. What if another thread is doing GC at this point
|
||||
... ?
|
||||
*/
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
/* Initialize the type slot last so that the cell is ignored by the
|
||||
GC until it is completely initialized. This is only relevant
|
||||
when the GC can actually run during this code, which it can't
|
||||
since the GC only runs when all other threads are stopped.
|
||||
*/
|
||||
SCM_GC_SET_CELL_WORD (z, 1, cdr);
|
||||
SCM_GC_SET_CELL_WORD (z, 0, car);
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (scm_expensive_debug_cell_accesses_p )
|
||||
scm_i_expensive_validation_check (z);
|
||||
#endif
|
||||
|
||||
return z;
|
||||
return cell;
|
||||
}
|
||||
|
||||
#if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H
|
||||
|
|
@ -145,18 +93,8 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
|||
scm_t_bits ccr, scm_t_bits cdr)
|
||||
{
|
||||
SCM z;
|
||||
SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2);
|
||||
|
||||
if (scm_is_null (*freelist))
|
||||
z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist);
|
||||
else
|
||||
{
|
||||
z = *freelist;
|
||||
*freelist = SCM_FREE_CELL_CDR (*freelist);
|
||||
}
|
||||
|
||||
scm_cells_allocated += 2;
|
||||
|
||||
z = SCM_PACK ((scm_t_bits) (GC_malloc (2 * sizeof (scm_t_cell))));
|
||||
/* Initialize the type slot last so that the cell is ignored by the
|
||||
GC until it is completely initialized. This is only relevant
|
||||
when the GC can actually run during this code, which it can't
|
||||
|
|
@ -167,22 +105,6 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
|||
SCM_GC_SET_CELL_WORD (z, 3, cdr);
|
||||
SCM_GC_SET_CELL_WORD (z, 0, car);
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (scm_debug_cell_accesses_p)
|
||||
{
|
||||
if (SCM_GC_MARK_P (z))
|
||||
{
|
||||
fprintf(stderr,
|
||||
"scm_double_cell tried to allocate a marked cell.\n");
|
||||
abort();
|
||||
}
|
||||
}
|
||||
|
||||
/* see above. */
|
||||
SCM_SET_GC_MARK (z);
|
||||
|
||||
#endif
|
||||
|
||||
/* When this function is inlined, it's possible that the last
|
||||
SCM_GC_SET_CELL_WORD above will be adjacent to a following
|
||||
initialization of z. E.g., it occurred in scm_make_real. GCC
|
||||
|
|
|
|||
|
|
@ -791,7 +791,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
|
|||
{
|
||||
scm_puts ("#<unknown-", port);
|
||||
scm_puts (hdr, port);
|
||||
if (scm_in_heap_p (ptr))
|
||||
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
|
||||
{
|
||||
scm_puts (" (0x", port);
|
||||
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
|
||||
|
|
|
|||
|
|
@ -78,87 +78,6 @@ 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;
|
||||
|
||||
|
||||
/* Sweep statistics. */
|
||||
typedef struct scm_sweep_statistics
|
||||
{
|
||||
/* Number of cells "swept", i.e., visited during the sweep operation. */
|
||||
unsigned swept;
|
||||
|
||||
/* Number of cells collected during the sweep operation. This number must
|
||||
alsways be lower than or equal to SWEPT. */
|
||||
unsigned collected;
|
||||
} scm_t_sweep_statistics;
|
||||
|
||||
#define scm_i_sweep_statistics_init(_stats) \
|
||||
do \
|
||||
{ \
|
||||
(_stats)->swept = (_stats)->collected = 0; \
|
||||
} \
|
||||
while (0)
|
||||
|
||||
#define scm_i_sweep_statistics_sum(_sum, _addition) \
|
||||
do \
|
||||
{ \
|
||||
(_sum)->swept += (_addition).swept; \
|
||||
(_sum)->collected += (_addition).collected; \
|
||||
} \
|
||||
while (0)
|
||||
|
||||
|
||||
|
||||
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,
|
||||
scm_t_sweep_statistics sweep_stats);
|
||||
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))
|
||||
|
|
@ -183,103 +102,8 @@ int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist);
|
|||
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_i_init_card_freelist (scm_t_cell * card, SCM *free_list,scm_t_heap_segment*);
|
||||
int scm_i_sweep_card (scm_t_cell * card, SCM *free_list, scm_t_heap_segment*);
|
||||
void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg);
|
||||
char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
|
||||
|
||||
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,
|
||||
scm_t_sweep_statistics *sweep_stats);
|
||||
void scm_i_sweep_segment (scm_t_heap_segment *seg,
|
||||
scm_t_sweep_statistics *sweep_stats);
|
||||
|
||||
void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab);
|
||||
|
||||
|
||||
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,
|
||||
scm_t_sweep_statistics *sweep_stats);
|
||||
void scm_i_reset_segments (void);
|
||||
void scm_i_sweep_all_segments (char const *reason,
|
||||
scm_t_sweep_statistics *sweep_stats);
|
||||
SCM scm_i_all_segments_statistics (SCM hashtab);
|
||||
void scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist);
|
||||
|
||||
extern long int scm_i_deprecated_memory_return;
|
||||
|
||||
|
|
|
|||
|
|
@ -350,11 +350,17 @@ scm_struct_gc_init (void *dummy1 SCM_UNUSED,
|
|||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* During collection, this accumulates structures which are to be freed.
|
||||
*/
|
||||
SCM scm_i_structs_to_free;
|
||||
|
||||
static void *
|
||||
scm_free_structs (void *dummy1 SCM_UNUSED,
|
||||
void *dummy2 SCM_UNUSED,
|
||||
void *dummy3 SCM_UNUSED)
|
||||
{
|
||||
#if 0
|
||||
SCM newchain = scm_i_structs_to_free;
|
||||
do
|
||||
{
|
||||
|
|
@ -393,6 +399,7 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
|
|||
}
|
||||
while (!scm_is_null (newchain));
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
||||
|
|
|
|||
|
|
@ -203,7 +203,8 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
|
||||
#define UNMARKED_CELL_P(x) 1 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) *//*
|
||||
FIXME */
|
||||
|
||||
static SCM weak_vectors;
|
||||
|
||||
|
|
@ -321,6 +322,8 @@ scm_i_mark_weak_vectors_non_weaks ()
|
|||
static void
|
||||
scm_i_remove_weaks (SCM w)
|
||||
{
|
||||
return; /* FIXME */
|
||||
#if 0
|
||||
SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
|
||||
size_t n = SCM_I_WVECT_LENGTH (w);
|
||||
size_t i;
|
||||
|
|
@ -362,6 +365,7 @@ scm_i_remove_weaks (SCM w)
|
|||
#endif
|
||||
SCM_I_SET_WVECT_DELTA (w, delta);
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
||||
void
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue