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 #include "libguile/gen-scmconfig.h"
  27
  28 #include <stdio.h>
  29 #include <errno.h>
  30 #include <string.h>
  31 #include <stdlib.h>
  32 #include <math.h>
  33
  34 #ifdef __ia64__
  35 #include <ucontext.h>
  36 extern unsigned long * __libc_ia64_register_backing_store_base;
  37 #endif
  38
  39 #include "libguile/_scm.h"
  40 #include "libguile/eval.h"
  41 #include "libguile/stime.h"
  42 #include "libguile/stackchk.h"
  43 #include "libguile/struct.h"
  44 #include "libguile/smob.h"
  45 #include "libguile/arrays.h"
  46 #include "libguile/async.h"
  47 #include "libguile/ports.h"
  48 #include "libguile/root.h"
  49 #include "libguile/simpos.h"
  50 #include "libguile/strings.h"
  51 #include "libguile/vectors.h"
  52 #include "libguile/hashtab.h"
  53 #include "libguile/tags.h"
  54
  55 #include "libguile/validate.h"
  56 #include "libguile/deprecation.h"
  57 #include "libguile/gc.h"
  58 #include "libguile/dynwind.h"
  59
  60 #include "libguile/bdw-gc.h"
  61
  62 /* For GC_set_start_callback.  */
  63 #include <gc/gc_mark.h>
  64
  65 #ifdef GUILE_DEBUG_MALLOC
  66 #include "libguile/debug-malloc.h"
  67 #endif
  68
  69 #ifdef HAVE_UNISTD_H
  70 #include <unistd.h>
  71 #endif
  72
  73 /* Size in bytes of the initial heap.  This should be about the size of
  74    result of 'guile -c "(display (assq-ref (gc-stats)
  75    'heap-total-allocated))"'.  */
  76
  77 #define DEFAULT_INITIAL_HEAP_SIZE (128 * 1024 * SIZEOF_SCM_T_BITS)
  78
  79 /* Set this to != 0 if every cell that is accessed shall be checked:
  80  */
  81 int scm_debug_cell_accesses_p = 0;
  82 int scm_expensive_debug_cell_accesses_p = 0;
  83
  84 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
  85  * the number of cell accesses after which a gc shall be called.
  86  */
  87 int scm_debug_cells_gc_interval = 0;
  88
  89 /* Hash table that keeps a reference to objects the user wants to protect from
  90    garbage collection.  */
  91 static SCM scm_protects;
  92
  93
  94 #if (SCM_DEBUG_CELL_ACCESSES == 1)
  95
  96
  97 /*
  98
  99   Assert that the given object is a valid reference to a valid cell.  This
 100   test involves to determine whether the object is a cell pointer, whether
 101   this pointer actually points into a heap segment and whether the cell
 102   pointed to is not a free cell.  Further, additional garbage collections may
 103   get executed after a user defined number of cell accesses.  This helps to
 104   find places in the C code where references are dropped for extremely short
 105   periods.
 106
 107 */
 108 void
 109 scm_i_expensive_validation_check (SCM cell)
 110 {
 111   /* If desired, perform additional garbage collections after a user
 112    * defined number of cell accesses.
 113    */
 114   if (scm_debug_cells_gc_interval)
 115     {
 116       static unsigned int counter = 0;
 117
 118       if (counter != 0)
 119         {
 120           --counter;
 121         }
 122       else
 123         {
 124           counter = scm_debug_cells_gc_interval;
 125           scm_gc ();
 126         }
 127     }
 128 }
 129
 130 /* Whether cell validation is already running.  */
 131 static int scm_i_cell_validation_already_running = 0;
 132
 133 void
 134 scm_assert_cell_valid (SCM cell)
 135 {
 136   if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
 137     {
 138       scm_i_cell_validation_already_running = 1;  /* set to avoid recursion */
 139
 140       /*
 141         During GC, no user-code should be run, and the guile core
 142         should use non-protected accessors.
 143       */
 144       if (scm_gc_running_p)
 145         return;
 146
 147       /*
 148         Only scm_in_heap_p and rescanning the heap is wildly
 149         expensive.
 150       */
 151       if (scm_expensive_debug_cell_accesses_p)
 152         scm_i_expensive_validation_check (cell);
 153
 154       scm_i_cell_validation_already_running = 0;  /* re-enable */
 155     }
 156 }
 157
 158
 159
 160 SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
 161             (SCM flag),
 162             "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
 163             "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
 164             "but no additional calls to garbage collection are issued.\n"
 165             "If @var{flag} is a number, strict cell access checking is enabled,\n"
 166             "with an additional garbage collection after the given\n"
 167             "number of cell accesses.\n"
 168             "This procedure only exists when the compile-time flag\n"
 169             "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
 170 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
 171 {
 172   if (scm_is_false (flag))
 173     {
 174       scm_debug_cell_accesses_p = 0;
 175     }
 176   else if (scm_is_eq (flag, SCM_BOOL_T))
 177     {
 178       scm_debug_cells_gc_interval = 0;
 179       scm_debug_cell_accesses_p = 1;
 180       scm_expensive_debug_cell_accesses_p = 0;
 181     }
 182   else
 183     {
 184       scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
 185       scm_debug_cell_accesses_p = 1;
 186       scm_expensive_debug_cell_accesses_p = 1;
 187     }
 188   return SCM_UNSPECIFIED;
 189 }
 190 #undef FUNC_NAME
 191
 192
 193 #endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
 194
 195
 196 \f
 197
 198 static int needs_gc_after_nonlocal_exit = 0;
 199
 200 /* Arrange to throw an exception on failed allocations.  */
 201 static void*
 202 scm_oom_fn (size_t nbytes)
 203 {
 204   needs_gc_after_nonlocal_exit = 1;
 205   scm_report_out_of_memory ();
 206   return NULL;
 207 }
 208
 209 /* Called within GC -- cannot allocate GC memory.  */
 210 static void
 211 scm_gc_warn_proc (char *fmt, GC_word arg)
 212 {
 213   SCM port;
 214   FILE *stream = NULL;
 215
 216   port = scm_current_warning_port ();
 217   if (!SCM_OPPORTP (port))
 218     return;
 219
 220   if (SCM_FPORTP (port))
 221     {
 222       int fd;
 223       scm_force_output (port);
 224       if (!SCM_OPPORTP (port))
 225         return;
 226       fd = dup (SCM_FPORT_FDES (port));
 227       if (fd == -1)
 228         perror ("Failed to dup warning port fd");
 229       else
 230         {
 231           stream = fdopen (fd, "a");
 232           if (!stream)
 233             {
 234               perror ("Failed to open stream for warning port");
 235               close (fd);
 236             }
 237         }
 238     }
 239
 240   fprintf (stream ? stream : stderr, fmt, arg);
 241
 242   if (stream)
 243     fclose (stream);
 244 }
 245
 246 void
 247 scm_gc_after_nonlocal_exit (void)
 248 {
 249   if (needs_gc_after_nonlocal_exit)
 250     {
 251       needs_gc_after_nonlocal_exit = 0;
 252       GC_gcollect_and_unmap ();
 253     }
 254 }
 255
 256
 257 \f
 258
 259 /* Hooks.  */
 260 scm_t_c_hook scm_before_gc_c_hook;
 261 scm_t_c_hook scm_before_mark_c_hook;
 262 scm_t_c_hook scm_before_sweep_c_hook;
 263 scm_t_c_hook scm_after_sweep_c_hook;
 264 scm_t_c_hook scm_after_gc_c_hook;
 265
 266
 267 static void
 268 run_before_gc_c_hook (void)
 269 {
 270   if (!SCM_I_CURRENT_THREAD)
 271     /* GC while a thread is spinning up; punt.  */
 272     return;
 273
 274   scm_c_hook_run (&scm_before_gc_c_hook, NULL);
 275 }
 276
 277
 278 /* GC Statistics Keeping
 279  */
 280 unsigned long scm_gc_ports_collected = 0;
 281 static long gc_time_taken = 0;
 282 static long gc_start_time = 0;
 283
 284 static unsigned long free_space_divisor;
 285 static unsigned long minimum_free_space_divisor;
 286 static double target_free_space_divisor;
 287
 288 static unsigned long protected_obj_count = 0;
 289
 290
 291 SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
 292 SCM_SYMBOL (sym_heap_size, "heap-size");
 293 SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
 294 SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
 295 SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
 296 SCM_SYMBOL (sym_protected_objects, "protected-objects");
 297 SCM_SYMBOL (sym_times, "gc-times");
 298
 299
 300 /* {Scheme Interface to GC}
 301  */
 302 extern int scm_gc_malloc_yield_percentage;
 303 SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
 304             (),
 305             "Return an association list of statistics about Guile's current\n"
 306             "use of storage.\n")
 307 #define FUNC_NAME s_scm_gc_stats
 308 {
 309   SCM answer;
 310   GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
 311   size_t gc_times;
 312
 313   GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
 314                           &bytes_since_gc, &total_bytes);
 315   gc_times = GC_get_gc_no ();
 316
 317   answer =
 318     scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
 319                 scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
 320                 scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
 321                 scm_cons (sym_heap_total_allocated,
 322                           scm_from_size_t (total_bytes)),
 323                 scm_cons (sym_heap_allocated_since_gc,
 324                           scm_from_size_t (bytes_since_gc)),
 325                 scm_cons (sym_protected_objects,
 326                           scm_from_ulong (protected_obj_count)),
 327                 scm_cons (sym_times, scm_from_size_t (gc_times)),
 328                 SCM_UNDEFINED);
 329
 330   return answer;
 331 }
 332 #undef FUNC_NAME
 333
 334
 335 SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
 336             (void),
 337             "Dump information about the garbage collector's internal data "
 338             "structures and memory usage to the standard output.")
 339 #define FUNC_NAME s_scm_gc_dump
 340 {
 341   GC_dump ();
 342
 343   return SCM_UNSPECIFIED;
 344 }
 345 #undef FUNC_NAME
 346
 347
 348 SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
 349             (SCM obj),
 350             "Return an integer that for the lifetime of @var{obj} is uniquely\n"
 351             "returned by this function for @var{obj}")
 352 #define FUNC_NAME s_scm_object_address
 353 {
 354   return scm_from_ulong (SCM_UNPACK (obj));
 355 }
 356 #undef FUNC_NAME
 357
 358
 359 SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
 360             (),
 361             "Disables the garbage collector.  Nested calls are permitted.  "
 362             "GC is re-enabled once @code{gc-enable} has been called the "
 363             "same number of times @code{gc-disable} was called.")
 364 #define FUNC_NAME s_scm_gc_disable
 365 {
 366   GC_disable ();
 367   return SCM_UNSPECIFIED;
 368 }
 369 #undef FUNC_NAME
 370
 371 SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
 372             (),
 373             "Enables the garbage collector.")
 374 #define FUNC_NAME s_scm_gc_enable
 375 {
 376   GC_enable ();
 377   return SCM_UNSPECIFIED;
 378 }
 379 #undef FUNC_NAME
 380
 381
 382 SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 383            (),
 384             "Scans all of SCM objects and reclaims for further use those that are\n"
 385             "no longer accessible.")
 386 #define FUNC_NAME s_scm_gc
 387 {
 388   scm_i_gc ("call");
 389   /* If you're calling scm_gc(), you probably want synchronous
 390      finalization.  */
 391   GC_invoke_finalizers ();
 392   return SCM_UNSPECIFIED;
 393 }
 394 #undef FUNC_NAME
 395
 396 void
 397 scm_i_gc (const char *what)
 398 {
 399   GC_gcollect ();
 400 }
 401
 402
 403 \f
 404 /* {GC Protection Helper Functions}
 405  */
 406
 407
 408 /*
 409  * If within a function you need to protect one or more scheme objects from
 410  * garbage collection, pass them as parameters to one of the
 411  * scm_remember_upto_here* functions below.  These functions don't do
 412  * anything, but since the compiler does not know that they are actually
 413  * no-ops, it will generate code that calls these functions with the given
 414  * parameters.  Therefore, you can be sure that the compiler will keep those
 415  * scheme values alive (on the stack or in a register) up to the point where
 416  * scm_remember_upto_here* is called.  In other words, place the call to
 417  * scm_remember_upto_here* _behind_ the last code in your function, that
 418  * depends on the scheme object to exist.
 419  *
 420  * Example: We want to make sure that the string object str does not get
 421  * garbage collected during the execution of 'some_function' in the code
 422  * below, because otherwise the characters belonging to str would be freed and
 423  * 'some_function' might access freed memory.  To make sure that the compiler
 424  * keeps str alive on the stack or in a register such that it is visible to
 425  * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
 426  * call to 'some_function'.  Note that this would not be necessary if str was
 427  * used anyway after the call to 'some_function'.
 428  *   char *chars = scm_i_string_chars (str);
 429  *   some_function (chars);
 430  *   scm_remember_upto_here_1 (str);  // str will be alive up to this point.
 431  */
 432
 433 /* Remove any macro versions of these while defining the functions.
 434    Functions are always included in the library, for upward binary
 435    compatibility and in case combinations of GCC and non-GCC are used.  */
 436 #undef scm_remember_upto_here_1
 437 #undef scm_remember_upto_here_2
 438
 439 void
 440 scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
 441 {
 442   /* Empty.  Protects a single object from garbage collection. */
 443 }
 444
 445 void
 446 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
 447 {
 448   /* Empty.  Protects two objects from garbage collection. */
 449 }
 450
 451 void
 452 scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
 453 {
 454   /* Empty.  Protects any number of objects from garbage collection. */
 455 }
 456
 457 /*
 458   These crazy functions prevent garbage collection
 459   of arguments after the first argument by
 460   ensuring they remain live throughout the
 461   function because they are used in the last
 462   line of the code block.
 463   It'd be better to have a nice compiler hint to
 464   aid the conservative stack-scanning GC. --03/09/00 gjb */
 465 SCM
 466 scm_return_first (SCM elt, ...)
 467 {
 468   return elt;
 469 }
 470
 471 int
 472 scm_return_first_int (int i, ...)
 473 {
 474   return i;
 475 }
 476
 477
 478 SCM
 479 scm_permanent_object (SCM obj)
 480 {
 481   return (scm_gc_protect_object (obj));
 482 }
 483
 484
 485 /* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
 486    other references are dropped, until the object is unprotected by calling
 487    scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
 488    i. e. it is possible to protect the same object several times, but it is
 489    necessary to unprotect the object the same number of times to actually get
 490    the object unprotected.  It is an error to unprotect an object more often
 491    than it has been protected before.  The function scm_protect_object returns
 492    OBJ.
 493 */
 494
 495 /* Implementation note:  For every object X, there is a counter which
 496    scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
 497 */
 498
 499
 500
 501 SCM
 502 scm_gc_protect_object (SCM obj)
 503 {
 504   SCM handle;
 505
 506   /* This critical section barrier will be replaced by a mutex. */
 507   /* njrev: Indeed; if my comment above is correct, there is the same
 508      critsec/mutex inconsistency here. */
 509   SCM_CRITICAL_SECTION_START;
 510
 511   handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
 512   SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
 513
 514   protected_obj_count ++;
 515
 516   SCM_CRITICAL_SECTION_END;
 517
 518   return obj;
 519 }
 520
 521
 522 /* Remove any protection for OBJ established by a prior call to
 523    scm_protect_object.  This function returns OBJ.
 524
 525    See scm_protect_object for more information.  */
 526 SCM
 527 scm_gc_unprotect_object (SCM obj)
 528 {
 529   SCM handle;
 530
 531   /* This critical section barrier will be replaced by a mutex. */
 532   /* njrev: and again. */
 533   SCM_CRITICAL_SECTION_START;
 534
 535   if (scm_gc_running_p)
 536     {
 537       fprintf (stderr, "scm_unprotect_object called during GC.\n");
 538       abort ();
 539     }
 540
 541   handle = scm_hashq_get_handle (scm_protects, obj);
 542
 543   if (scm_is_false (handle))
 544     {
 545       fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
 546       abort ();
 547     }
 548   else
 549     {
 550       SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
 551       if (scm_is_eq (count, scm_from_int (0)))
 552         scm_hashq_remove_x (scm_protects, obj);
 553       else
 554         SCM_SETCDR (handle, count);
 555     }
 556   protected_obj_count --;
 557
 558   SCM_CRITICAL_SECTION_END;
 559
 560   return obj;
 561 }
 562
 563 void
 564 scm_gc_register_root (SCM *p)
 565 {
 566   /* Nothing.  */
 567 }
 568
 569 void
 570 scm_gc_unregister_root (SCM *p)
 571 {
 572   /* Nothing.  */
 573 }
 574
 575 void
 576 scm_gc_register_roots (SCM *b, unsigned long n)
 577 {
 578   SCM *p = b;
 579   for (; p < b + n; ++p)
 580     scm_gc_register_root (p);
 581 }
 582
 583 void
 584 scm_gc_unregister_roots (SCM *b, unsigned long n)
 585 {
 586   SCM *p = b;
 587   for (; p < b + n; ++p)
 588     scm_gc_unregister_root (p);
 589 }
 590
 591 \f
 592
 593
 594 void
 595 scm_storage_prehistory ()
 596 {
 597   GC_set_all_interior_pointers (0);
 598
 599   free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
 600   minimum_free_space_divisor = free_space_divisor;
 601   target_free_space_divisor = free_space_divisor;
 602   GC_set_free_space_divisor (free_space_divisor);
 603   GC_set_finalize_on_demand (1);
 604
 605 #if (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 4     \
 606      && GC_ALPHA_VERSION == 0)
 607   /* BDW-GC 7.4.0 has a bug making it loop indefinitely when using more
 608      than one marker thread: <https://github.com/ivmai/bdwgc/pull/30>.
 609      Work around it by asking for one marker thread.  */
 610   setenv ("GC_MARKERS", "1", 1);
 611 #endif
 612
 613   GC_INIT ();
 614
 615   GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE);
 616
 617   /* We only need to register a displacement for those types for which the
 618      higher bits of the type tag are used to store a pointer (that is, a
 619      pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
 620      handled in `scm_alloc_struct ()'.  */
 621   GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
 622   /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
 623
 624   /* Sanity check.  */
 625   if (!GC_is_visible (&scm_protects))
 626     abort ();
 627
 628   scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 629   scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
 630   scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 631   scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 632   scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 633 }
 634
 635 scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 636
 637 void
 638 scm_init_gc_protect_object ()
 639 {
 640   scm_protects = scm_c_make_hash_table (31);
 641
 642 #if 0
 643   /* We can't have a cleanup handler since we have no thread to run it
 644      in. */
 645
 646 #ifdef HAVE_ATEXIT
 647   atexit (cleanup);
 648 #else
 649 #ifdef HAVE_ON_EXIT
 650   on_exit (cleanup, 0);
 651 #endif
 652 #endif
 653
 654 #endif
 655 }
 656
 657 \f
 658
 659 SCM scm_after_gc_hook;
 660
 661 static SCM after_gc_async_cell;
 662
 663 /* The function after_gc_async_thunk causes the execution of the
 664  * after-gc-hook.  It is run after the gc, as soon as the asynchronous
 665  * events are handled by the evaluator.
 666  */
 667 static SCM
 668 after_gc_async_thunk (void)
 669 {
 670   /* Fun, no? Hook-run *and* run-hook?  */
 671   scm_c_hook_run (&scm_after_gc_c_hook, NULL);
 672   scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
 673   return SCM_UNSPECIFIED;
 674 }
 675
 676
 677 /* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
 678  * at the end of the garbage collection.  The only purpose of this
 679  * function is to mark the after_gc_async (which will eventually lead to
 680  * the execution of the after_gc_async_thunk).
 681  */
 682 static void *
 683 queue_after_gc_hook (void * hook_data SCM_UNUSED,
 684                       void *fn_data SCM_UNUSED,
 685                       void *data SCM_UNUSED)
 686 {
 687   /* If cell access debugging is enabled, the user may choose to perform
 688    * additional garbage collections after an arbitrary number of cell
 689    * accesses.  We don't want the scheme level after-gc-hook to be performed
 690    * for each of these garbage collections for the following reason: The
 691    * execution of the after-gc-hook causes cell accesses itself.  Thus, if the
 692    * after-gc-hook was performed with every gc, and if the gc was performed
 693    * after a very small number of cell accesses, then the number of cell
 694    * accesses during the execution of the after-gc-hook will suffice to cause
 695    * the execution of the next gc.  Then, guile would keep executing the
 696    * after-gc-hook over and over again, and would never come to do other
 697    * things.
 698    *
 699    * To overcome this problem, if cell access debugging with additional
 700    * garbage collections is enabled, the after-gc-hook is never run by the
 701    * garbage collecter.  When running guile with cell access debugging and the
 702    * execution of the after-gc-hook is desired, then it is necessary to run
 703    * the hook explicitly from the user code.  This has the effect, that from
 704    * the scheme level point of view it seems that garbage collection is
 705    * performed with a much lower frequency than it actually is.  Obviously,
 706    * this will not work for code that depends on a fixed one to one
 707    * relationship between the execution counts of the C level garbage
 708    * collection hooks and the execution count of the scheme level
 709    * after-gc-hook.
 710    */
 711
 712 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 713   if (scm_debug_cells_gc_interval == 0)
 714 #endif
 715     {
 716       scm_i_thread *t = SCM_I_CURRENT_THREAD;
 717
 718       if (scm_is_false (SCM_CDR (after_gc_async_cell)))
 719         {
 720           SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
 721           t->active_asyncs = after_gc_async_cell;
 722           t->pending_asyncs = 1;
 723         }
 724     }
 725
 726   return NULL;
 727 }
 728
 729 \f
 730
 731 static void *
 732 start_gc_timer (void * hook_data SCM_UNUSED,
 733                 void *fn_data SCM_UNUSED,
 734                 void *data SCM_UNUSED)
 735 {
 736   if (!gc_start_time)
 737     gc_start_time = scm_c_get_internal_run_time ();
 738
 739   return NULL;
 740 }
 741
 742 static void *
 743 accumulate_gc_timer (void * hook_data SCM_UNUSED,
 744                 void *fn_data SCM_UNUSED,
 745                 void *data SCM_UNUSED)
 746 {
 747   if (gc_start_time)
 748     {
 749       long now = scm_c_get_internal_run_time ();
 750       gc_time_taken += now - gc_start_time;
 751       gc_start_time = 0;
 752     }
 753
 754   return NULL;
 755 }
 756
 757 static size_t bytes_until_gc = DEFAULT_INITIAL_HEAP_SIZE;
 758 static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 759
 760 void
 761 scm_gc_register_allocation (size_t size)
 762 {
 763   scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
 764   if (bytes_until_gc - size > bytes_until_gc)
 765     {
 766       bytes_until_gc = GC_get_heap_size ();
 767       scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
 768       GC_gcollect ();
 769     }
 770   else
 771     {
 772       bytes_until_gc -= size;
 773       scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
 774     }
 775 }
 776
 777
 778 \f
 779 void
 780 scm_init_gc ()
 781 {
 782   /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'.  */
 783
 784   scm_after_gc_hook = scm_make_hook (SCM_INUM0);
 785   scm_c_define ("after-gc-hook", scm_after_gc_hook);
 786
 787   /* When the async is to run, the cdr of the gc_async pair gets set to
 788      the asyncs queue of the current thread.  */
 789   after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
 790                                                     after_gc_async_thunk),
 791                                   SCM_BOOL_F);
 792
 793   scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
 794   scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
 795   scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
 796
 797   GC_set_oom_fn (scm_oom_fn);
 798   GC_set_warn_proc (scm_gc_warn_proc);
 799   GC_set_start_callback (run_before_gc_c_hook);
 800
 801 #include "libguile/gc.x"
 802 }
 803
 804
 805 void
 806 scm_gc_sweep (void)
 807 #define FUNC_NAME "scm_gc_sweep"
 808 {
 809   /* FIXME */
 810   fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
 811 }
 812 #undef FUNC_NAME
 813
 814 /*
 815   Local Variables:
 816   c-file-style: "gnu"
 817   End:
 818 */