X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/76da80e7881947ebcdb647e5ce4be029fece29f2..9a5fa6e98a0078e6f3e47dd72d1545877ea862f7:/libguile/gc.c diff --git a/libguile/gc.c b/libguile/gc.c index c1d489c40..89984888a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006 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 @@ -12,9 +12,10 @@ * * 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 */ +#define _GNU_SOURCE /* #define DEBUGINFO */ @@ -27,11 +28,6 @@ #include #include -#ifdef __ia64__ -#include -extern unsigned long * __libc_ia64_register_backing_store_base; -#endif - #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" @@ -52,6 +48,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/validate.h" #include "libguile/deprecation.h" #include "libguile/gc.h" +#include "libguile/dynwind.h" #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" @@ -65,13 +62,9 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include #endif - - -unsigned int scm_gc_running_p = 0; - /* Lock this mutex before doing lazy sweeping. */ -scm_t_rec_mutex scm_i_sweep_mutex; +scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; /* Set this to != 0 if every cell that is accessed shall be checked: */ @@ -127,7 +120,7 @@ scm_i_expensive_validation_check (SCM cell) else { counter = scm_debug_cells_gc_interval; - scm_igc ("scm_assert_cell_valid"); + scm_gc (); } } } @@ -206,32 +199,12 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, -scm_t_key scm_i_freelist; -scm_t_key scm_i_freelist2; - /* scm_mtrigger * is the number of bytes of malloc allocation needed to trigger gc. */ unsigned long scm_mtrigger; -/* scm_gc_heap_lock - * If set, don't expand the heap. Set only during gc, during which no allocation - * is supposed to take place anyway. - */ -int scm_gc_heap_lock = 0; - -/* GC Blocking - * Don't pause for collection if this is set -- just - * expand the heap. - */ -int scm_block_gc = 1; - -/* During collection, this accumulates objects holding - * weak references. - */ -SCM scm_weak_vectors; - /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; @@ -276,6 +249,46 @@ unsigned scm_newcell2_count; /* {Scheme Interface to GC} */ +static SCM +tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc) +{ + if (scm_is_integer (key)) + { + int c_tag = scm_to_int (key); + + char const * name = scm_i_tag_name (c_tag); + if (name != NULL) + { + key = scm_from_locale_string (name); + } + else + { + char s[100]; + sprintf (s, "tag %d", c_tag); + key = scm_from_locale_string (s); + } + } + + 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 alist; + + scm_i_all_segments_statistics (tab); + + 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, (), @@ -300,13 +313,13 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, SCM answer; unsigned long *bounds = 0; int table_size = scm_i_heap_segment_table_size; - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; /* temporarily store the numbers, so as not to cause GC. */ - bounds = malloc (sizeof (int) * table_size * 2); + bounds = malloc (sizeof (unsigned long) * table_size * 2); if (!bounds) abort(); for (i = table_size; i--; ) @@ -344,7 +357,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, scm_from_ulong (bounds[2*i+1])), heap_segs); } - + /* njrev: can any of these scm_cons's or scm_list_n signal a memory + error? If so we need a frame here. */ answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_from_ulong (local_scm_gc_time_taken)), @@ -372,7 +386,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, scm_from_ulong (local_protected_obj_count)), scm_cons (sym_heap_segments, heap_segs), SCM_UNDEFINED); - SCM_ALLOW_INTS; + SCM_CRITICAL_SECTION_END; free (bounds); return answer; @@ -384,31 +398,32 @@ gc_start_stats (const char *what SCM_UNUSED) { t_before_gc = scm_c_get_internal_run_time (); - scm_gc_cells_marked_acc += (double) scm_gc_cells_swept - - (double) scm_gc_cells_collected; - scm_gc_cells_swept_acc += (double) scm_gc_cells_swept; - - scm_gc_cell_yield_percentage = ( scm_gc_cells_collected * 100 ) / SCM_HEAP_SIZE; - - scm_gc_cells_swept = 0; - scm_gc_cells_collected_1 = scm_gc_cells_collected; - - /* - CELLS SWEPT is another word for the number of cells that were - examined during GC. YIELD is the number that we cleaned - out. MARKED is the number that weren't cleaned. - */ - scm_gc_cells_collected = 0; scm_gc_malloc_collected = 0; scm_gc_ports_collected = 0; } static void -gc_end_stats () +gc_end_stats (scm_t_sweep_statistics sweep_stats) { unsigned long t = scm_c_get_internal_run_time (); scm_gc_time_taken += (t - t_before_gc); + /* + CELLS SWEPT is another word for the number of cells that were + examined during GC. YIELD is the number that we cleaned + out. MARKED is the number that weren't cleaned. + */ + scm_gc_cells_marked_acc += (double) sweep_stats.swept + - (double) scm_gc_cells_collected; + scm_gc_cells_swept_acc += (double) sweep_stats.swept; + + scm_gc_cell_yield_percentage = (sweep_stats.collected * 100) / SCM_HEAP_SIZE; + + scm_gc_cells_swept = sweep_stats.swept; + scm_gc_cells_collected_1 = scm_gc_cells_collected; + scm_gc_cells_collected = sweep_stats.collected; + scm_cells_allocated -= sweep_stats.collected; + ++scm_gc_times; } @@ -430,7 +445,19 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, "no longer accessible.") #define FUNC_NAME s_scm_gc { - scm_igc ("call"); + scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); + scm_gc_running_p = 1; + scm_i_gc ("call"); + /* njrev: It looks as though other places, e.g. scm_realloc, + can call scm_i_gc without acquiring the sweep mutex. Does this + matter? Also scm_i_gc (or its descendants) touch the + scm_sys_protects, which are protected in some cases + (e.g. scm_permobjs above in scm_gc_stats) by a critical section, + not by the sweep mutex. Shouldn't all the GC-relevant objects be + protected in the same way? */ + scm_gc_running_p = 0; + scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); + scm_c_hook_run (&scm_after_gc_c_hook, 0); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -438,39 +465,47 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, -/* When we get POSIX threads support, the master will be global and - * common while the freelist will be individual for each thread. +/* The master is global and common while the freelist will be + * individual for each thread. */ SCM scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) { SCM cell; - - scm_rec_mutex_lock (&scm_i_sweep_mutex); + int did_gc = 0; + scm_t_sweep_statistics sweep_stats; + + scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); + scm_gc_running_p = 1; + + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); + scm_cells_allocated -= sweep_stats.collected; - *free_cells = scm_i_sweep_some_segments (freelist); if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist)) { freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error); - *free_cells = scm_i_sweep_some_segments (freelist); + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); + scm_cells_allocated -= sweep_stats.collected; } - if (*free_cells == SCM_EOL && !scm_block_gc) + if (*free_cells == SCM_EOL) { /* - with the advent of lazy sweep, GC yield is only know just + with the advent of lazy sweep, GC yield is only known just before doing the GC. */ - scm_i_adjust_min_yield (freelist); + scm_i_adjust_min_yield (freelist, sweep_stats); /* out of fresh cells. Try to get some new ones. */ - scm_igc ("cells"); + did_gc = 1; + scm_i_gc ("cells"); - *free_cells = scm_i_sweep_some_segments (freelist); + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); + scm_cells_allocated -= sweep_stats.collected; } if (*free_cells == SCM_EOL) @@ -479,7 +514,8 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) failed getting new cells. Get new juice or die. */ freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error); - *free_cells = scm_i_sweep_some_segments (freelist); + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); + scm_cells_allocated -= sweep_stats.collected; } if (*free_cells == SCM_EOL) @@ -489,7 +525,11 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) *free_cells = SCM_FREE_CELL_CDR (cell); - scm_rec_mutex_unlock (&scm_i_sweep_mutex); + scm_gc_running_p = 0; + scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); + + if (did_gc) + scm_c_hook_run (&scm_after_gc_c_hook, 0); return cell; } @@ -501,11 +541,16 @@ scm_t_c_hook scm_before_sweep_c_hook; scm_t_c_hook scm_after_sweep_c_hook; scm_t_c_hook scm_after_gc_c_hook; +/* Must be called while holding scm_i_sweep_mutex. + */ + void -scm_igc (const char *what) +scm_i_gc (const char *what) { - scm_rec_mutex_lock (&scm_i_sweep_mutex); - ++scm_gc_running_p; + scm_t_sweep_statistics sweep_stats; + + scm_i_thread_put_to_sleep (); + scm_c_hook_run (&scm_before_gc_c_hook, 0); #ifdef DEBUGINFO @@ -517,29 +562,25 @@ scm_igc (const char *what) : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m")); #endif - /* During the critical section, only the current thread may run. */ - scm_i_thread_put_to_sleep (); - - if (!scm_root || !scm_stack_base || scm_block_gc) - { - --scm_gc_running_p; - return; - } - 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 (); - - ++scm_gc_heap_lock; - + /* + Set freelists to NULL so scm_cons() always triggers gc, causing + the assertion above to fail. + */ + *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; + /* Let's finish the sweep. The conservative GC might point into the garbage, and marking that would create a mess. */ - scm_i_sweep_all_segments("GC"); + scm_i_sweep_all_segments ("GC", &sweep_stats); + + /* Invariant: the number of cells collected (i.e., freed) must always be + lower than or equal to the number of cells "swept" (i.e., visited). */ + assert (sweep_stats.collected <= sweep_stats.swept); + if (scm_mallocated < scm_i_deprecated_memory_return) { /* The byte count of allocated objects has underflowed. This is @@ -556,28 +597,17 @@ scm_igc (const char *what) scm_mallocated -= scm_i_deprecated_memory_return; - - scm_c_hook_run (&scm_before_mark_c_hook, 0); + /* Mark */ + scm_c_hook_run (&scm_before_mark_c_hook, 0); scm_mark_all (); - scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc); - scm_c_hook_run (&scm_before_sweep_c_hook, 0); - - /* - Moved this lock upwards so that we can alloc new heap at the end of a sweep. - - DOCME: why should the heap be locked anyway? - */ - --scm_gc_heap_lock; - - scm_gc_sweep (); - + /* Sweep - /* - TODO: this hook should probably be moved to just before the mark, - since that's where the sweep is finished in lazy sweeping. + TODO: the after_sweep hook should probably be moved to just before + the mark, since that's where the sweep is finished in lazy + sweeping. MDJ 030219 : No, probably not. The original meaning implied at least two things: that it would be @@ -598,17 +628,14 @@ scm_igc (const char *what) distinct classes of hook functions since this can prevent some bad interference when several modules adds gc hooks. */ + + scm_c_hook_run (&scm_before_sweep_c_hook, 0); + scm_gc_sweep (); scm_c_hook_run (&scm_after_sweep_c_hook, 0); - gc_end_stats (); - scm_i_thread_wake_up (); + gc_end_stats (sweep_stats); - /* - See above. - */ - --scm_gc_running_p; - scm_c_hook_run (&scm_after_gc_c_hook, 0); - scm_rec_mutex_unlock (&scm_i_sweep_mutex); + scm_i_thread_wake_up (); /* For debugging purposes, you could do @@ -617,6 +644,7 @@ scm_igc (const char *what) */ } + /* {GC Protection Helper Functions} */ @@ -695,9 +723,11 @@ scm_return_first_int (int i, ...) SCM scm_permanent_object (SCM obj) { - SCM_REDEFER_INTS; - scm_permobjs = scm_cons (obj, scm_permobjs); - SCM_REALLOW_INTS; + SCM cell = scm_cons (obj, SCM_EOL); + SCM_CRITICAL_SECTION_START; + SCM_SETCDR (cell, scm_permobjs); + scm_permobjs = cell; + SCM_CRITICAL_SECTION_END; return obj; } @@ -724,14 +754,16 @@ scm_gc_protect_object (SCM obj) SCM handle; /* This critical section barrier will be replaced by a mutex. */ - SCM_REDEFER_INTS; + /* njrev: Indeed; if my comment above is correct, there is the same + critsec/mutex inconsistency here. */ + SCM_CRITICAL_SECTION_START; handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0)); SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); protected_obj_count ++; - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; return obj; } @@ -747,14 +779,15 @@ scm_gc_unprotect_object (SCM obj) SCM handle; /* This critical section barrier will be replaced by a mutex. */ - SCM_REDEFER_INTS; + /* njrev: and again. */ + SCM_CRITICAL_SECTION_START; if (scm_gc_running_p) { fprintf (stderr, "scm_unprotect_object called during GC.\n"); abort (); } - + handle = scm_hashq_get_handle (scm_protects, obj); if (scm_is_false (handle)) @@ -772,7 +805,7 @@ scm_gc_unprotect_object (SCM obj) } protected_obj_count --; - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; return obj; } @@ -784,13 +817,15 @@ scm_gc_register_root (SCM *p) SCM key = scm_from_ulong ((unsigned long) p); /* This critical section barrier will be replaced by a mutex. */ - SCM_REDEFER_INTS; + /* njrev: and again. */ + SCM_CRITICAL_SECTION_START; handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, scm_from_int (0)); + /* njrev: note also that the above can probably signal an error */ SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; } void @@ -800,7 +835,8 @@ scm_gc_unregister_root (SCM *p) SCM key = scm_from_ulong ((unsigned long) p); /* This critical section barrier will be replaced by a mutex. */ - SCM_REDEFER_INTS; + /* njrev: and again. */ + SCM_CRITICAL_SECTION_START; handle = scm_hashv_get_handle (scm_gc_registered_roots, key); @@ -818,7 +854,7 @@ scm_gc_unregister_root (SCM *p) SCM_SETCDR (handle, count); } - SCM_REALLOW_INTS; + SCM_CRITICAL_SECTION_END; } void @@ -839,25 +875,6 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) int scm_i_terminating; -/* called on process termination. */ -#ifdef HAVE_ATEXIT -static void -cleanup (void) -#else -#ifdef HAVE_ON_EXIT -extern int on_exit (void (*procp) (), int arg); - -static void -cleanup (int status, void *arg) -#else -#error Dont know how to setup a cleanup handler on your system. -#endif -#endif -{ - scm_i_terminating = 1; - scm_flush_all_ports (); -} - @@ -890,22 +907,16 @@ scm_storage_prehistory () scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); } -scm_t_mutex scm_i_gc_admin_mutex; +scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; int scm_init_storage () { size_t j; - /* Fixme: Should use mutexattr from the low-level API. */ - scm_rec_mutex_init (&scm_i_sweep_mutex, &scm_i_plugin_rec_mutex); - - scm_i_plugin_mutex_init (&scm_i_gc_admin_mutex, &scm_i_plugin_mutex); - j = SCM_NUM_PROTECTS; while (j) scm_sys_protects[--j] = SCM_BOOL_F; - scm_block_gc = 1; scm_gc_init_freelist(); scm_gc_init_malloc (); @@ -919,6 +930,10 @@ scm_init_storage () if (!scm_i_port_table) return 1; +#if 0 + /* We can't have a cleanup handler since we have no thread to run it + in. */ + #ifdef HAVE_ATEXIT atexit (cleanup); #else @@ -927,7 +942,9 @@ scm_init_storage () #endif #endif - scm_stand_in_procs = scm_c_make_hash_table (257); +#endif + + scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257)); scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); scm_gc_registered_roots = scm_c_make_hash_table (31); @@ -987,6 +1004,7 @@ mark_gc_async (void * hook_data SCM_UNUSED, * collection hooks and the execution count of the scheme level * after-gc-hook. */ + #if (SCM_DEBUG_CELL_ACCESSES == 1) if (scm_debug_cells_gc_interval == 0) scm_system_async_mark (gc_async); @@ -1013,6 +1031,44 @@ scm_init_gc () #include "libguile/gc.x" } +#ifdef __ia64__ +# ifdef __hpux +# include +# include +void * +scm_ia64_register_backing_store_base (void) +{ + struct pst_vm_status vm_status; + int i = 0; + while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1) + if (vm_status.pst_type == PS_RSESTACK) + return (void *) vm_status.pst_vaddr; + abort (); +} +void * +scm_ia64_ar_bsp (const void *ctx) +{ + uint64_t bsp; + __uc_get_ar_bsp(ctx, &bsp); + return (void *) bsp; +} +# endif /* hpux */ +# ifdef linux +# include +void * +scm_ia64_register_backing_store_base (void) +{ + extern void *__libc_ia64_register_backing_store_base; + return __libc_ia64_register_backing_store_base; +} +void * +scm_ia64_ar_bsp (const void *opaque) +{ + ucontext_t *ctx = opaque; + return (void *) ctx->uc_mcontext.sc_ar_bsp; +} +# endif /* linux */ +#endif /* __ia64__ */ void scm_gc_sweep (void) @@ -1028,8 +1084,6 @@ scm_gc_sweep (void) */ scm_i_reset_segments (); - /* When we move to POSIX threads private freelists should probably - be GC-protected instead. */ *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;