X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f6f4feb0a2222efcb297e634603621126542e63f..fb50a753e125f77093826963fd786b9592f7e08d:/libguile/gc.c diff --git a/libguile/gc.c b/libguile/gc.c index 581bbc527..13823c054 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, - * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -46,12 +46,12 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/async.h" #include "libguile/ports.h" #include "libguile/root.h" +#include "libguile/simpos.h" #include "libguile/strings.h" #include "libguile/vectors.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" @@ -66,9 +66,13 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include -#endif + +/* Size in bytes of the initial heap. This should be about the size of + result of 'guile -c "(display (assq-ref (gc-stats) + 'heap-total-allocated))"'. */ + +#define DEFAULT_INITIAL_HEAP_SIZE (128 * 1024 * SIZEOF_SCM_T_BITS) /* Set this to != 0 if every cell that is accessed shall be checked: */ @@ -186,6 +190,68 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + + + +static int needs_gc_after_nonlocal_exit = 0; + +/* Arrange to throw an exception on failed allocations. */ +static void* +scm_oom_fn (size_t nbytes) +{ + needs_gc_after_nonlocal_exit = 1; + scm_report_out_of_memory (); + return NULL; +} + +/* Called within GC -- cannot allocate GC memory. */ +static void +scm_gc_warn_proc (char *fmt, GC_word arg) +{ + SCM port; + FILE *stream = NULL; + + port = scm_current_warning_port (); + if (!SCM_OPPORTP (port)) + return; + + if (SCM_FPORTP (port)) + { + int fd; + scm_force_output (port); + if (!SCM_OPPORTP (port)) + return; + fd = dup (SCM_FPORT_FDES (port)); + if (fd == -1) + perror ("Failed to dup warning port fd"); + else + { + stream = fdopen (fd, "a"); + if (!stream) + { + perror ("Failed to open stream for warning port"); + close (fd); + } + } + } + + fprintf (stream ? stream : stderr, fmt, arg); + + if (stream) + fclose (stream); +} + +void +scm_gc_after_nonlocal_exit (void) +{ + if (needs_gc_after_nonlocal_exit) + { + needs_gc_after_nonlocal_exit = 0; + GC_gcollect_and_unmap (); + } +} + + /* Hooks. */ @@ -231,44 +297,6 @@ SCM_SYMBOL (sym_times, "gc-times"); /* {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; - - 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, (), @@ -282,13 +310,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes, &bytes_since_gc, &total_bytes); -#ifdef HAVE_GC_GET_GC_NO - /* This function was added in 7.2alpha2 (June 2009). */ gc_times = GC_get_gc_no (); -#else - /* This symbol is deprecated as of 7.3. */ - gc_times = GC_gc_no; -#endif answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)), @@ -567,35 +589,10 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) -/* - MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC. - */ - -/* Get an integer from an environment variable. */ -int -scm_getenv_int (const char *var, int def) -{ - char *end = 0; - char *val = getenv (var); - long res = def; - if (!val) - return def; - res = strtol (val, &end, 10); - if (end == val) - return def; - return res; -} - void scm_storage_prehistory () { -#ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS - /* This function was added in 7.2alpha2 (June 2009). */ GC_set_all_interior_pointers (0); -#else - /* This symbol is deprecated in 7.3. */ - GC_all_interior_pointers = 0; -#endif free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3); minimum_free_space_divisor = free_space_divisor; @@ -603,16 +600,17 @@ scm_storage_prehistory () GC_set_free_space_divisor (free_space_divisor); GC_set_finalize_on_demand (1); - GC_INIT (); - -#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \ - && (defined SCM_I_GSC_USE_PTHREAD_THREADS) - /* When using GC 6.8, this call is required to initialize thread-local - freelists (shouldn't be necessary with GC 7.0). */ - GC_init (); +#if (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 4 \ + && GC_VERSION_MICRO == 0) + /* BDW-GC 7.4.0 has a bug making it loop indefinitely when using more + than one marker thread: . + Work around it by asking for one marker thread. */ + setenv ("GC_MARKERS", "1", 1); #endif - GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2); + GC_INIT (); + + GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE); /* We only need to register a displacement for those types for which the higher bits of the type tag are used to store a pointer (that is, a @@ -754,151 +752,9 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED, return NULL; } -/* Return some idea of the memory footprint of a process, in bytes. - Currently only works on Linux systems. */ -static size_t -get_image_size (void) -{ - unsigned long size, resident, share; - size_t ret = 0; - - FILE *fp = fopen ("/proc/self/statm", "r"); - - if (fp && fscanf (fp, "%lu %lu %lu", &size, &resident, &share) == 3) - ret = resident * 4096; - - if (fp) - fclose (fp); - - return ret; -} - -/* These are discussed later. */ -static size_t bytes_until_gc; +static size_t bytes_until_gc = DEFAULT_INITIAL_HEAP_SIZE; static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -/* Make GC run more frequently when the process image size is growing, - measured against the number of bytes allocated through the GC. - - If Guile is allocating at a GC-managed heap size H, libgc will tend - to limit the process image size to H*N. But if at the same time the - user program is mallocating at a rate M bytes per GC-allocated byte, - then the process stabilizes at H*N*M -- assuming that collecting data - will result in malloc'd data being freed. It doesn't take a very - large M for this to be a bad situation. To limit the image size, - Guile should GC more often -- the bigger the M, the more often. - - Numeric functions that produce bigger and bigger integers are - pessimal, because M is an increasing function of time. Here is an - example of such a function: - - (define (factorial n) - (define (fac n acc) - (if (<= n 1) - acc - (fac (1- n) (* n acc)))) - (fac n 1)) - - It is possible for a process to grow for reasons that will not be - solved by faster GC. In that case M will be estimated as - artificially high for a while, and so GC will happen more often on - the Guile side. But when it stabilizes, Guile can ease back the GC - frequency. - - The key is to measure process image growth, not mallocation rate. - For maximum effectiveness, Guile reacts quickly to process growth, - and exponentially backs down when the process stops growing. - - See http://thread.gmane.org/gmane.lisp.guile.devel/12552/focus=12936 - for further discussion. - */ -static void * -adjust_gc_frequency (void * hook_data SCM_UNUSED, - void *fn_data SCM_UNUSED, - void *data SCM_UNUSED) -{ - static size_t prev_image_size = 0; - static size_t prev_bytes_alloced = 0; - size_t image_size; - size_t bytes_alloced; - - scm_i_pthread_mutex_lock (&bytes_until_gc_lock); - bytes_until_gc = GC_get_heap_size (); - scm_i_pthread_mutex_unlock (&bytes_until_gc_lock); - - image_size = get_image_size (); - bytes_alloced = GC_get_total_bytes (); - -#define HEURISTICS_DEBUG 0 - -#if HEURISTICS_DEBUG - fprintf (stderr, "prev image / alloced: %lu / %lu\n", prev_image_size, prev_bytes_alloced); - fprintf (stderr, " image / alloced: %lu / %lu\n", image_size, bytes_alloced); - fprintf (stderr, "divisor %lu / %f\n", free_space_divisor, target_free_space_divisor); -#endif - - if (prev_image_size && bytes_alloced != prev_bytes_alloced) - { - double growth_rate, new_target_free_space_divisor; - double decay_factor = 0.5; - double hysteresis = 0.1; - - growth_rate = ((double) image_size - prev_image_size) - / ((double)bytes_alloced - prev_bytes_alloced); - -#if HEURISTICS_DEBUG - fprintf (stderr, "growth rate %f\n", growth_rate); -#endif - - new_target_free_space_divisor = minimum_free_space_divisor; - - if (growth_rate > 0) - new_target_free_space_divisor *= 1.0 + growth_rate; - -#if HEURISTICS_DEBUG - fprintf (stderr, "new divisor %f\n", new_target_free_space_divisor); -#endif - - if (new_target_free_space_divisor < target_free_space_divisor) - /* Decay down. */ - target_free_space_divisor = - (decay_factor * target_free_space_divisor - + (1.0 - decay_factor) * new_target_free_space_divisor); - else - /* Jump up. */ - target_free_space_divisor = new_target_free_space_divisor; - -#if HEURISTICS_DEBUG - fprintf (stderr, "new target divisor %f\n", target_free_space_divisor); -#endif - - if (free_space_divisor + 0.5 + hysteresis < target_free_space_divisor - || free_space_divisor - 0.5 - hysteresis > target_free_space_divisor) - { - free_space_divisor = lround (target_free_space_divisor); -#if HEURISTICS_DEBUG - fprintf (stderr, "new divisor %lu\n", free_space_divisor); -#endif - GC_set_free_space_divisor (free_space_divisor); - } - } - - prev_image_size = image_size; - prev_bytes_alloced = bytes_alloced; - - return NULL; -} - -/* The adjust_gc_frequency routine handles transients in the process - image size. It can't handle instense non-GC-managed steady-state - allocation though, as it decays the FSD at steady-state down to its - minimum value. - - The only real way to handle continuous, high non-GC allocation is to - let the GC know about it. This routine can handle non-GC allocation - rates that are similar in size to the GC-managed heap size. - */ - void scm_gc_register_allocation (size_t size) { @@ -918,88 +774,6 @@ scm_gc_register_allocation (size_t size) - -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_tc7_pointer: - return "foreign"; - case scm_tc7_hashtable: - return "hashtable"; - case scm_tc7_weak_set: - return "weak-set"; - case scm_tc7_weak_table: - return "weak-table"; - case scm_tc7_fluid: - return "fluid"; - case scm_tc7_dynamic_state: - return "dynamic state"; - case scm_tc7_frame: - return "frame"; - case scm_tc7_objcode: - return "objcode"; - case scm_tc7_vm: - return "vm"; - case scm_tc7_vm_cont: - return "vm continuation"; - case scm_tc7_wvect: - return "weak vector"; - case scm_tc7_vector: - return "vector"; - 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_tc7_port: - return "port"; - break; - case scm_tc7_smob: - { - int k = 0xff & (tag >> 8); - return (scm_smobs[k].name); - } - break; - } - - return NULL; -} - - - - void scm_init_gc () { @@ -1018,10 +792,8 @@ scm_init_gc () scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0); scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0); - /* GC_get_heap_usage does not take a lock, and so can run in the GC - start hook. */ - scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0); - + GC_set_oom_fn (scm_oom_fn); + GC_set_warn_proc (scm_gc_warn_proc); GC_set_start_callback (run_before_gc_c_hook); #include "libguile/gc.x"