/* 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 #endif #include #include #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