mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
516 lines
12 KiB
C
516 lines
12 KiB
C
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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"
|
||
|
||
#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;
|
||
|
||
|
||
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_BUCKETS (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);
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
/* FIXME: we should have a means to register C functions to be run
|
||
* in different phases of GC
|
||
*/
|
||
scm_mark_subr_table ();
|
||
}
|
||
|
||
/* {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_VECTOR_LENGTH (ptr);
|
||
if (i == 0)
|
||
break;
|
||
while (--i > 0)
|
||
{
|
||
if (SCM_NIMP (SCM_VELTS (ptr)[i]))
|
||
scm_gc_mark (SCM_VELTS (ptr)[i]);
|
||
}
|
||
ptr = SCM_VELTS (ptr)[0];
|
||
goto gc_mark_loop;
|
||
#ifdef CCLO
|
||
case scm_tc7_cclo:
|
||
{
|
||
size_t i = SCM_CCLO_LENGTH (ptr);
|
||
size_t j;
|
||
for (j = 1; j != i; ++j)
|
||
{
|
||
SCM obj = SCM_CCLO_REF (ptr, j);
|
||
if (!SCM_IMP (obj))
|
||
scm_gc_mark (obj);
|
||
}
|
||
ptr = SCM_CCLO_REF (ptr, 0);
|
||
goto gc_mark_loop;
|
||
}
|
||
#endif
|
||
|
||
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_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
|
||
scm_weak_vectors = ptr;
|
||
if (SCM_IS_WHVEC_ANY (ptr))
|
||
{
|
||
long x;
|
||
long len;
|
||
int weak_keys;
|
||
int weak_values;
|
||
|
||
len = SCM_VECTOR_LENGTH (ptr);
|
||
weak_keys = SCM_WVECT_WEAK_KEY_P (ptr);
|
||
weak_values = SCM_WVECT_WEAK_VALUE_P (ptr);
|
||
|
||
for (x = 0; x < len; ++x)
|
||
{
|
||
SCM alist;
|
||
alist = SCM_VELTS (ptr)[x];
|
||
|
||
/* mark everything on the alist except the keys or
|
||
* values, according to weak_values and weak_keys. */
|
||
while ( scm_is_pair (alist)
|
||
&& !SCM_GC_MARK_P (alist)
|
||
&& scm_is_pair (SCM_CAR (alist)))
|
||
{
|
||
SCM kvpair;
|
||
SCM next_alist;
|
||
|
||
kvpair = SCM_CAR (alist);
|
||
next_alist = SCM_CDR (alist);
|
||
/*
|
||
* Do not do this:
|
||
* SCM_SET_GC_MARK (alist);
|
||
* SCM_SET_GC_MARK (kvpair);
|
||
*
|
||
* It may be that either the key or value is protected by
|
||
* an escaped reference to part of the spine of this alist.
|
||
* If we mark the spine here, and only mark one or neither of the
|
||
* key and value, they may never be properly marked.
|
||
* This leads to a horrible situation in which an alist containing
|
||
* freelist cells is exported.
|
||
*
|
||
* So only mark the spines of these arrays last of all marking.
|
||
* If somebody confuses us by constructing a weak vector
|
||
* with a circular alist then we are hosed, but at least we
|
||
* won't prematurely drop table entries.
|
||
*/
|
||
if (!weak_keys)
|
||
scm_gc_mark (SCM_CAR (kvpair));
|
||
if (!weak_values)
|
||
scm_gc_mark (SCM_CDR (kvpair));
|
||
alist = next_alist;
|
||
}
|
||
if (SCM_NIMP (alist))
|
||
scm_gc_mark (alist);
|
||
}
|
||
}
|
||
break;
|
||
|
||
case scm_tc7_symbol:
|
||
ptr = scm_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
|
||
}
|
||
|