mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-05 03:30:24 +02:00
Code Activity

* gc.h: add scm_debug_cells_gc_interval to public interface

Browse source 
* gc-card.c ("sweep_card"): set scm_gc_running while sweeping.

* gc.c (scm_i_expensive_validation_check): separate expensive
validation checks from cheap ones.
This commit is contained in:
Han-Wen Nienhuys 2002-08-08 19:47:31 +00:00
parent 00706edc1d
commit eab1b25970
12 changed files with 179 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

6
NEWS
View file

@ -142,9 +142,9 @@ cause aborts in long running programs.
The new functions are more symmetrical and do not need cooperation
from smob free routines, among other improvements.
The new functions are scm_malloc, scm_realloc, scm_strdup,
scm_strndup, scm_gc_malloc, scm_gc_calloc, scm_gc_realloc, scm_gc_free,
scm_gc_register_collectable_memory, and
The new functions are scm_malloc, scm_realloc, scm_calloc, scm_strdup,
scm_strndup, scm_gc_malloc, scm_gc_calloc, scm_gc_realloc,
scm_gc_free, scm_gc_register_collectable_memory, and
scm_gc_unregister_collectable_memory. Refer to the manual for more
details and for upgrading instructions.

17
doc/ref/scheme-memory.texi
View file

@ -76,6 +76,7 @@ For really specialized needs, take at look at
@code{scm_gc_unregister_collectable_memory}.
@deftypefn {C Function} void *scm_malloc (size_t @var{size})
@deftypefnx {C Function} void *scm_calloc (size_t @var{size})
Allocate @var{size} bytes of memory and return a pointer to it. When
@var{size} is 0, return @code{NULL}. When not enough memory is
available, signal an error. This function runs the GC to free up some
@ -85,6 +86,9 @@ The memory is allocated by the libc @code{malloc} function and can be
freed with @code{free}. There is no @code{scm_free} function to go
with @code{scm_malloc} to make it easier to pass memory back and forth
between different modules.
The function @code{scm_calloc} is similar to @code{scm_malloc}, but
initializes the block of memory to zero as well.
@end deftypefn
@deftypefn {C Function} void *scm_realloc (void *@var{mem}, size_t @var{new_size})
@ -98,6 +102,9 @@ When not enough memory is available, signal an error. This function
runs the GC to free up some memory when it deems it appropriate.
@end deftypefn
@deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what})
Informs the GC that the memory at @var{mem} of size @var{size} can
potentially be freed during a GC. That is, announce that @var{mem} is
@ -127,12 +134,14 @@ much less efficiently than it could.
@deftypefn {C Function} void *scm_gc_malloc (size_t @var{size}, const char *@var{what})
@deftypefnx {C Function} void *scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
Like @code{scm_malloc} or @code{scm_realloc}, but also call
@code{scm_gc_register_collectable_memory}. Note that you need to pass
the old size of a reallocated memory block as well. See below for a
motivation.
@deftypefnx {C Function} void *scm_gc_calloc (size_t @var{size}, const char *@var{what})
Like @code{scm_malloc}, @code{scm_realloc} or @code{scm_calloc}, but
also call @code{scm_gc_register_collectable_memory}. Note that you
need to pass the old size of a reallocated memory block as well. See
below for a motivation.
@end deftypefn
@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.

9
libguile/ChangeLog
View file

@ -1,3 +1,12 @@
2002-08-08 Han-Wen Nienhuys <hanwen@cs.uu.nl>
* gc.h: add scm_debug_cells_gc_interval to public interface
* gc-card.c ("sweep_card"): set scm_gc_running while sweeping.
* gc.c (scm_i_expensive_validation_check): separate expensive
validation checks from cheap ones.
2002-08-06 Han-Wen Nienhuys <hanwen@cs.uu.nl>
* read.c (scm_input_error): new function: give meaningful error

16
libguile/gc-card.c
View file

