--- /dev/null
+/* 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
+ * 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#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_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 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
projects / lilypond.git / blobdiff