/* 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
#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"
#include "libguile/debug-malloc.h"
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#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:
*/
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
+
+\f
+
+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 ();
+ }
+}
+
+
\f
/* Hooks. */
/* {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,
(),
\f
-/*
- 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 ()
{
GC_set_free_space_divisor (free_space_divisor);
GC_set_finalize_on_demand (1);
+#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: <https://github.com/ivmai/bdwgc/pull/30>.
+ Work around it by asking for one marker thread. */
+ setenv ("GC_MARKERS", "1", 1);
+#endif
+
GC_INIT ();
- GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
+ 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
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)
{
\f
-
-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_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;
-}
-
-
-
-\f
void
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"
HCoop / bpt / guile.git / blobdiff