-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 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
*
* 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+#include <assert.h>
#include <stdio.h>
+#include <count-one-bits.h>
+
#include <gmp.h>
#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/deprecation.h"
#include "libguile/eval.h"
+#include "libguile/gc.h"
+#include "libguile/hashtab.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/private-gc.h"
#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/srfi-4.h"
+#include "libguile/stackchk.h"
+#include "libguile/stime.h"
#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-#include "libguile/hashtab.h"
+#include "libguile/struct.h"
#include "libguile/tags.h"
-#include "libguile/private-gc.h"
+#include "libguile/unif.h"
#include "libguile/validate.h"
-#include "libguile/deprecation.h"
-#include "libguile/gc.h"
-
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
#include "libguile/private-gc.h"
*/
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.
+ Return: FREE_COUNT, the number of cells collected. This is
+ typically the length of the *FREE_LIST, but for some special cases,
+ we do not actually free the cell. To make the numbers match up, we
+ do increase the FREE_COUNT.
- It would be cleaner to have a separate function sweep_value(), but
+ 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).
+ 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
--hwn.
*/
int
-scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg)
+scm_i_sweep_card (scm_t_cell *card, 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;
+ scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (card);
+ scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
+ scm_t_cell *p = card;
int span = seg->span;
- int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
- int free_count = 0;
-
- ++ scm_gc_running_p;
-
+ 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
SCM scmptr = PTR2SCM (p);
if (SCM_C_BVEC_GET (bitvec, offset))
continue;
-
+ free_count++;
switch (SCM_TYP7 (scmptr))
{
case scm_tcs_struct:
break;
case scm_tc7_wvect:
case scm_tc7_vector:
- {
- unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
- if (length > 0)
- {
- scm_gc_free (SCM_VECTOR_BASE (scmptr),
- length * sizeof (scm_t_bits),
- "vector");
- }
- break;
- }
+ scm_i_vector_free (scmptr);
+ break;
+
#ifdef CCLO
case scm_tc7_cclo:
scm_gc_free (SCM_CCLO_BASE (scmptr),
"compiled closure");
break;
#endif
-#if SCM_HAVE_ARRAYS
- case scm_tc7_bvect:
- {
- unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
- if (length > 0)
- {
- scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
- (sizeof (long)
- * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
- "vector");
- }
- }
- break;
- case scm_tc7_byvect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_svect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- scm_gc_free (SCM_UVECTOR_BASE (scmptr),
- (SCM_UVECTOR_LENGTH (scmptr)
- * scm_uniform_element_size (scmptr)),
- "vector");
- 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_gc_free (SCM_STRING_CHARS (scmptr),
- SCM_STRING_LENGTH (scmptr) + 1, "string");
+ scm_i_string_free (scmptr);
+ break;
+ case scm_tc7_stringbuf:
+ scm_i_stringbuf_free (scmptr);
break;
case scm_tc7_symbol:
- scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
- SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
+ scm_i_symbol_free (scmptr);
break;
case scm_tc7_variable:
break;
if (!(k < scm_numptob))
{
fprintf (stderr, "undefined port type");
- abort();
+ 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 */
}
SCM_SETSTREAM (scmptr, 0);
- scm_remove_from_port_table (scmptr);
- scm_gc_ports_collected++;
+ scm_i_remove_port (scmptr);
SCM_CLR_PORT_OPEN_FLAG (scmptr);
}
break;
switch SCM_TYP16 (scmptr)
{
case scm_tc_free_cell:
- 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;
default:
{
if (!(k < scm_numsmob))
{
fprintf (stderr, "undefined smob type");
- abort();
+ abort ();
}
#endif
if (scm_smobs[k].free)
SCM_SMOBNAME (k));
scm_i_deprecated_memory_return += mm;
#else
- abort();
+ abort ();
#endif
}
}
break;
default:
fprintf (stderr, "unknown type");
- abort();
+ abort ();
}
-
- SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
+ 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 ++;
}
-
- --scm_gc_running_p;
+
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)
+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 collected = 0;
+ 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;
+ bvec_ptr += idx * SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
/*
for (; p > card; p -= span)
{
const SCM scmptr = PTR2SCM (p);
- SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
+ SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
*free_list = scmptr;
+ collected ++;
+ }
+
+ return collected;
+}
+
+/*
+ Amount of cells marked in this cell, measured in 1-cells.
+ */
+int
+scm_i_card_marked_count (scm_t_cell *card, int span)
+{
+ scm_t_c_bvec_long* bvec = SCM_GC_CARD_BVEC (card);
+ scm_t_c_bvec_long* bvec_end = (bvec + SCM_GC_CARD_BVEC_SIZE_IN_LONGS);
+
+ int count = 0;
+ while (bvec < bvec_end)
+ {
+ count += count_one_bits_l (*bvec);
+ bvec ++;
+ }
+ return count * span;
+}
+
+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_tc7_number)
+ {
+ /* Record smobs and numbers under 16 bits of the tag, so the
+ different smob objects are distinguished, and likewise the
+ different numbers big, real, complex and fraction. */
+ 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 handle = scm_hashq_create_handle_x (hashtab,
+ scm_from_int (tag), SCM_INUM0);
+ SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
+ }
+ }
+}
+
+/* TAG is the tag word of a cell, return a string which is its name, or NULL
+ if unknown. Currently this is only used by gc-live-object-stats and the
+ distinctions between types are oriented towards what that code records
+ while scanning what's alive. */
+char const *
+scm_i_tag_name (scm_t_bits tag)
+{
+ switch (tag & 0x7F) /* 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";
+ case scm_tc16_big:
+ return "bignum";
+ case scm_tc16_complex:
+ return "complex number";
+ case scm_tc16_fraction:
+ return "fraction";
+ }
+ /* shouldn't reach here unless there's a new class of numbers */
+ return "number";
+ case scm_tc7_string:
+ return "string";
+ case scm_tc7_stringbuf:
+ return "string buffer";
+ case scm_tc7_symbol:
+ return "symbol";
+ case scm_tc7_variable:
+ return "variable";
+ case scm_tcs_subrs:
+ return "subrs";
+ case scm_tc7_port:
+ return "port";
+ case scm_tc7_smob:
+ /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
+ entry should be ok for our return here */
+ return scm_smobs[SCM_TC2SMOBNUM (tag)].name;
}
- return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
+ return NULL;
}
int scm_dbg_gc_marked_p (SCM obj);
scm_t_cell * scm_dbg_gc_get_card (SCM obj);
-long * scm_dbg_gc_get_bvec (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);
+ return SCM_GC_MARK_P (obj);
else
return 0;
}
scm_dbg_gc_get_card (SCM obj)
{
if (!SCM_IMP (obj))
- return SCM_GC_CELL_CARD(obj);
+ return SCM_GC_CELL_CARD (obj);
else
return NULL;
}
-long *
+scm_t_c_bvec_long *
scm_dbg_gc_get_bvec (SCM obj)
{
if (!SCM_IMP (obj))
HCoop / bpt / guile.git / blobdiff