summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS5
-rw-r--r--libguile/ChangeLog15
-rw-r--r--libguile/gc-card.c117
-rw-r--r--libguile/gc-segment.c35
-rw-r--r--libguile/gc.c32
-rw-r--r--libguile/gc.h2
-rw-r--r--libguile/private-gc.h6
7 files changed, 210 insertions, 2 deletions
diff --git a/NEWS b/NEWS
index 31054acb0..4c18e0e13 100644
--- a/NEWS
+++ b/NEWS
@@ -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;