123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/gen-scmconfig.h"
- #include <stdio.h>
- #include <errno.h>
- #include <string.h>
- #include <stdlib.h>
- #include <math.h>
- #ifdef __ia64__
- #include <ucontext.h>
- extern unsigned long * __libc_ia64_register_backing_store_base;
- #endif
- #include "libguile/_scm.h"
- #include "libguile/eval.h"
- #include "libguile/stime.h"
- #include "libguile/stackchk.h"
- #include "libguile/struct.h"
- #include "libguile/smob.h"
- #include "libguile/arrays.h"
- #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/validate.h"
- #include "libguile/deprecation.h"
- #include "libguile/gc.h"
- #include "libguile/dynwind.h"
- #include "libguile/bdw-gc.h"
- #include <gc/gc_mark.h>
- #ifdef GUILE_DEBUG_MALLOC
- #include "libguile/debug-malloc.h"
- #endif
- #include <unistd.h>
- #define DEFAULT_INITIAL_HEAP_SIZE (128 * 1024 * SIZEOF_SCM_T_BITS)
- int scm_debug_cell_accesses_p = 0;
- int scm_expensive_debug_cell_accesses_p = 0;
- int scm_debug_cells_gc_interval = 0;
- static SCM scm_protects;
- #if (SCM_DEBUG_CELL_ACCESSES == 1)
- void
- scm_i_expensive_validation_check (SCM cell)
- {
-
- if (scm_debug_cells_gc_interval)
- {
- static unsigned int counter = 0;
- if (counter != 0)
- {
- --counter;
- }
- else
- {
- counter = scm_debug_cells_gc_interval;
- scm_gc ();
- }
- }
- }
- static int scm_i_cell_validation_already_running = 0;
- void
- scm_assert_cell_valid (SCM cell)
- {
- if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
- {
- scm_i_cell_validation_already_running = 1;
-
- if (scm_gc_running_p)
- return;
-
- if (scm_expensive_debug_cell_accesses_p)
- scm_i_expensive_validation_check (cell);
- scm_i_cell_validation_already_running = 0;
- }
- }
- SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
- (SCM flag),
- "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
- "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
- "but no additional calls to garbage collection are issued.\n"
- "If @var{flag} is a number, strict cell access checking is enabled,\n"
- "with an additional garbage collection after the given\n"
- "number of cell accesses.\n"
- "This procedure only exists when the compile-time flag\n"
- "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
- #define FUNC_NAME s_scm_set_debug_cell_accesses_x
- {
- if (scm_is_false (flag))
- {
- scm_debug_cell_accesses_p = 0;
- }
- else if (scm_is_eq (flag, SCM_BOOL_T))
- {
- scm_debug_cells_gc_interval = 0;
- scm_debug_cell_accesses_p = 1;
- scm_expensive_debug_cell_accesses_p = 0;
- }
- else
- {
- scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
- scm_debug_cell_accesses_p = 1;
- scm_expensive_debug_cell_accesses_p = 1;
- }
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- #endif
- static int needs_gc_after_nonlocal_exit = 0;
- static void*
- scm_oom_fn (size_t nbytes)
- {
- needs_gc_after_nonlocal_exit = 1;
- scm_report_out_of_memory ();
- return NULL;
- }
- 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 ();
- }
- }
- scm_t_c_hook scm_before_gc_c_hook;
- scm_t_c_hook scm_before_mark_c_hook;
- 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;
- static void
- run_before_gc_c_hook (void)
- {
- if (!SCM_I_CURRENT_THREAD)
-
- return;
- scm_c_hook_run (&scm_before_gc_c_hook, NULL);
- }
- unsigned long scm_gc_ports_collected = 0;
- static long gc_time_taken = 0;
- static long gc_start_time = 0;
- static unsigned long free_space_divisor;
- static unsigned long minimum_free_space_divisor;
- static double target_free_space_divisor;
- static unsigned long protected_obj_count = 0;
- SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
- SCM_SYMBOL (sym_heap_size, "heap-size");
- SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
- SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
- SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
- SCM_SYMBOL (sym_protected_objects, "protected-objects");
- SCM_SYMBOL (sym_times, "gc-times");
- extern int scm_gc_malloc_yield_percentage;
- SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
- (),
- "Return an association list of statistics about Guile's current\n"
- "use of storage.\n")
- #define FUNC_NAME s_scm_gc_stats
- {
- SCM answer;
- GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
- size_t gc_times;
- GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
- &bytes_since_gc, &total_bytes);
- gc_times = GC_get_gc_no ();
- answer =
- scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
- scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
- scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
- scm_cons (sym_heap_total_allocated,
- scm_from_size_t (total_bytes)),
- scm_cons (sym_heap_allocated_since_gc,
- scm_from_size_t (bytes_since_gc)),
- scm_cons (sym_protected_objects,
- scm_from_ulong (protected_obj_count)),
- scm_cons (sym_times, scm_from_size_t (gc_times)),
- SCM_UNDEFINED);
- return answer;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
- (void),
- "Dump information about the garbage collector's internal data "
- "structures and memory usage to the standard output.")
- #define FUNC_NAME s_scm_gc_dump
- {
- GC_dump ();
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
- (SCM obj),
- "Return an integer that for the lifetime of @var{obj} is uniquely\n"
- "returned by this function for @var{obj}")
- #define FUNC_NAME s_scm_object_address
- {
- return scm_from_ulong (SCM_UNPACK (obj));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
- (),
- "Disables the garbage collector. Nested calls are permitted. "
- "GC is re-enabled once @code{gc-enable} has been called the "
- "same number of times @code{gc-disable} was called.")
- #define FUNC_NAME s_scm_gc_disable
- {
- GC_disable ();
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
- (),
- "Enables the garbage collector.")
- #define FUNC_NAME s_scm_gc_enable
- {
- GC_enable ();
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
- (),
- "Scans all of SCM objects and reclaims for further use those that are\n"
- "no longer accessible.")
- #define FUNC_NAME s_scm_gc
- {
- scm_i_gc ("call");
-
- GC_invoke_finalizers ();
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- void
- scm_i_gc (const char *what)
- {
- GC_gcollect ();
- }
- #undef scm_remember_upto_here_1
- #undef scm_remember_upto_here_2
- void
- scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
- {
-
- }
- void
- scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
- {
-
- }
- void
- scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
- {
-
- }
- SCM
- scm_return_first (SCM elt, ...)
- {
- return elt;
- }
- int
- scm_return_first_int (int i, ...)
- {
- return i;
- }
- SCM
- scm_permanent_object (SCM obj)
- {
- return (scm_gc_protect_object (obj));
- }
- SCM
- scm_gc_protect_object (SCM obj)
- {
- SCM handle;
-
-
- 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_CRITICAL_SECTION_END;
- return obj;
- }
- SCM
- scm_gc_unprotect_object (SCM obj)
- {
- SCM handle;
-
-
- 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))
- {
- fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
- abort ();
- }
- else
- {
- SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
- if (scm_is_eq (count, scm_from_int (0)))
- scm_hashq_remove_x (scm_protects, obj);
- else
- SCM_SETCDR (handle, count);
- }
- protected_obj_count --;
- SCM_CRITICAL_SECTION_END;
- return obj;
- }
- void
- scm_gc_register_root (SCM *p)
- {
-
- }
- void
- scm_gc_unregister_root (SCM *p)
- {
-
- }
- void
- scm_gc_register_roots (SCM *b, unsigned long n)
- {
- SCM *p = b;
- for (; p < b + n; ++p)
- scm_gc_register_root (p);
- }
- void
- scm_gc_unregister_roots (SCM *b, unsigned long n)
- {
- SCM *p = b;
- for (; p < b + n; ++p)
- scm_gc_unregister_root (p);
- }
- void
- scm_storage_prehistory ()
- {
- GC_set_all_interior_pointers (0);
- free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
- minimum_free_space_divisor = free_space_divisor;
- target_free_space_divisor = free_space_divisor;
- 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)
-
- setenv ("GC_MARKERS", "1", 1);
- #endif
- GC_INIT ();
- GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE);
-
- GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
-
-
- if (!GC_is_visible (&scm_protects))
- abort ();
- scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
- scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
- scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
- scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
- scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
- }
- scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
- void
- scm_init_gc_protect_object ()
- {
- scm_protects = scm_c_make_hash_table (31);
- #if 0
-
- #ifdef HAVE_ATEXIT
- atexit (cleanup);
- #else
- #ifdef HAVE_ON_EXIT
- on_exit (cleanup, 0);
- #endif
- #endif
- #endif
- }
- SCM scm_after_gc_hook;
- static SCM after_gc_async_cell;
- static SCM
- after_gc_async_thunk (void)
- {
-
- scm_c_hook_run (&scm_after_gc_c_hook, NULL);
- scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
- return SCM_UNSPECIFIED;
- }
- static void *
- queue_after_gc_hook (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
- {
-
- #if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cells_gc_interval == 0)
- #endif
- {
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- if (scm_is_false (SCM_CDR (after_gc_async_cell)))
- {
- SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
- t->active_asyncs = after_gc_async_cell;
- t->pending_asyncs = 1;
- }
- }
- return NULL;
- }
- static void *
- start_gc_timer (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
- {
- if (!gc_start_time)
- gc_start_time = scm_c_get_internal_run_time ();
- return NULL;
- }
- static void *
- accumulate_gc_timer (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
- {
- if (gc_start_time)
- {
- long now = scm_c_get_internal_run_time ();
- gc_time_taken += now - gc_start_time;
- gc_start_time = 0;
- }
- return NULL;
- }
- 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;
- void
- scm_gc_register_allocation (size_t size)
- {
- scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
- if (bytes_until_gc - size > bytes_until_gc)
- {
- bytes_until_gc = GC_get_heap_size ();
- scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
- GC_gcollect ();
- }
- else
- {
- bytes_until_gc -= size;
- scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
- }
- }
- void
- scm_init_gc ()
- {
-
- scm_after_gc_hook = scm_make_hook (SCM_INUM0);
- scm_c_define ("after-gc-hook", scm_after_gc_hook);
-
- after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
- after_gc_async_thunk),
- SCM_BOOL_F);
- scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
- 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_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"
- }
- void
- scm_gc_sweep (void)
- #define FUNC_NAME "scm_gc_sweep"
- {
-
- fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
- }
- #undef FUNC_NAME
|