@ -86,12 +86,13 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, int span)
int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
int free_count = 0;
++ scm_gc_running_p;
/*
I tried something fancy with shifting by one bit every word from
the bitvec in turn, but it wasn't any faster, but quite bit
hairier.
*/
for (p += offset; p < end; p += span, offset += span)
{
SCM scmptr = PTR2SCM(p);
@ -273,6 +274,8 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, int span)
*free_list = PTR2SCM (p);
free_count ++;
}
--scm_gc_running_p;
return free_count;
}
#undef FUNC_NAME
@ -301,6 +304,7 @@ scm_init_card_freelist (scm_t_cell * card, SCM *free_list, int span)
}
#if 0
/*
These functions are meant to be called from GDB as a debug aid.
@ -318,6 +322,16 @@ typedef struct scm_t_list_cell_struct {
struct scm_t_list_cell_struct * cdr;
} scm_t_list_cell;
typedef struct scm_t_double_cell
{
scm_t_bits word_0;
scm_t_bits word_1;
scm_t_bits word_2;
scm_t_bits word_3;
} scm_t_double_cell;
int
scm_gc_marked_p (SCM obj)
{

22
libguile/gc-mark.c
View file

@ -83,9 +83,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include <unistd.h>
#endif
#ifdef __ia64__
# define SCM_MARK_BACKING_STORE() do { \
ucontext_t ctx; \
@ -101,6 +98,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
# define SCM_MARK_BACKING_STORE()
#endif
/*
Entry point for this file.
*/
@ -108,10 +106,10 @@ void
scm_mark_all (void)
{
long j;
scm_i_clear_mark_space ();
#ifndef USE_THREADS
/* Mark objects on the C stack. */
@ -157,12 +155,14 @@ scm_mark_all (void)
}
}
}
/* 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
@ -171,7 +171,6 @@ scm_mark_all (void)
/* {Mark/Sweep}
*/
/*
Mark an object precisely, then recurse.
*/
@ -182,7 +181,9 @@ scm_gc_mark (SCM ptr)
return ;
if (SCM_GC_MARK_P (ptr))
return;
{
return;
}
SCM_SET_GC_MARK (ptr);
scm_gc_mark_dependencies (ptr);
@ -475,9 +476,12 @@ gc_mark_loop:
}
if (SCM_GC_MARK_P (ptr))
{
return;
}
SCM_SET_GC_MARK (ptr);
goto scm_mark_dependencies_again;
}
@ -485,6 +489,7 @@ gc_mark_loop:
/* Mark a region conservatively */
void
scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
@ -570,4 +575,3 @@ scm_gc_init_mark(void)
#endif
}

2
libguile/gc-segment.c
View file

@ -546,6 +546,7 @@ scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_erro
}
void
scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *freelist)
{
@ -568,4 +569,3 @@ scm_i_make_initial_segment (size_t init_heap_size, scm_t_cell_type_statistics *f
freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
/ 100);
}

173
libguile/gc.c
View file

