mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
485 lines
11 KiB
C
485 lines
11 KiB
C
/* 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
|