libguile/gc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
   2  *   2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20 /* #define DEBUGINFO */
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #define SCM_BUILDING_DEPRECATED_CODE
  27
  28 #include "libguile/gen-scmconfig.h"
  29
  30 #include <stdio.h>
  31 #include <errno.h>
  32 #include <string.h>
  33 #include <stdlib.h>
  34 #include <math.h>
  35
  36 #ifdef __ia64__
  37 #include <ucontext.h>
  38 extern unsigned long * __libc_ia64_register_backing_store_base;
  39 #endif
  40
  41 #include "libguile/_scm.h"
  42 #include "libguile/eval.h"
  43 #include "libguile/stime.h"
  44 #include "libguile/stackchk.h"
  45 #include "libguile/struct.h"
  46 #include "libguile/smob.h"
  47 #include "libguile/arrays.h"
  48 #include "libguile/async.h"
  49 #include "libguile/ports.h"
  50 #include "libguile/root.h"
  51 #include "libguile/strings.h"
  52 #include "libguile/vectors.h"
  53 #include "libguile/weaks.h"
  54 #include "libguile/hashtab.h"
  55 #include "libguile/tags.h"
  56
  57 #include "libguile/private-gc.h"
  58 #include "libguile/validate.h"
  59 #include "libguile/deprecation.h"
  60 #include "libguile/gc.h"
  61 #include "libguile/dynwind.h"
  62
  63 #include "libguile/bdw-gc.h"
  64
  65 /* For GC_set_start_callback.  */
  66 #include <gc/gc_mark.h>
  67
  68 #ifdef GUILE_DEBUG_MALLOC
  69 #include "libguile/debug-malloc.h"
  70 #endif
  71
  72 #include <unistd.h>
  73
  74 /* Set this to != 0 if every cell that is accessed shall be checked:
  75  */
  76 int scm_debug_cell_accesses_p = 0;
  77 int scm_expensive_debug_cell_accesses_p = 0;
  78
  79 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
  80  * the number of cell accesses after which a gc shall be called.
  81  */
  82 int scm_debug_cells_gc_interval = 0;
  83
  84 #if SCM_ENABLE_DEPRECATED == 1
  85 /* Hash table that keeps a reference to objects the user wants to protect from
  86    garbage collection.  It could arguably be private but applications have come
  87    to rely on it (e.g., Lilypond 2.13.9).  */
  88 SCM scm_protects;
  89 #else
  90 static SCM scm_protects;
  91 #endif
  92
  93 #if (SCM_DEBUG_CELL_ACCESSES == 1)
  94
  95
  96 /*
  97
  98   Assert that the given object is a valid reference to a valid cell.  This
  99   test involves to determine whether the object is a cell pointer, whether
 100   this pointer actually points into a heap segment and whether the cell
 101   pointed to is not a free cell.  Further, additional garbage collections may
 102   get executed after a user defined number of cell accesses.  This helps to
 103   find places in the C code where references are dropped for extremely short
 104   periods.
 105
 106 */
 107 void
 108 scm_i_expensive_validation_check (SCM cell)
 109 {
 110   /* If desired, perform additional garbage collections after a user
 111    * defined number of cell accesses.
 112    */
 113   if (scm_debug_cells_gc_interval)
 114     {
 115       static unsigned int counter = 0;
 116
 117       if (counter != 0)
 118         {
 119           --counter;
 120         }
 121       else
 122         {
 123           counter = scm_debug_cells_gc_interval;
 124           scm_gc ();
 125         }
 126     }
 127 }
 128
 129 /* Whether cell validation is already running.  */
 130 static int scm_i_cell_validation_already_running = 0;
 131
 132 void
 133 scm_assert_cell_valid (SCM cell)
 134 {
 135   if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
 136     {
 137       scm_i_cell_validation_already_running = 1;  /* set to avoid recursion */
 138
 139       /*
 140         During GC, no user-code should be run, and the guile core
 141         should use non-protected accessors.
 142       */
 143       if (scm_gc_running_p)
 144         return;
 145
 146       /*
 147         Only scm_in_heap_p and rescanning the heap is wildly
 148         expensive.
 149       */
 150       if (scm_expensive_debug_cell_accesses_p)
 151         scm_i_expensive_validation_check (cell);
 152
 153       scm_i_cell_validation_already_running = 0;  /* re-enable */
 154     }
 155 }
 156
 157
 158
 159 SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
 160             (SCM flag),
 161             "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
 162             "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
 163             "but no additional calls to garbage collection are issued.\n"
 164             "If @var{flag} is a number, strict cell access checking is enabled,\n"
 165             "with an additional garbage collection after the given\n"
 166             "number of cell accesses.\n"
 167             "This procedure only exists when the compile-time flag\n"
 168             "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
 169 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
 170 {
 171   if (scm_is_false (flag))
 172     {
 173       scm_debug_cell_accesses_p = 0;
 174     }
 175   else if (scm_is_eq (flag, SCM_BOOL_T))
 176     {
 177       scm_debug_cells_gc_interval = 0;
 178       scm_debug_cell_accesses_p = 1;
 179       scm_expensive_debug_cell_accesses_p = 0;
 180     }
 181   else
 182     {
 183       scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
 184       scm_debug_cell_accesses_p = 1;
 185       scm_expensive_debug_cell_accesses_p = 1;
 186     }
 187   return SCM_UNSPECIFIED;
 188 }
 189 #undef FUNC_NAME
 190
 191
 192 #endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
 193
 194 \f
 195
 196 /* Compatibility.  */
 197
 198 #ifndef HAVE_GC_GET_HEAP_USAGE_SAFE
 199 static void
 200 GC_get_heap_usage_safe (GC_word *pheap_size, GC_word *pfree_bytes,
 201                         GC_word *punmapped_bytes, GC_word *pbytes_since_gc,
 202                         GC_word *ptotal_bytes)
 203 {
 204   *pheap_size = GC_get_heap_size ();
 205   *pfree_bytes = GC_get_free_bytes ();
 206 #ifdef HAVE_GC_GET_UNMAPPED_BYTES
 207   *punmapped_bytes = GC_get_unmapped_bytes ();
 208 #else
 209   *punmapped_bytes = 0;
 210 #endif
 211   *pbytes_since_gc = GC_get_bytes_since_gc ();
 212   *ptotal_bytes = GC_get_total_bytes ();
 213 }
 214 #endif
 215
 216 #ifndef HAVE_GC_GET_FREE_SPACE_DIVISOR
 217 static GC_word
 218 GC_get_free_space_divisor (void)
 219 {
 220   return GC_free_space_divisor;
 221 }
 222 #endif
 223
 224 \f
 225 /* Hooks.  */
 226 scm_t_c_hook scm_before_gc_c_hook;
 227 scm_t_c_hook scm_before_mark_c_hook;
 228 scm_t_c_hook scm_before_sweep_c_hook;
 229 scm_t_c_hook scm_after_sweep_c_hook;
 230 scm_t_c_hook scm_after_gc_c_hook;
 231
 232
 233 static void
 234 run_before_gc_c_hook (void)
 235 {
 236   if (!SCM_I_CURRENT_THREAD)
 237     /* GC while a thread is spinning up; punt.  */
 238     return;
 239
 240   scm_c_hook_run (&scm_before_gc_c_hook, NULL);
 241 }
 242
 243
 244 /* GC Statistics Keeping
 245  */
 246 unsigned long scm_gc_ports_collected = 0;
 247 static long gc_time_taken = 0;
 248 static long gc_start_time = 0;
 249
 250 static unsigned long free_space_divisor;
 251 static unsigned long minimum_free_space_divisor;
 252 static double target_free_space_divisor;
 253
 254 static unsigned long protected_obj_count = 0;
 255
 256
 257 SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
 258 SCM_SYMBOL (sym_heap_size, "heap-size");
 259 SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
 260 SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
 261 SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
 262 SCM_SYMBOL (sym_protected_objects, "protected-objects");
 263 SCM_SYMBOL (sym_times, "gc-times");
 264
 265
 266 /* {Scheme Interface to GC}
 267  */
 268 extern int scm_gc_malloc_yield_percentage;
 269 SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
 270             (),
 271             "Return an association list of statistics about Guile's current\n"
 272             "use of storage.\n")
 273 #define FUNC_NAME s_scm_gc_stats
 274 {
 275   SCM answer;
 276   GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
 277   size_t gc_times;
 278
 279   GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
 280                           &bytes_since_gc, &total_bytes);
 281 #ifdef HAVE_GC_GET_GC_NO
 282   /* This function was added in 7.2alpha2 (June 2009).  */
 283   gc_times = GC_get_gc_no ();
 284 #else
 285   /* This symbol is deprecated as of 7.3.  */
 286   gc_times = GC_gc_no;
 287 #endif
 288
 289   answer =
 290     scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
 291                 scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
 292                 scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
 293                 scm_cons (sym_heap_total_allocated,
 294                           scm_from_size_t (total_bytes)),
 295                 scm_cons (sym_heap_allocated_since_gc,
 296                           scm_from_size_t (bytes_since_gc)),
 297                 scm_cons (sym_protected_objects,
 298                           scm_from_ulong (protected_obj_count)),
 299                 scm_cons (sym_times, scm_from_size_t (gc_times)),
 300                 SCM_UNDEFINED);
 301
 302   return answer;
 303 }
 304 #undef FUNC_NAME
 305
 306
 307 SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
 308             (void),
 309             "Dump information about the garbage collector's internal data "
 310             "structures and memory usage to the standard output.")
 311 #define FUNC_NAME s_scm_gc_dump
 312 {
 313   GC_dump ();
 314
 315   return SCM_UNSPECIFIED;
 316 }
 317 #undef FUNC_NAME
 318
 319
 320 SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
 321             (SCM obj),
 322             "Return an integer that for the lifetime of @var{obj} is uniquely\n"
 323             "returned by this function for @var{obj}")
 324 #define FUNC_NAME s_scm_object_address
 325 {
 326   return scm_from_ulong (SCM_UNPACK (obj));
 327 }
 328 #undef FUNC_NAME
 329
 330
 331 SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
 332             (),
 333             "Disables the garbage collector.  Nested calls are permitted.  "
 334             "GC is re-enabled once @code{gc-enable} has been called the "
 335             "same number of times @code{gc-disable} was called.")
 336 #define FUNC_NAME s_scm_gc_disable
 337 {
 338   GC_disable ();
 339   return SCM_UNSPECIFIED;
 340 }
 341 #undef FUNC_NAME
 342
 343 SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
 344             (),
 345             "Enables the garbage collector.")
 346 #define FUNC_NAME s_scm_gc_enable
 347 {
 348   GC_enable ();
 349   return SCM_UNSPECIFIED;
 350 }
 351 #undef FUNC_NAME
 352
 353
 354 SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 355            (),
 356             "Scans all of SCM objects and reclaims for further use those that are\n"
 357             "no longer accessible.")
 358 #define FUNC_NAME s_scm_gc
 359 {
 360   scm_i_gc ("call");
 361   /* If you're calling scm_gc(), you probably want synchronous
 362      finalization.  */
 363   GC_invoke_finalizers ();
 364   return SCM_UNSPECIFIED;
 365 }
 366 #undef FUNC_NAME
 367
 368 void
 369 scm_i_gc (const char *what)
 370 {
 371 #ifndef HAVE_GC_SET_START_CALLBACK
 372   run_before_gc_c_hook ();
 373 #endif
 374   GC_gcollect ();
 375 }
 376
 377
 378 \f
 379 /* {GC Protection Helper Functions}
 380  */
 381
 382
 383 /*
 384  * If within a function you need to protect one or more scheme objects from
 385  * garbage collection, pass them as parameters to one of the
 386  * scm_remember_upto_here* functions below.  These functions don't do
 387  * anything, but since the compiler does not know that they are actually
 388  * no-ops, it will generate code that calls these functions with the given
 389  * parameters.  Therefore, you can be sure that the compiler will keep those
 390  * scheme values alive (on the stack or in a register) up to the point where
 391  * scm_remember_upto_here* is called.  In other words, place the call to
 392  * scm_remember_upto_here* _behind_ the last code in your function, that
 393  * depends on the scheme object to exist.
 394  *
 395  * Example: We want to make sure that the string object str does not get
 396  * garbage collected during the execution of 'some_function' in the code
 397  * below, because otherwise the characters belonging to str would be freed and
 398  * 'some_function' might access freed memory.  To make sure that the compiler
 399  * keeps str alive on the stack or in a register such that it is visible to
 400  * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
 401  * call to 'some_function'.  Note that this would not be necessary if str was
 402  * used anyway after the call to 'some_function'.
 403  *   char *chars = scm_i_string_chars (str);
 404  *   some_function (chars);
 405  *   scm_remember_upto_here_1 (str);  // str will be alive up to this point.
 406  */
 407
 408 /* Remove any macro versions of these while defining the functions.
 409    Functions are always included in the library, for upward binary
 410    compatibility and in case combinations of GCC and non-GCC are used.  */
 411 #undef scm_remember_upto_here_1
 412 #undef scm_remember_upto_here_2
 413
 414 void
 415 scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
 416 {
 417   /* Empty.  Protects a single object from garbage collection. */
 418 }
 419
 420 void
 421 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
 422 {
 423   /* Empty.  Protects two objects from garbage collection. */
 424 }
 425
 426 void
 427 scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
 428 {
 429   /* Empty.  Protects any number of objects from garbage collection. */
 430 }
 431
 432 /*
 433   These crazy functions prevent garbage collection
 434   of arguments after the first argument by
 435   ensuring they remain live throughout the
 436   function because they are used in the last
 437   line of the code block.
 438   It'd be better to have a nice compiler hint to
 439   aid the conservative stack-scanning GC. --03/09/00 gjb */
 440 SCM
 441 scm_return_first (SCM elt, ...)
 442 {
 443   return elt;
 444 }
 445
 446 int
 447 scm_return_first_int (int i, ...)
 448 {
 449   return i;
 450 }
 451
 452
 453 SCM
 454 scm_permanent_object (SCM obj)
 455 {
 456   return (scm_gc_protect_object (obj));
 457 }
 458
 459
 460 /* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
 461    other references are dropped, until the object is unprotected by calling
 462    scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
 463    i. e. it is possible to protect the same object several times, but it is
 464    necessary to unprotect the object the same number of times to actually get
 465    the object unprotected.  It is an error to unprotect an object more often
 466    than it has been protected before.  The function scm_protect_object returns
 467    OBJ.
 468 */
 469
 470 /* Implementation note:  For every object X, there is a counter which
 471    scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
 472 */
 473
 474
 475
 476 SCM
 477 scm_gc_protect_object (SCM obj)
 478 {
 479   SCM handle;
 480
 481   /* This critical section barrier will be replaced by a mutex. */
 482   /* njrev: Indeed; if my comment above is correct, there is the same
 483      critsec/mutex inconsistency here. */
 484   SCM_CRITICAL_SECTION_START;
 485
 486   handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
 487   SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
 488
 489   protected_obj_count ++;
 490
 491   SCM_CRITICAL_SECTION_END;
 492
 493   return obj;
 494 }
 495
 496
 497 /* Remove any protection for OBJ established by a prior call to
 498    scm_protect_object.  This function returns OBJ.
 499
 500    See scm_protect_object for more information.  */
 501 SCM
 502 scm_gc_unprotect_object (SCM obj)
 503 {
 504   SCM handle;
 505
 506   /* This critical section barrier will be replaced by a mutex. */
 507   /* njrev: and again. */
 508   SCM_CRITICAL_SECTION_START;
 509
 510   if (scm_gc_running_p)
 511     {
 512       fprintf (stderr, "scm_unprotect_object called during GC.\n");
 513       abort ();
 514     }
 515
 516   handle = scm_hashq_get_handle (scm_protects, obj);
 517
 518   if (scm_is_false (handle))
 519     {
 520       fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
 521       abort ();
 522     }
 523   else
 524     {
 525       SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
 526       if (scm_is_eq (count, scm_from_int (0)))
 527         scm_hashq_remove_x (scm_protects, obj);
 528       else
 529         SCM_SETCDR (handle, count);
 530     }
 531   protected_obj_count --;
 532
 533   SCM_CRITICAL_SECTION_END;
 534
 535   return obj;
 536 }
 537
 538 void
 539 scm_gc_register_root (SCM *p)
 540 {
 541   /* Nothing.  */
 542 }
 543
 544 void
 545 scm_gc_unregister_root (SCM *p)
 546 {
 547   /* Nothing.  */
 548 }
 549
 550 void
 551 scm_gc_register_roots (SCM *b, unsigned long n)
 552 {
 553   SCM *p = b;
 554   for (; p < b + n; ++p)
 555     scm_gc_register_root (p);
 556 }
 557
 558 void
 559 scm_gc_unregister_roots (SCM *b, unsigned long n)
 560 {
 561   SCM *p = b;
 562   for (; p < b + n; ++p)
 563     scm_gc_unregister_root (p);
 564 }
 565
 566 \f
 567
 568
 569 /*
 570   MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
 571  */
 572
 573 /* Get an integer from an environment variable.  */
 574 int
 575 scm_getenv_int (const char *var, int def)
 576 {
 577   char *end = 0;
 578   char *val = getenv (var);
 579   long res = def;
 580   if (!val)
 581     return def;
 582   res = strtol (val, &end, 10);
 583   if (end == val)
 584     return def;
 585   return res;
 586 }
 587
 588 #ifndef HAVE_GC_SET_FINALIZE_ON_DEMAND
 589 static void
 590 GC_set_finalize_on_demand (int foo)
 591 {
 592   GC_finalize_on_demand = foo;
 593 }
 594 #endif
 595
 596 void
 597 scm_storage_prehistory ()
 598 {
 599 #ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS
 600   /* This function was added in 7.2alpha2 (June 2009).  */
 601   GC_set_all_interior_pointers (0);
 602 #else
 603   /* This symbol is deprecated in 7.3.  */
 604   GC_all_interior_pointers = 0;
 605 #endif
 606
 607   free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
 608   minimum_free_space_divisor = free_space_divisor;
 609   target_free_space_divisor = free_space_divisor;
 610   GC_set_free_space_divisor (free_space_divisor);
 611   GC_set_finalize_on_demand (1);
 612
 613   GC_INIT ();
 614
 615 #if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \
 616     && (defined SCM_I_GSC_USE_PTHREAD_THREADS)
 617   /* When using GC 6.8, this call is required to initialize thread-local
 618      freelists (shouldn't be necessary with GC 7.0).  */
 619   GC_init ();
 620 #endif
 621
 622   GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
 623
 624   /* We only need to register a displacement for those types for which the
 625      higher bits of the type tag are used to store a pointer (that is, a
 626      pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
 627      handled in `scm_alloc_struct ()'.  */
 628   GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
 629   /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
 630
 631   /* Sanity check.  */
 632   if (!GC_is_visible (&scm_protects))
 633     abort ();
 634
 635   scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 636   scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
 637   scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 638   scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 639   scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 640 }
 641
 642 scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 643
 644 void
 645 scm_init_gc_protect_object ()
 646 {
 647   scm_protects = scm_c_make_hash_table (31);
 648
 649 #if 0
 650   /* We can't have a cleanup handler since we have no thread to run it
 651      in. */
 652
 653 #ifdef HAVE_ATEXIT
 654   atexit (cleanup);
 655 #else
 656 #ifdef HAVE_ON_EXIT
 657   on_exit (cleanup, 0);
 658 #endif
 659 #endif
 660
 661 #endif
 662 }
 663
 664 \f
 665
 666 SCM scm_after_gc_hook;
 667
 668 static SCM after_gc_async_cell;
 669
 670 /* The function after_gc_async_thunk causes the execution of the
 671  * after-gc-hook.  It is run after the gc, as soon as the asynchronous
 672  * events are handled by the evaluator.
 673  */
 674 static SCM
 675 after_gc_async_thunk (void)
 676 {
 677   /* Fun, no? Hook-run *and* run-hook?  */
 678   scm_c_hook_run (&scm_after_gc_c_hook, NULL);
 679   scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
 680   return SCM_UNSPECIFIED;
 681 }
 682
 683
 684 /* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
 685  * at the end of the garbage collection.  The only purpose of this
 686  * function is to mark the after_gc_async (which will eventually lead to
 687  * the execution of the after_gc_async_thunk).
 688  */
 689 static void *
 690 queue_after_gc_hook (void * hook_data SCM_UNUSED,
 691                       void *fn_data SCM_UNUSED,
 692                       void *data SCM_UNUSED)
 693 {
 694   /* If cell access debugging is enabled, the user may choose to perform
 695    * additional garbage collections after an arbitrary number of cell
 696    * accesses.  We don't want the scheme level after-gc-hook to be performed
 697    * for each of these garbage collections for the following reason: The
 698    * execution of the after-gc-hook causes cell accesses itself.  Thus, if the
 699    * after-gc-hook was performed with every gc, and if the gc was performed
 700    * after a very small number of cell accesses, then the number of cell
 701    * accesses during the execution of the after-gc-hook will suffice to cause
 702    * the execution of the next gc.  Then, guile would keep executing the
 703    * after-gc-hook over and over again, and would never come to do other
 704    * things.
 705    *
 706    * To overcome this problem, if cell access debugging with additional
 707    * garbage collections is enabled, the after-gc-hook is never run by the
 708    * garbage collecter.  When running guile with cell access debugging and the
 709    * execution of the after-gc-hook is desired, then it is necessary to run
 710    * the hook explicitly from the user code.  This has the effect, that from
 711    * the scheme level point of view it seems that garbage collection is
 712    * performed with a much lower frequency than it actually is.  Obviously,
 713    * this will not work for code that depends on a fixed one to one
 714    * relationship between the execution counts of the C level garbage
 715    * collection hooks and the execution count of the scheme level
 716    * after-gc-hook.
 717    */
 718
 719 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 720   if (scm_debug_cells_gc_interval == 0)
 721 #endif
 722     {
 723       scm_i_thread *t = SCM_I_CURRENT_THREAD;
 724
 725       if (scm_is_false (SCM_CDR (after_gc_async_cell)))
 726         {
 727           SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
 728           t->active_asyncs = after_gc_async_cell;
 729           t->pending_asyncs = 1;
 730         }
 731     }
 732
 733   return NULL;
 734 }
 735
 736 \f
 737
 738 static void *
 739 start_gc_timer (void * hook_data SCM_UNUSED,
 740                 void *fn_data SCM_UNUSED,
 741                 void *data SCM_UNUSED)
 742 {
 743   if (!gc_start_time)
 744     gc_start_time = scm_c_get_internal_run_time ();
 745
 746   return NULL;
 747 }
 748
 749 static void *
 750 accumulate_gc_timer (void * hook_data SCM_UNUSED,
 751                 void *fn_data SCM_UNUSED,
 752                 void *data SCM_UNUSED)
 753 {
 754   if (gc_start_time)
 755     {
 756       long now = scm_c_get_internal_run_time ();
 757       gc_time_taken += now - gc_start_time;
 758       gc_start_time = 0;
 759     }
 760
 761   return NULL;
 762 }
 763
 764 /* Return some idea of the memory footprint of a process, in bytes.
 765    Currently only works on Linux systems.  */
 766 static size_t
 767 get_image_size (void)
 768 {
 769   unsigned long size, resident, share;
 770   size_t ret = 0;
 771
 772   FILE *fp = fopen ("/proc/self/statm", "r");
 773
 774   if (fp && fscanf (fp, "%lu %lu %lu", &size, &resident, &share) == 3)
 775     ret = resident * 4096;
 776
 777   if (fp)
 778     fclose (fp);
 779
 780   return ret;
 781 }
 782
 783 /* These are discussed later.  */
 784 static size_t bytes_until_gc;
 785 static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 786
 787 /* Make GC run more frequently when the process image size is growing,
 788    measured against the number of bytes allocated through the GC.
 789
 790    If Guile is allocating at a GC-managed heap size H, libgc will tend
 791    to limit the process image size to H*N.  But if at the same time the
 792    user program is mallocating at a rate M bytes per GC-allocated byte,
 793    then the process stabilizes at H*N*M -- assuming that collecting data
 794    will result in malloc'd data being freed.  It doesn't take a very
 795    large M for this to be a bad situation.  To limit the image size,
 796    Guile should GC more often -- the bigger the M, the more often.
 797
 798    Numeric functions that produce bigger and bigger integers are
 799    pessimal, because M is an increasing function of time.  Here is an
 800    example of such a function:
 801
 802       (define (factorial n)
 803         (define (fac n acc)
 804           (if (<= n 1)
 805             acc
 806             (fac (1- n) (* n acc))))
 807         (fac n 1))
 808
 809    It is possible for a process to grow for reasons that will not be
 810    solved by faster GC.  In that case M will be estimated as
 811    artificially high for a while, and so GC will happen more often on
 812    the Guile side.  But when it stabilizes, Guile can ease back the GC
 813    frequency.
 814
 815    The key is to measure process image growth, not mallocation rate.
 816    For maximum effectiveness, Guile reacts quickly to process growth,
 817    and exponentially backs down when the process stops growing.
 818
 819    See http://thread.gmane.org/gmane.lisp.guile.devel/12552/focus=12936
 820    for further discussion.
 821  */
 822 static void *
 823 adjust_gc_frequency (void * hook_data SCM_UNUSED,
 824                      void *fn_data SCM_UNUSED,
 825                      void *data SCM_UNUSED)
 826 {
 827   static size_t prev_image_size = 0;
 828   static size_t prev_bytes_alloced = 0;
 829   size_t image_size;
 830   size_t bytes_alloced;
 831
 832   scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
 833   bytes_until_gc = GC_get_heap_size ();
 834   scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
 835
 836   image_size = get_image_size ();
 837   bytes_alloced = GC_get_total_bytes ();
 838
 839 #define HEURISTICS_DEBUG 0
 840
 841 #if HEURISTICS_DEBUG
 842   fprintf (stderr, "prev image / alloced: %lu / %lu\n", prev_image_size, prev_bytes_alloced);
 843   fprintf (stderr, "     image / alloced: %lu / %lu\n", image_size, bytes_alloced);
 844   fprintf (stderr, "divisor %lu / %f\n", free_space_divisor, target_free_space_divisor);
 845 #endif
 846
 847   if (prev_image_size && bytes_alloced != prev_bytes_alloced)
 848     {
 849       double growth_rate, new_target_free_space_divisor;
 850       double decay_factor = 0.5;
 851       double hysteresis = 0.1;
 852
 853       growth_rate = ((double) image_size - prev_image_size)
 854         / ((double)bytes_alloced - prev_bytes_alloced);
 855
 856 #if HEURISTICS_DEBUG
 857       fprintf (stderr, "growth rate %f\n", growth_rate);
 858 #endif
 859
 860       new_target_free_space_divisor = minimum_free_space_divisor;
 861
 862       if (growth_rate > 0)
 863         new_target_free_space_divisor *= 1.0 + growth_rate;
 864
 865 #if HEURISTICS_DEBUG
 866       fprintf (stderr, "new divisor %f\n", new_target_free_space_divisor);
 867 #endif
 868
 869       if (new_target_free_space_divisor < target_free_space_divisor)
 870         /* Decay down.  */
 871         target_free_space_divisor =
 872           (decay_factor * target_free_space_divisor
 873            + (1.0 - decay_factor) * new_target_free_space_divisor);
 874       else
 875         /* Jump up.  */
 876         target_free_space_divisor = new_target_free_space_divisor;
 877
 878 #if HEURISTICS_DEBUG
 879       fprintf (stderr, "new target divisor %f\n", target_free_space_divisor);
 880 #endif
 881
 882       if (free_space_divisor + 0.5 + hysteresis < target_free_space_divisor
 883           || free_space_divisor - 0.5 - hysteresis > target_free_space_divisor)
 884         {
 885           free_space_divisor = lround (target_free_space_divisor);
 886 #if HEURISTICS_DEBUG
 887           fprintf (stderr, "new divisor %lu\n", free_space_divisor);
 888 #endif
 889           GC_set_free_space_divisor (free_space_divisor);
 890         }
 891     }
 892
 893   prev_image_size = image_size;
 894   prev_bytes_alloced = bytes_alloced;
 895
 896   return NULL;
 897 }
 898
 899 /* The adjust_gc_frequency routine handles transients in the process
 900    image size.  It can't handle instense non-GC-managed steady-state
 901    allocation though, as it decays the FSD at steady-state down to its
 902    minimum value.
 903
 904    The only real way to handle continuous, high non-GC allocation is to
 905    let the GC know about it.  This routine can handle non-GC allocation
 906    rates that are similar in size to the GC-managed heap size.
 907  */
 908
 909 void
 910 scm_gc_register_allocation (size_t size)
 911 {
 912   scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
 913   if (bytes_until_gc - size > bytes_until_gc)
 914     {
 915       bytes_until_gc = GC_get_heap_size ();
 916       scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
 917       GC_gcollect ();
 918     }
 919   else
 920     {
 921       bytes_until_gc -= size;
 922       scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
 923     }
 924 }
 925
 926
 927 \f
 928
 929 char const *
 930 scm_i_tag_name (scm_t_bits tag)
 931 {
 932   switch (tag & 0x7f) /* 7 bits */
 933     {
 934     case scm_tcs_struct:
 935       return "struct";
 936     case scm_tcs_cons_imcar:
 937       return "cons (immediate car)";
 938     case scm_tcs_cons_nimcar:
 939       return "cons (non-immediate car)";
 940     case scm_tc7_pointer:
 941       return "foreign";
 942     case scm_tc7_hashtable:
 943       return "hashtable";
 944     case scm_tc7_fluid:
 945       return "fluid";
 946     case scm_tc7_dynamic_state:
 947       return "dynamic state";
 948     case scm_tc7_frame:
 949       return "frame";
 950     case scm_tc7_objcode:
 951       return "objcode";
 952     case scm_tc7_vm:
 953       return "vm";
 954     case scm_tc7_vm_cont:
 955       return "vm continuation";
 956     case scm_tc7_wvect:
 957       return "weak vector";
 958     case scm_tc7_vector:
 959       return "vector";
 960     case scm_tc7_number:
 961       switch (tag)
 962         {
 963         case scm_tc16_real:
 964           return "real";
 965           break;
 966         case scm_tc16_big:
 967           return "bignum";
 968           break;
 969         case scm_tc16_complex:
 970           return "complex number";
 971           break;
 972         case scm_tc16_fraction:
 973           return "fraction";
 974           break;
 975         }
 976       break;
 977     case scm_tc7_string:
 978       return "string";
 979       break;
 980     case scm_tc7_stringbuf:
 981       return "string buffer";
 982       break;
 983     case scm_tc7_symbol:
 984       return "symbol";
 985       break;
 986     case scm_tc7_variable:
 987       return "variable";
 988       break;
 989     case scm_tc7_port:
 990       return "port";
 991       break;
 992     case scm_tc7_smob:
 993       {
 994         int k = 0xff & (tag >> 8);
 995         return (scm_smobs[k].name);
 996       }
 997       break;
 998     }
 999
1000   return NULL;
1001 }
1002
1003
1004
1005 \f
1006 void
1007 scm_init_gc ()
1008 {
1009   /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'.  */
1010
1011   scm_after_gc_hook = scm_make_hook (SCM_INUM0);
1012   scm_c_define ("after-gc-hook", scm_after_gc_hook);
1013
1014   /* When the async is to run, the cdr of the gc_async pair gets set to
1015      the asyncs queue of the current thread.  */
1016   after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
1017                                                     after_gc_async_thunk),
1018                                   SCM_BOOL_F);
1019
1020   scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
1021   scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
1022   scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
1023
1024 #if HAVE_GC_GET_HEAP_USAGE_SAFE
1025   /* GC_get_heap_usage does not take a lock, and so can run in the GC
1026      start hook.  */
1027   scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0);
1028 #else
1029   /* GC_get_heap_usage might take a lock (and did from 7.2alpha1 to
1030      7.2alpha7), so call it in the after_gc_hook.  */
1031   scm_c_hook_add (&scm_after_gc_c_hook, adjust_gc_frequency, NULL, 0);
1032 #endif
1033
1034 #ifdef HAVE_GC_SET_START_CALLBACK
1035   GC_set_start_callback (run_before_gc_c_hook);
1036 #endif
1037
1038 #include "libguile/gc.x"
1039 }
1040
1041
1042 void
1043 scm_gc_sweep (void)
1044 #define FUNC_NAME "scm_gc_sweep"
1045 {
1046   /* FIXME */
1047   fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
1048 }
1049 #undef FUNC_NAME
1050
1051 /*
1052   Local Variables:
1053   c-file-style: "gnu"
1054   End:
1055 */