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