@ -90,53 +90,87 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
unsigned int scm_gc_running_p = 0;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
/* Set this to != 0 if every cell that is accessed shall be checked:
*/
unsigned int scm_debug_cell_accesses_p = 1;
int scm_debug_cell_accesses_p = 0;
int scm_expensive_debug_cell_accesses_p = 0;
/* Set this to 0 if no additional gc's shall be performed, otherwise set it to
* the number of cell accesses after which a gc shall be called.
*/
static unsigned int debug_cells_gc_interval = 0;
int scm_debug_cells_gc_interval = 0;
/* Assert that the given object is a valid reference to a valid cell. This
* test involves to determine whether the object is a cell pointer, whether
* this pointer actually points into a heap segment and whether the cell
* pointed to is not a free cell. Further, additional garbage collections may
* get executed after a user defined number of cell accesses. This helps to
* find places in the C code where references are dropped for extremely short
* periods.
/*
Global variable, so you can switch it off at runtime by setting
scm_i_cell_validation_already_running.
*/
int scm_i_cell_validation_already_running ;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
/*
Assert that the given object is a valid reference to a valid cell. This
test involves to determine whether the object is a cell pointer, whether
this pointer actually points into a heap segment and whether the cell
pointed to is not a free cell. Further, additional garbage collections may
get executed after a user defined number of cell accesses. This helps to
find places in the C code where references are dropped for extremely short
periods.
*/
void
scm_i_expensive_validation_check (SCM cell)
{
if (!scm_in_heap_p (cell))
{
fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
(unsigned long) SCM_UNPACK (cell));
abort ();
}
/* If desired, perform additional garbage collections after a user
* defined number of cell accesses.
*/
if (scm_debug_cells_gc_interval)
{
static unsigned int counter = 0;
if (counter != 0)
{
--counter;
}
else
{
counter = scm_debug_cells_gc_interval;
scm_igc ("scm_assert_cell_valid");
}
}
}
void
scm_assert_cell_valid (SCM cell)
{
static unsigned int already_running = 0;
if (!already_running)
if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
{
already_running = 1; /* set to avoid recursion */
scm_i_cell_validation_already_running = 1; /* set to avoid recursion */
/*
During GC, no user-code should be run, and the guile core should
use non-protected accessors.
*/
During GC, no user-code should be run, and the guile core
should use non-protected accessors.
*/
if (scm_gc_running_p)
abort();
return;
/*
Only scm_in_heap_p is wildly expensive.
*/
if (scm_debug_cell_accesses_p)
if (!scm_in_heap_p (cell))
{
fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
(unsigned long) SCM_UNPACK (cell));
abort ();
}
Only scm_in_heap_p and rescanning the heap is wildly
expensive.
*/
if (scm_expensive_debug_cell_accesses_p)
scm_i_expensive_validation_check (cell);
if (!SCM_GC_MARK_P (cell))
{
@ -148,54 +182,47 @@ scm_assert_cell_valid (SCM cell)
abort ();
}
/* If desired, perform additional garbage collections after a user
* defined number of cell accesses.
*/
if (scm_debug_cell_accesses_p && debug_cells_gc_interval)
{
static unsigned int counter = 0;
if (counter != 0)
{
--counter;
}
else
{
counter = debug_cells_gc_interval;
scm_igc ("scm_assert_cell_valid");
}
}
already_running = 0; /* re-enable */
scm_i_cell_validation_already_running = 0; /* re-enable */
}
}
SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
(SCM flag),
"If @var{flag} is @code{#f}, cell access checking is disabled.\n"
"If @var{flag} is @code{#t}, cell access checking is enabled,\n"
"If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
"but no additional calls to garbage collection are issued.\n"
"If @var{flag} is a number, cell access checking is enabled,\n"
"If @var{flag} is a number, strict cell access checking is enabled,\n"
"with an additional garbage collection after the given\n"
"number of cell accesses.\n"
"This procedure only exists when the compile-time flag\n"
"@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
#define FUNC_NAME s_scm_set_debug_cell_accesses_x
{
if (SCM_FALSEP (flag)) {
scm_debug_cell_accesses_p = 0;
} else if (SCM_EQ_P (flag, SCM_BOOL_T)) {
debug_cells_gc_interval = 0;
scm_debug_cell_accesses_p = 1;
} else if (SCM_INUMP (flag)) {
long int f = SCM_INUM (flag);
if (f <= 0) SCM_OUT_OF_RANGE (1, flag);
debug_cells_gc_interval = f;
scm_debug_cell_accesses_p = 1;
} else {
SCM_WRONG_TYPE_ARG (1, flag);
}
if (SCM_FALSEP (flag))
{
scm_debug_cell_accesses_p = 0;
}
else if (SCM_EQ_P (flag, SCM_BOOL_T))
{
scm_debug_cells_gc_interval = 0;
scm_debug_cell_accesses_p = 1;
scm_expensive_debug_cell_accesses_p = 0;
}
else if (SCM_INUMP (flag))
{
long int f = SCM_INUM (flag);
if (f <= 0)
SCM_OUT_OF_RANGE (1, flag);
scm_debug_cells_gc_interval = f;
scm_debug_cell_accesses_p = 1;
scm_expensive_debug_cell_accesses_p = 1;
}
else
{
SCM_WRONG_TYPE_ARG (1, flag);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -497,6 +524,8 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
--scm_ints_disabled;
*free_cells = SCM_FREE_CELL_CDR (cell);
return cell;
}
@ -525,7 +554,7 @@ scm_igc (const char *what)
/* During the critical section, only the current thread may run. */
SCM_CRITICAL_SECTION_START;
if (!scm_stack_base || scm_block_gc)
if (!scm_root || !scm_stack_base || scm_block_gc)
{
--scm_gc_running_p;
return;
@ -585,17 +614,15 @@ scm_igc (const char *what)
SCM_CRITICAL_SECTION_END;
scm_c_hook_run (&scm_after_gc_c_hook, 0);
--scm_gc_running_p;
/*
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 Protection Helper Functions}
*/
@ -939,7 +966,7 @@ mark_gc_async (void * hook_data SCM_UNUSED,
* after-gc-hook.
*/
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (debug_cells_gc_interval == 0)
if (scm_debug_cells_gc_interval == 0)
scm_system_async_mark (gc_async);
#else
scm_system_async_mark (gc_async);

16
libguile/gc.h
View file

@ -218,6 +218,7 @@ typedef unsigned long scm_t_c_bvec_long;
#define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 (x, t)
/* Freelists consist of linked cells where the type entry holds the value
* scm_tc_free_cell and the second entry holds a pointer to the next cell of
* the freelist. Due to this structure, freelist cells are not cons cells
@ -245,7 +246,11 @@ typedef unsigned long scm_t_c_bvec_long;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
SCM_API unsigned int scm_debug_cell_accesses_p;
/* Set this to != 0 if every cell that is accessed shall be checked:
*/
SCM_API int scm_debug_cell_accesses_p;
SCM_API int scm_expensive_debug_cell_accesses_p;
SCM_API int scm_debug_cells_gc_interval ;
#endif
SCM_API int scm_block_gc;
@ -274,10 +279,11 @@ SCM_API size_t scm_max_segment_size;
Deprecated scm_freelist, scm_master_freelist.
No warning; this is not a user serviceable part.
*/
SCM_API SCM scm_i_freelist;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
SCM_API SCM scm_i_freelist2;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
extern SCM scm_i_freelist;
extern struct scm_t_cell_type_statistics scm_i_master_freelist;
extern SCM scm_i_freelist2;
extern struct scm_t_cell_type_statistics scm_i_master_freelist2;
SCM_API unsigned long scm_gc_cells_swept;
SCM_API unsigned long scm_gc_cells_collected;

5
libguile/inline.c
View file

@ -39,10 +39,13 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#include <stdio.h>
#include "libguile/scmconfig.h"
#ifndef HAVE_INLINE
#define HAVE_INLINE
#endif
#define EXTERN_INLINE
#undef SCM_INLINE_H

13
libguile/inline.h
View file

@ -50,10 +50,6 @@
*/
#if (SCM_DEBUG_CELL_ACCESSES == 1)
#include <stdio.h>
#endif
#include "libguile/pairs.h"
#include "libguile/gc.h"
@ -64,8 +60,6 @@ SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
#ifdef HAVE_INLINE
#ifndef EXTERN_INLINE
#define EXTERN_INLINE extern inline
#endif
@ -74,6 +68,7 @@ extern unsigned scm_newcell2_count;
extern unsigned scm_newcell_count;
EXTERN_INLINE
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
@ -137,6 +132,10 @@ scm_cell (scm_t_bits car, scm_t_bits cdr)
#endif
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (scm_expensive_debug_cell_accesses_p )
scm_i_expensive_validation_check (z);
#endif
return z;
}
@ -201,5 +200,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
return z;
}
#endif
#endif

3
libguile/private-gc.h
View file

@ -236,5 +236,6 @@ 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

2
libguile/procs.c
View file

@ -139,7 +139,7 @@ scm_mark_subr_table ()
long i;
for (i = 0; i < scm_subr_table_size; ++i)
{
SCM_SET_GC_MARK (scm_subr_table[i].name);
scm_gc_mark (scm_subr_table[i].name);
if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
scm_gc_mark (*scm_subr_table[i].generic);
if (SCM_NIMP (scm_subr_table[i].properties))