mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Removed useless files; beautified `libguile/Makefile.am'.

Browse source 
* libguile/Makefile.am: Beautified backslashification (complements `patch-1').

git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-20
This commit is contained in:
Ludovic Courtes 2006-05-18 08:08:32 +00:00 • committed by Ludovic Courtès
parent 080ecf3f7b
commit 296278188e
6 changed files with 7 additions and 3695 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/Makefile.am
View file

@ -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-malloc.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 \
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-malloc.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 \
@ -153,7 +153,7 @@ EXTRA_libguile_la_SOURCES = _scm.h \
inet_aton.c memmove.c putenv.c strerror.c \
dynl.c regex-posix.c \
filesys.c posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
debug-malloc.c mkstemp.c \
win32-uname.c win32-dirent.c win32-socket.c
## delete guile-snarf.awk from the installation bindir, in case it's

485
libguile/gc-card.c
View file

@ -1,485 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#include <stdio.h>
#include <gmp.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/numbers.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
#include "libguile/private-gc.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"
#include "libguile/srfi-4.h"
#include "libguile/private-gc.h"
long int scm_i_deprecated_memory_return;
/* During collection, this accumulates structures which are to be freed.
*/
SCM scm_i_structs_to_free;
/*
Init all the free cells in CARD, prepending to *FREE_LIST.
Return: number of free cells found in this card.
It would be cleaner to have a separate function sweep_value(), but
that is too slow (functions with switch statements can't be
inlined).
NOTE:
This function is quite efficient. However, for many types of cells,
allocation and a de-allocation involves calling malloc() and
free().
This is costly for small objects (due to malloc/free overhead.)
(should measure this).
It might also be bad for threads: if several threads are allocating
strings concurrently, then mallocs for both threads may have to
fiddle with locks.
It might be interesting to add a separate memory pool for small
objects to each freelist.
--hwn.
*/
int
scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg)
#define FUNC_NAME "sweep_card"
{
scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
int span = seg->span;
int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
int free_count = 0;
/*
I tried something fancy with shifting by one bit every word from
the bitvec in turn, but it wasn't any faster, but quite a bit
hairier.
*/
for (p += offset; p < end; p += span, offset += span)
{
SCM scmptr = PTR2SCM (p);
if (SCM_C_BVEC_GET (bitvec, offset))
continue;
switch (SCM_TYP7 (scmptr))
{
case scm_tcs_struct:
/* The card can be swept more than once. Check that it's
* the first time!
*/
if (!SCM_STRUCT_GC_CHAIN (scmptr))
{
/* Structs need to be freed in a special order.
* This is handled by GC C hooks in struct.c.
*/
SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
scm_i_structs_to_free = scmptr;
}
continue;
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
case scm_tcs_closures:
case scm_tc7_pws:
break;
case scm_tc7_wvect:
case scm_tc7_vector:
scm_i_vector_free (scmptr);
break;
#ifdef CCLO
case scm_tc7_cclo:
scm_gc_free (SCM_CCLO_BASE (scmptr),
SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
"compiled closure");
break;
#endif
case scm_tc7_number:
switch SCM_TYP16 (scmptr)
{
case scm_tc16_real:
break;
case scm_tc16_big:
mpz_clear (SCM_I_BIG_MPZ (scmptr));
/* nothing else to do here since the mpz is in a double cell */
break;
case scm_tc16_complex:
scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
"complex");
break;
case scm_tc16_fraction:
/* nothing to do here since the num/denum of a fraction
are proper SCM objects themselves. */
break;
}
break;
case scm_tc7_string:
scm_i_string_free (scmptr);
break;
case scm_tc7_stringbuf:
scm_i_stringbuf_free (scmptr);
break;
case scm_tc7_symbol:
scm_i_symbol_free (scmptr);
break;
case scm_tc7_variable:
break;
case scm_tcs_subrs:
/* the various "subrs" (primitives) are never freed */
continue;
case scm_tc7_port:
if SCM_OPENP (scmptr)
{
int k = SCM_PTOBNUM (scmptr);
size_t mm;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (!(k < scm_numptob))
{
fprintf (stderr, "undefined port type");
abort();
}
#endif
/* Keep "revealed" ports alive. */
if (scm_revealed_count (scmptr) > 0)
continue;
/* Yes, I really do mean scm_ptobs[k].free */
/* rather than ftobs[k].close. .close */
/* is for explicit CLOSE-PORT by user */
mm = scm_ptobs[k].free (scmptr);
if (mm != 0)
{
#if SCM_ENABLE_DEPRECATED == 1
scm_c_issue_deprecation_warning
("Returning non-0 from a port free function is "
"deprecated. Use scm_gc_free et al instead.");
scm_c_issue_deprecation_warning_fmt
("(You just returned non-0 while freeing a %s.)",
SCM_PTOBNAME (k));
scm_i_deprecated_memory_return += mm;
#else
abort ();
#endif
}
SCM_SETSTREAM (scmptr, 0);
scm_remove_from_port_table (scmptr);
scm_gc_ports_collected++;
SCM_CLR_PORT_OPEN_FLAG (scmptr);
}
break;
case scm_tc7_smob:
switch SCM_TYP16 (scmptr)
{
case scm_tc_free_cell:
free_count --;
break;
default:
{
int k;
k = SCM_SMOBNUM (scmptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (!(k < scm_numsmob))
{
fprintf (stderr, "undefined smob type");
abort();
}
#endif
if (scm_smobs[k].free)
{
size_t mm;
mm = scm_smobs[k].free (scmptr);
if (mm != 0)
{
#if SCM_ENABLE_DEPRECATED == 1
scm_c_issue_deprecation_warning
("Returning non-0 from a smob free function is "
"deprecated. Use scm_gc_free et al instead.");
scm_c_issue_deprecation_warning_fmt
("(You just returned non-0 while freeing a %s.)",
SCM_SMOBNAME (k));
scm_i_deprecated_memory_return += mm;
#else
abort();
#endif
}
}
break;
}
}
break;
default:
fprintf (stderr, "unknown type");
abort();
}
SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
*free_list = scmptr;
free_count ++;
}
return free_count;
}
#undef FUNC_NAME
/*
Like sweep, but no complicated logic to do the sweeping.
*/
int
scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
scm_t_heap_segment*seg)
{
int span = seg->span;
scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
scm_t_cell *p = end - span;
scm_t_c_bvec_long * bvec_ptr = (scm_t_c_bvec_long* ) seg->bounds[1];
int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
/*
ASSUMPTION: n_header_cells <= 2.
*/
for (; p > card; p -= span)
{
const SCM scmptr = PTR2SCM (p);
SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
*free_list = scmptr;
}
return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
}
void
scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
{
scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
int span = seg->span;
int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
if (!bitvec)
/* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
return;
for (p += offset; p < end; p += span, offset += span)
{
scm_t_bits tag = -1;
SCM scmptr = PTR2SCM (p);
if (!SCM_C_BVEC_GET (bitvec, offset))
continue;
tag = SCM_TYP7 (scmptr);
if (tag == scm_tc7_smob)
{
tag = SCM_TYP16(scmptr);
}
else
switch (tag)
{
case scm_tcs_cons_imcar:
tag = scm_tc2_int;
break;
case scm_tcs_cons_nimcar:
tag = scm_tc3_cons;
break;
case scm_tcs_struct:
tag = scm_tc3_struct;
break;
case scm_tcs_closures:
tag = scm_tc3_closure;
break;
case scm_tcs_subrs:
tag = scm_tc7_asubr;
break;
}
{
SCM tag_as_scm = scm_from_int (tag);
SCM current = scm_hashq_ref (hashtab, tag_as_scm, SCM_I_MAKINUM (0));
scm_hashq_set_x (hashtab, tag_as_scm,
scm_from_int (scm_to_int (current) + 1));
}
}
}
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;
}
#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
typedef struct scm_dbg_t_list_cell {
scm_t_bits car;
struct scm_dbg_t_list_cell * cdr;
} scm_dbg_t_list_cell;
typedef struct scm_dbg_t_double_cell {
scm_t_bits word_0;
scm_t_bits word_1;
scm_t_bits word_2;
scm_t_bits word_3;
} scm_dbg_t_double_cell;
int scm_dbg_gc_marked_p (SCM obj);
scm_t_cell * scm_dbg_gc_get_card (SCM obj);
scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
int
scm_dbg_gc_marked_p (SCM obj)
{
if (!SCM_IMP (obj))
return SCM_GC_MARK_P(obj);
else
return 0;
}
scm_t_cell *
scm_dbg_gc_get_card (SCM obj)
{
if (!SCM_IMP (obj))
return SCM_GC_CELL_CARD(obj);
else
return NULL;
}
scm_t_c_bvec_long *
scm_dbg_gc_get_bvec (SCM obj)
{
if (!SCM_IMP (obj))
return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
else
return NULL;
}
#endif

192
libguile/gc-freelist.c
View file

@ -1,192 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#include <assert.h>
#include <stdio.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;
}
#undef FUNC_NAME
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,
scm_t_sweep_statistics sweep_stats)
{
/* 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) sweep_stats.collected);
#ifdef DEBUGINFO
fprintf (stderr, " after GC = %lu, delta = %ld\n",
(unsigned 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)
{
if (min_yield < 1)
min_yield = 1;
if (min_yield > 99)
min_yield = 99;
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)
{
int init_heap_size_1
= scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1);
int init_heap_size_2
= scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);
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);
if (scm_max_segment_size <= 0)
scm_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;
}

511
libguile/gc-mark.c
View file

@ -1,511 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#if HAVE_CONFIG_H
# include <config.h>
#endif
#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"
#include "libguile/guardians.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
/*
Entry point for this file.
*/
void
scm_mark_all (void)
{
long j;
int loops;
scm_i_init_weak_vectors_for_gc ();
scm_i_init_guardians_for_gc ();
scm_i_clear_mark_space ();
/* Mark every thread's stack and registers */
scm_threads_mark_stacks ();
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_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
{
SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i);
for (; !scm_is_null (l); l = SCM_CDR (l))
{
SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l)));
scm_gc_mark (*p);
}
}
}
scm_mark_subr_table ();
loops = 0;
while (1)
{
int again;
loops++;
/* Mark the non-weak references of weak vectors. For a weak key
alist vector, this would mark the values for keys that are
marked. We need to do this in a loop until everything
settles down since the newly marked values might be keys in
other weak key alist vectors, for example.
*/
again = scm_i_mark_weak_vectors_non_weaks ();
if (again)
continue;
/* Now we scan all marked guardians and move all unmarked objects
from the accessible to the inaccessible list.
*/
scm_i_identify_inaccessible_guardeds ();
/* When we have identified all inaccessible objects, we can mark
them.
*/
again = scm_i_mark_inaccessible_guardeds ();
/* This marking might have changed the situation for weak vectors
and might have turned up new guardians that need to be processed,
so we do it all over again.
*/
if (again)
continue;
/* Nothing new marked in this round, we are done.
*/
break;
}
/* fprintf (stderr, "%d loops\n", loops); */
/* Remove all unmarked entries from the weak vectors.
*/
scm_i_remove_weaks_from_weak_vectors ();
/* Bring hashtables upto date.
*/
scm_i_scan_weak_hashtables ();
}
/* {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.
Prefetching:
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
(Some time later.)
Tried this with GCC 3.1.1 -- the time differences are barely measurable.
Perhaps this would work better with an explicit markstack?
*/
void
scm_gc_mark_dependencies (SCM p)
#define FUNC_NAME "scm_gc_mark_dependencies"
{
register long i;
register SCM ptr;
SCM 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_i_symbol_length (layout);
const char *fields_desc = scm_i_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_SIMPLE_VECTOR_LENGTH (ptr);
if (i == 0)
break;
while (--i > 0)
{
SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
if (SCM_NIMP (elt))
scm_gc_mark (elt);
}
ptr = SCM_SIMPLE_VECTOR_REF (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
case scm_tc7_string:
ptr = scm_i_string_mark (ptr);
goto gc_mark_loop;
case scm_tc7_stringbuf:
ptr = scm_i_stringbuf_mark (ptr);
goto gc_mark_loop;
case scm_tc7_number:
if (SCM_TYP16 (ptr) == scm_tc16_fraction)
{
scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
ptr = SCM_CELL_OBJECT_2 (ptr);
goto gc_mark_loop;
}
break;
case scm_tc7_wvect:
scm_i_mark_weak_vector (ptr);
break;
case scm_tc7_symbol:
ptr = scm_i_symbol_mark (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))
{
fprintf (stderr, "undefined port type");
abort();
}
#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;
default:
i = SCM_SMOBNUM (ptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (!(i < scm_numsmob))
{
fprintf (stderr, "undefined smob type");
abort();
}
#endif
if (scm_smobs[i].mark)
{
ptr = (scm_smobs[i].mark) (ptr);
goto gc_mark_loop;
}
else
return;
}
break;
default:
fprintf (stderr, "unknown type");
abort();
}
/*
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)
{
fprintf (stderr, "rogue pointer in heap");
abort();
}
}
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
}

561
libguile/gc-segment.c
View file

@ -1,561 +0,0 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#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"
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;
}
void
scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
{
scm_t_cell *p = seg->bounds[0];
while (p < seg->bounds[1])
{
scm_i_card_statistics (p, tab, seg);
p += SCM_GC_CARD_N_CELLS;
}
}
/*
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 calloc 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];
/*
Don't init the mem or the bitvector. 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);
}
/* Sweep cards from SEG until we've gathered THRESHOLD cells. On return,
*CELLS_SWEPT contains the number of cells that have been visited and
*CELLS_COLLECTED contains the number of cells actually collected. A
freelist is returned, potentially empty. */
SCM
scm_i_sweep_some_cards (scm_t_heap_segment *seg,
scm_t_sweep_statistics *sweep_stats)
{
SCM cells = SCM_EOL;
int threshold = 512;
int collected = 0;
int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* )
= (seg->first_time) ? &scm_i_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);
next_free += SCM_GC_CARD_N_CELLS;
cards_swept ++;
}
sweep_stats->swept = cards_swept * seg->span
* (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
if (!seg->first_time)
{
/* scm_cells_allocated -= collected * seg->span; */
sweep_stats->collected = collected * seg->span;
}
else
sweep_stats->collected = 0;
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.
FIXME: if you do scm_i_sweep_segment(), and then allocate from this
segment again, the statistics are off.
*/
void
scm_i_sweep_segment (scm_t_heap_segment *seg,
scm_t_sweep_statistics *sweep_stats)
{
scm_t_sweep_statistics sweep;
scm_t_cell * p = seg->next_free_card;
scm_i_sweep_statistics_init (sweep_stats);
while (scm_i_sweep_some_cards (seg, &sweep) != SCM_EOL)
scm_i_sweep_statistics_sum (sweep_stats, sweep);
seg->next_free_card =p;
}
void
scm_i_sweep_all_segments (char const *reason,
scm_t_sweep_statistics *sweep_stats)
{
unsigned i= 0;
scm_i_sweep_statistics_init (sweep_stats);
for (i = 0; i < scm_i_heap_segment_table_size; i++)
{
scm_t_sweep_statistics sweep;
scm_i_sweep_segment (scm_i_heap_segment_table[i], &sweep);
scm_i_sweep_statistics_sum (sweep_stats, sweep);
}
}
/*
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++;
/*
We insert a new entry; if that happens to be before the
"current" segment of a freelist, we must move the freelist index
as well.
*/
if (scm_i_master_freelist.heap_segment_idx >= i)
scm_i_master_freelist.heap_segment_idx ++;
if (scm_i_master_freelist2.heap_segment_idx >= i)
scm_i_master_freelist2.heap_segment_idx ++;
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,
scm_t_sweep_statistics *sweep_stats)
{
int i = fl->heap_segment_idx;
SCM collected = SCM_EOL;
scm_i_sweep_statistics_init (sweep_stats);
if (i == -1)
i++;
for (;
i < scm_i_heap_segment_table_size; i++)
{
scm_t_sweep_statistics sweep;
if (scm_i_heap_segment_table[i]->freelist != fl)
continue;
collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i],
&sweep);
scm_i_sweep_statistics_sum (sweep_stats, sweep);
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];
}
}
/*
Return a hashtab with counts of live objects, with tags as keys.
*/
SCM
scm_i_all_segments_statistics (SCM tab)
{
int i = 0;
for (; i < scm_i_heap_segment_table_size; i++)
{
scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
scm_i_heap_segment_statistics (seg, tab);
}
return tab;
}
/*
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 (!SCM_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;
{
/* 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)
*/
float f = freelist->min_yield_fraction / 100.0;
float h = SCM_HEAP_SIZE;
float min_cells = (f * h - scm_gc_cells_collected) / (1.0 - 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
if (len < min_cells)
len = (unsigned long) 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;
if (len < SCM_MIN_HEAP_SEG_SIZE)
len = SCM_MIN_HEAP_SEG_SIZE;
{
scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
/* Allocate with decaying ambition. */
while (len >= SCM_MIN_HEAP_SEG_SIZE)
{
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 (int init_heap_size, scm_t_cell_type_statistics *freelist)
{
scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
if (init_heap_size < 1)
{
init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1;
}
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);
}

1939
libguile/gc_os_dep.c
View file

File diff suppressed because it is too large Load diff