diff options
-rw-r--r-- | NEWS | 5 | ||||
-rw-r--r-- | libguile/ChangeLog | 15 | ||||
-rw-r--r-- | libguile/gc-card.c | 117 | ||||
-rw-r--r-- | libguile/gc-segment.c | 35 | ||||
-rw-r--r-- | libguile/gc.c | 32 | ||||
-rw-r--r-- | libguile/gc.h | 2 | ||||
-rw-r--r-- | libguile/private-gc.h | 6 |
7 files changed, 210 insertions, 2 deletions
@@ -1078,6 +1078,11 @@ the C variables that control garbage collection. The environment variables GUILE_MAX_SEGMENT_SIZE, GUILE_INIT_SEGMENT_SIZE_2, GUILE_INIT_SEGMENT_SIZE_1, and GUILE_MIN_YIELD_2 should be used. +For understanding the memory usage of a GUILE program, the routine +gc-live-object-stats returns an alist containing the number of live +objects for every type. + + ** The function scm_definedp has been renamed to scm_defined_p The name scm_definedp is deprecated. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e23342e14..6929c19e5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2005-01-27 Han-Wen Nienhuys <hanwen@xs4all.nl> + + * gc.c (s_scm_gc_live_object_stats): return alist, not hashtable. + + * gc-segment.c (scm_i_all_segments_statistics): new function. + (scm_i_heap_segment_statistics): new function + + * gc.c (s_scm_gc_live_object_stats): new GUILE callable: return + statistics on the number of live objects of each type. + + * gc-card.c (scm_i_tag_name): new function. + (scm_i_card_statistics): new function. + 2005-01-24 Kevin Ryde <user42@zip.com.au> * posix.c (scm_setlocale): Force errno=EINVAL for an error, since @@ -978,6 +991,8 @@ 2004-10-08 Han-Wen Nienhuys <hanwen@xs4all.nl> + * gc.c (scm_igc): put scm_gc_running-- before running hooks. + * inline.h (scm_double_cell): abort if GC running. (scm_cell): idem. diff --git a/libguile/gc-card.c b/libguile/gc-card.c index a92dd1d85..1acd95e17 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -301,6 +301,123 @@ scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list, } +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); + + for (p += offset; p < end; p += span, offset += span) + { + SCM scmptr = PTR2SCM (p); + if (!SCM_C_BVEC_GET (bitvec, offset)) + continue; + + scm_t_bits 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; + } + + 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 "unknown type"; +} + + #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1) typedef struct scm_dbg_t_list_cell { diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c index 2ba135c62..fee06e7f9 100644 --- a/libguile/gc-segment.c +++ b/libguile/gc-segment.c @@ -52,6 +52,19 @@ scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl) } +void +scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab) +{ + scm_t_cell *p = seg->bounds[0]; + while (p < seg->bounds[1]) + { + scm_i_card_statistics (p, tab, seg); + p += SCM_GC_CARD_N_CELLS; + } +} + + + /* Fill SEGMENT with memory both for data and mark bits. @@ -331,8 +344,6 @@ scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl) } - - void scm_i_reset_segments (void) { @@ -344,6 +355,26 @@ scm_i_reset_segments (void) } } +/* + Return a hashtab with counts of live objects, with tags as keys. + */ + + +SCM +scm_i_all_segments_statistics (SCM tab) +{ + int i = 0; + for (; i < scm_i_heap_segment_table_size; i++) + { + scm_t_heap_segment * seg = scm_i_heap_segment_table[i]; + scm_i_heap_segment_statistics (seg, tab); + } + + return tab; +} + + + /* Determine whether the given value does actually represent a cell in diff --git a/libguile/gc.c b/libguile/gc.c index c1d489c40..ef290d3c1 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -276,6 +276,29 @@ unsigned scm_newcell2_count; /* {Scheme Interface to GC} */ +static SCM +tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc) +{ + scm_t_bits c_tag = scm_to_int (key); + key = scm_from_locale_string (scm_i_tag_name (c_tag)); + return scm_cons (scm_cons (key, val), acc); +} + +SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0, + (), + "Return an alist of statistics of the current live objects. ") +#define FUNC_NAME s_scm_gc_live_object_stats +{ + SCM tab = scm_make_hash_table (scm_from_int (57)); + scm_i_all_segments_statistics (tab); + + SCM alist + = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab); + + return alist; +} +#undef FUNC_NAME + extern int scm_gc_malloc_yield_percentage; SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, (), @@ -528,11 +551,20 @@ scm_igc (const char *what) gc_start_stats (what); + + if (scm_gc_heap_lock) /* We've invoked the collector while a GC is already in progress. That should never happen. */ abort (); + /* + Set freelists to NULL so scm_cons() always triggers gc, causing + the above abort() to be triggered. + */ + *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; + ++scm_gc_heap_lock; /* diff --git a/libguile/gc.h b/libguile/gc.h index 4e546446b..99ad729bd 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -309,6 +309,8 @@ SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag); SCM_API SCM scm_object_address (SCM obj); SCM_API SCM scm_gc_stats (void); +SCM_API SCM scm_gc_live_object_stats (void); +SCM_API SCM scm_gc_tag_name (SCM tag); SCM_API SCM scm_gc (void); SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist); SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist); diff --git a/libguile/private-gc.h b/libguile/private-gc.h index a7acd499a..97ce63232 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -212,6 +212,9 @@ extern size_t scm_i_heap_segment_table_size; int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,scm_t_heap_segment*); int scm_i_sweep_card (scm_t_cell * card, SCM *free_list, scm_t_heap_segment*); +void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg); +char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */ + int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested); int scm_i_segment_card_count (scm_t_heap_segment * seg); int scm_i_segment_cell_count (scm_t_heap_segment * seg); @@ -221,6 +224,8 @@ scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*) SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg); void scm_i_sweep_segment (scm_t_heap_segment * seg); +void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab); + int scm_i_insert_segment (scm_t_heap_segment * seg); long int scm_i_find_heap_segment_containing_object (SCM obj); @@ -230,6 +235,7 @@ void scm_i_sweep_segments (void); SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl); void scm_i_reset_segments (void); void scm_i_sweep_all_segments (char const *reason); +SCM scm_i_all_segments_statistics (SCM hashtab); void scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist); extern long int scm_i_deprecated_memory_return; |