libguile/gc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 /* #define DEBUGINFO */
  20
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include "libguile/gen-scmconfig.h"
  26
  27 #include <stdio.h>
  28 #include <errno.h>
  29 #include <string.h>
  30
  31 #ifdef __ia64__
  32 #include <ucontext.h>
  33 extern unsigned long * __libc_ia64_register_backing_store_base;
  34 #endif
  35
  36 #include "libguile/_scm.h"
  37 #include "libguile/eval.h"
  38 #include "libguile/stime.h"
  39 #include "libguile/stackchk.h"
  40 #include "libguile/struct.h"
  41 #include "libguile/smob.h"
  42 #include "libguile/arrays.h"
  43 #include "libguile/async.h"
  44 #include "libguile/ports.h"
  45 #include "libguile/root.h"
  46 #include "libguile/strings.h"
  47 #include "libguile/vectors.h"
  48 #include "libguile/weaks.h"
  49 #include "libguile/hashtab.h"
  50 #include "libguile/tags.h"
  51
  52 #include "libguile/private-gc.h"
  53 #include "libguile/validate.h"
  54 #include "libguile/deprecation.h"
  55 #include "libguile/gc.h"
  56 #include "libguile/dynwind.h"
  57
  58 #include "libguile/bdw-gc.h"
  59
  60 /* For GC_set_start_callback.  */
  61 #include <gc/gc_mark.h>
  62
  63 #ifdef GUILE_DEBUG_MALLOC
  64 #include "libguile/debug-malloc.h"
  65 #endif
  66
  67 #ifdef HAVE_MALLOC_H
  68 #include <malloc.h>
  69 #endif
  70
  71 #ifdef HAVE_UNISTD_H
  72 #include <unistd.h>
  73 #endif
  74
  75 /* Set this to != 0 if every cell that is accessed shall be checked:
  76  */
  77 int scm_debug_cell_accesses_p = 0;
  78 int scm_expensive_debug_cell_accesses_p = 0;
  79
  80 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
  81  * the number of cell accesses after which a gc shall be called.
  82  */
  83 int scm_debug_cells_gc_interval = 0;
  84
  85 #if SCM_ENABLE_DEPRECATED == 1
  86 /* Hash table that keeps a reference to objects the user wants to protect from
  87    garbage collection.  It could arguably be private but applications have come
  88    to rely on it (e.g., Lilypond 2.13.9).  */
  89 SCM scm_protects;
  90 #else
  91 static SCM scm_protects;
  92 #endif
  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 \f
 196
 197 #ifndef HAVE_GC_GET_HEAP_USAGE_SAFE
 198 static void
 199 GC_get_heap_usage_safe (GC_word *pheap_size, GC_word *pfree_bytes,
 200                         GC_word *punmapped_bytes, GC_word *pbytes_since_gc,
 201                         GC_word *ptotal_bytes)
 202 {
 203   *pheap_size = GC_get_heap_size ();
 204   *pfree_bytes = GC_get_free_bytes ();
 205   *punmapped_bytes = GC_get_unmapped_bytes ();
 206   *pbytes_since_gc = GC_get_bytes_since_gc ();
 207   *ptotal_bytes = GC_get_total_bytes ();
 208 }
 209 #endif
 210
 211 \f
 212 /* Hooks.  */
 213 scm_t_c_hook scm_before_gc_c_hook;
 214 scm_t_c_hook scm_before_mark_c_hook;
 215 scm_t_c_hook scm_before_sweep_c_hook;
 216 scm_t_c_hook scm_after_sweep_c_hook;
 217 scm_t_c_hook scm_after_gc_c_hook;
 218
 219
 220 static void
 221 run_before_gc_c_hook (void)
 222 {
 223   scm_c_hook_run (&scm_before_gc_c_hook, NULL);
 224 }
 225
 226
 227 /* GC Statistics Keeping
 228  */
 229 unsigned long scm_gc_ports_collected = 0;
 230 static long gc_time_taken = 0;
 231 static long gc_start_time = 0;
 232
 233
 234 static unsigned long protected_obj_count = 0;
 235
 236
 237 SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
 238 SCM_SYMBOL (sym_heap_size, "heap-size");
 239 SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
 240 SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
 241 SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
 242 SCM_SYMBOL (sym_protected_objects, "protected-objects");
 243 SCM_SYMBOL (sym_times, "gc-times");
 244
 245
 246 /* {Scheme Interface to GC}
 247  */
 248 static SCM
 249 tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
 250 {
 251   if (scm_is_integer (key))
 252     {
 253       int c_tag = scm_to_int (key);
 254
 255       char const * name = scm_i_tag_name (c_tag);
 256       if (name != NULL)
 257         {
 258           key = scm_from_locale_string (name);
 259         }
 260       else
 261         {
 262           char s[100];
 263           sprintf (s, "tag %d", c_tag);
 264           key = scm_from_locale_string (s);
 265         }
 266     }
 267
 268   return scm_cons (scm_cons (key, val), acc);
 269 }
 270
 271 SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
 272             (),
 273             "Return an alist of statistics of the current live objects. ")
 274 #define FUNC_NAME s_scm_gc_live_object_stats
 275 {
 276   SCM tab = scm_make_hash_table (scm_from_int (57));
 277   SCM alist;
 278
 279   alist
 280     = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
 281
 282   return alist;
 283 }
 284 #undef FUNC_NAME
 285
 286 extern int scm_gc_malloc_yield_percentage;
 287 SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
 288             (),
 289             "Return an association list of statistics about Guile's current\n"
 290             "use of storage.\n")
 291 #define FUNC_NAME s_scm_gc_stats
 292 {
 293   SCM answer;
 294   GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
 295   size_t gc_times;
 296
 297   GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
 298                           &bytes_since_gc, &total_bytes);
 299   gc_times = GC_gc_no;
 300
 301   answer =
 302     scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
 303                 scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
 304                 scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
 305                 scm_cons (sym_heap_total_allocated,
 306                           scm_from_size_t (total_bytes)),
 307                 scm_cons (sym_heap_allocated_since_gc,
 308                           scm_from_size_t (bytes_since_gc)),
 309                 scm_cons (sym_protected_objects,
 310                           scm_from_ulong (protected_obj_count)),
 311                 scm_cons (sym_times, scm_from_size_t (gc_times)),
 312                 SCM_UNDEFINED);
 313
 314   return answer;
 315 }
 316 #undef FUNC_NAME
 317
 318
 319 SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
 320             (void),
 321             "Dump information about the garbage collector's internal data "
 322             "structures and memory usage to the standard output.")
 323 #define FUNC_NAME s_scm_gc_dump
 324 {
 325   GC_dump ();
 326
 327   return SCM_UNSPECIFIED;
 328 }
 329 #undef FUNC_NAME
 330
 331
 332 SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
 333             (SCM obj),
 334             "Return an integer that for the lifetime of @var{obj} is uniquely\n"
 335             "returned by this function for @var{obj}")
 336 #define FUNC_NAME s_scm_object_address
 337 {
 338   return scm_from_ulong (SCM_UNPACK (obj));
 339 }
 340 #undef FUNC_NAME
 341
 342
 343 SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
 344             (),
 345             "Disables the garbage collector.  Nested calls are permitted.  "
 346             "GC is re-enabled once @code{gc-enable} has been called the "
 347             "same number of times @code{gc-disable} was called.")
 348 #define FUNC_NAME s_scm_gc_disable
 349 {
 350   GC_disable ();
 351   return SCM_UNSPECIFIED;
 352 }
 353 #undef FUNC_NAME
 354
 355 SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
 356             (),
 357             "Enables the garbage collector.")
 358 #define FUNC_NAME s_scm_gc_enable
 359 {
 360   GC_enable ();
 361   return SCM_UNSPECIFIED;
 362 }
 363 #undef FUNC_NAME
 364
 365
 366 SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 367            (),
 368             "Scans all of SCM objects and reclaims for further use those that are\n"
 369             "no longer accessible.")
 370 #define FUNC_NAME s_scm_gc
 371 {
 372   scm_i_gc ("call");
 373   return SCM_UNSPECIFIED;
 374 }
 375 #undef FUNC_NAME
 376
 377 void
 378 scm_i_gc (const char *what)
 379 {
 380 #ifndef HAVE_GC_SET_START_CALLBACK
 381   run_before_gc_c_hook ();
 382 #endif
 383   GC_gcollect ();
 384 }
 385
 386
 387 \f
 388 /* {GC Protection Helper Functions}
 389  */
 390
 391
 392 /*
 393  * If within a function you need to protect one or more scheme objects from
 394  * garbage collection, pass them as parameters to one of the
 395  * scm_remember_upto_here* functions below.  These functions don't do
 396  * anything, but since the compiler does not know that they are actually
 397  * no-ops, it will generate code that calls these functions with the given
 398  * parameters.  Therefore, you can be sure that the compiler will keep those
 399  * scheme values alive (on the stack or in a register) up to the point where
 400  * scm_remember_upto_here* is called.  In other words, place the call to
 401  * scm_remember_upto_here* _behind_ the last code in your function, that
 402  * depends on the scheme object to exist.
 403  *
 404  * Example: We want to make sure that the string object str does not get
 405  * garbage collected during the execution of 'some_function' in the code
 406  * below, because otherwise the characters belonging to str would be freed and
 407  * 'some_function' might access freed memory.  To make sure that the compiler
 408  * keeps str alive on the stack or in a register such that it is visible to
 409  * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
 410  * call to 'some_function'.  Note that this would not be necessary if str was
 411  * used anyway after the call to 'some_function'.
 412  *   char *chars = scm_i_string_chars (str);
 413  *   some_function (chars);
 414  *   scm_remember_upto_here_1 (str);  // str will be alive up to this point.
 415  */
 416
 417 /* Remove any macro versions of these while defining the functions.
 418    Functions are always included in the library, for upward binary
 419    compatibility and in case combinations of GCC and non-GCC are used.  */
 420 #undef scm_remember_upto_here_1
 421 #undef scm_remember_upto_here_2
 422
 423 void
 424 scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
 425 {
 426   /* Empty.  Protects a single object from garbage collection. */
 427 }
 428
 429 void
 430 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
 431 {
 432   /* Empty.  Protects two objects from garbage collection. */
 433 }
 434
 435 void
 436 scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
 437 {
 438   /* Empty.  Protects any number of objects from garbage collection. */
 439 }
 440
 441 /*
 442   These crazy functions prevent garbage collection
 443   of arguments after the first argument by
 444   ensuring they remain live throughout the
 445   function because they are used in the last
 446   line of the code block.
 447   It'd be better to have a nice compiler hint to
 448   aid the conservative stack-scanning GC. --03/09/00 gjb */
 449 SCM
 450 scm_return_first (SCM elt, ...)
 451 {
 452   return elt;
 453 }
 454
 455 int
 456 scm_return_first_int (int i, ...)
 457 {
 458   return i;
 459 }
 460
 461
 462 SCM
 463 scm_permanent_object (SCM obj)
 464 {
 465   return (scm_gc_protect_object (obj));
 466 }
 467
 468
 469 /* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
 470    other references are dropped, until the object is unprotected by calling
 471    scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
 472    i. e. it is possible to protect the same object several times, but it is
 473    necessary to unprotect the object the same number of times to actually get
 474    the object unprotected.  It is an error to unprotect an object more often
 475    than it has been protected before.  The function scm_protect_object returns
 476    OBJ.
 477 */
 478
 479 /* Implementation note:  For every object X, there is a counter which
 480    scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
 481 */
 482
 483
 484
 485 SCM
 486 scm_gc_protect_object (SCM obj)
 487 {
 488   SCM handle;
 489
 490   /* This critical section barrier will be replaced by a mutex. */
 491   /* njrev: Indeed; if my comment above is correct, there is the same
 492      critsec/mutex inconsistency here. */
 493   SCM_CRITICAL_SECTION_START;
 494
 495   handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
 496   SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
 497
 498   protected_obj_count ++;
 499
 500   SCM_CRITICAL_SECTION_END;
 501
 502   return obj;
 503 }
 504
 505
 506 /* Remove any protection for OBJ established by a prior call to
 507    scm_protect_object.  This function returns OBJ.
 508
 509    See scm_protect_object for more information.  */
 510 SCM
 511 scm_gc_unprotect_object (SCM obj)
 512 {
 513   SCM handle;
 514
 515   /* This critical section barrier will be replaced by a mutex. */
 516   /* njrev: and again. */
 517   SCM_CRITICAL_SECTION_START;
 518
 519   if (scm_gc_running_p)
 520     {
 521       fprintf (stderr, "scm_unprotect_object called during GC.\n");
 522       abort ();
 523     }
 524
 525   handle = scm_hashq_get_handle (scm_protects, obj);
 526
 527   if (scm_is_false (handle))
 528     {
 529       fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
 530       abort ();
 531     }
 532   else
 533     {
 534       SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
 535       if (scm_is_eq (count, scm_from_int (0)))
 536         scm_hashq_remove_x (scm_protects, obj);
 537       else
 538         SCM_SETCDR (handle, count);
 539     }
 540   protected_obj_count --;
 541
 542   SCM_CRITICAL_SECTION_END;
 543
 544   return obj;
 545 }
 546
 547 void
 548 scm_gc_register_root (SCM *p)
 549 {
 550   /* Nothing.  */
 551 }
 552
 553 void
 554 scm_gc_unregister_root (SCM *p)
 555 {
 556   /* Nothing.  */
 557 }
 558
 559 void
 560 scm_gc_register_roots (SCM *b, unsigned long n)
 561 {
 562   SCM *p = b;
 563   for (; p < b + n; ++p)
 564     scm_gc_register_root (p);
 565 }
 566
 567 void
 568 scm_gc_unregister_roots (SCM *b, unsigned long n)
 569 {
 570   SCM *p = b;
 571   for (; p < b + n; ++p)
 572     scm_gc_unregister_root (p);
 573 }
 574
 575 \f
 576
 577
 578 /*
 579   MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
 580  */
 581
 582 /* Get an integer from an environment variable.  */
 583 int
 584 scm_getenv_int (const char *var, int def)
 585 {
 586   char *end = 0;
 587   char *val = getenv (var);
 588   long res = def;
 589   if (!val)
 590     return def;
 591   res = strtol (val, &end, 10);
 592   if (end == val)
 593     return def;
 594   return res;
 595 }
 596
 597 void
 598 scm_storage_prehistory ()
 599 {
 600   GC_all_interior_pointers = 0;
 601   GC_set_free_space_divisor (scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3));
 602
 603   GC_INIT ();
 604
 605 #if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \
 606     && (defined SCM_I_GSC_USE_PTHREAD_THREADS)
 607   /* When using GC 6.8, this call is required to initialize thread-local
 608      freelists (shouldn't be necessary with GC 7.0).  */
 609   GC_init ();
 610 #endif
 611
 612   GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
 613
 614   /* We only need to register a displacement for those types for which the
 615      higher bits of the type tag are used to store a pointer (that is, a
 616      pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
 617      handled in `scm_alloc_struct ()'.  */
 618   GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
 619   /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
 620
 621   /* Sanity check.  */
 622   if (!GC_is_visible (&scm_protects))
 623     abort ();
 624
 625   scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 626   scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
 627   scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 628   scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 629   scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 630 }
 631
 632 scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 633
 634 void
 635 scm_init_gc_protect_object ()
 636 {
 637   scm_protects = scm_c_make_hash_table (31);
 638
 639 #if 0
 640   /* We can't have a cleanup handler since we have no thread to run it
 641      in. */
 642
 643 #ifdef HAVE_ATEXIT
 644   atexit (cleanup);
 645 #else
 646 #ifdef HAVE_ON_EXIT
 647   on_exit (cleanup, 0);
 648 #endif
 649 #endif
 650
 651 #endif
 652 }
 653
 654 \f
 655
 656 SCM scm_after_gc_hook;
 657
 658 static SCM after_gc_async_cell;
 659
 660 /* The function after_gc_async_thunk causes the execution of the
 661  * after-gc-hook.  It is run after the gc, as soon as the asynchronous
 662  * events are handled by the evaluator.
 663  */
 664 static SCM
 665 after_gc_async_thunk (void)
 666 {
 667   /* Fun, no? Hook-run *and* run-hook?  */
 668   scm_c_hook_run (&scm_after_gc_c_hook, NULL);
 669   scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
 670   return SCM_UNSPECIFIED;
 671 }
 672
 673
 674 /* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
 675  * at the end of the garbage collection.  The only purpose of this
 676  * function is to mark the after_gc_async (which will eventually lead to
 677  * the execution of the after_gc_async_thunk).
 678  */
 679 static void *
 680 queue_after_gc_hook (void * hook_data SCM_UNUSED,
 681                       void *fn_data SCM_UNUSED,
 682                       void *data SCM_UNUSED)
 683 {
 684   /* If cell access debugging is enabled, the user may choose to perform
 685    * additional garbage collections after an arbitrary number of cell
 686    * accesses.  We don't want the scheme level after-gc-hook to be performed
 687    * for each of these garbage collections for the following reason: The
 688    * execution of the after-gc-hook causes cell accesses itself.  Thus, if the
 689    * after-gc-hook was performed with every gc, and if the gc was performed
 690    * after a very small number of cell accesses, then the number of cell
 691    * accesses during the execution of the after-gc-hook will suffice to cause
 692    * the execution of the next gc.  Then, guile would keep executing the
 693    * after-gc-hook over and over again, and would never come to do other
 694    * things.
 695    *
 696    * To overcome this problem, if cell access debugging with additional
 697    * garbage collections is enabled, the after-gc-hook is never run by the
 698    * garbage collecter.  When running guile with cell access debugging and the
 699    * execution of the after-gc-hook is desired, then it is necessary to run
 700    * the hook explicitly from the user code.  This has the effect, that from
 701    * the scheme level point of view it seems that garbage collection is
 702    * performed with a much lower frequency than it actually is.  Obviously,
 703    * this will not work for code that depends on a fixed one to one
 704    * relationship between the execution counts of the C level garbage
 705    * collection hooks and the execution count of the scheme level
 706    * after-gc-hook.
 707    */
 708
 709 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 710   if (scm_debug_cells_gc_interval == 0)
 711 #endif
 712     {
 713       scm_i_thread *t = SCM_I_CURRENT_THREAD;
 714
 715       if (scm_is_false (SCM_CDR (after_gc_async_cell)))
 716         {
 717           SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
 718           t->active_asyncs = after_gc_async_cell;
 719           t->pending_asyncs = 1;
 720         }
 721     }
 722
 723   return NULL;
 724 }
 725
 726 \f
 727
 728 static void *
 729 start_gc_timer (void * hook_data SCM_UNUSED,
 730                 void *fn_data SCM_UNUSED,
 731                 void *data SCM_UNUSED)
 732 {
 733   if (!gc_start_time)
 734     gc_start_time = scm_c_get_internal_run_time ();
 735
 736   return NULL;
 737 }
 738
 739 static void *
 740 accumulate_gc_timer (void * hook_data SCM_UNUSED,
 741                 void *fn_data SCM_UNUSED,
 742                 void *data SCM_UNUSED)
 743 {
 744   if (gc_start_time)
 745     { long now = scm_c_get_internal_run_time ();
 746       gc_time_taken += now - gc_start_time;
 747       gc_start_time = 0;
 748     }
 749
 750   return NULL;
 751 }
 752
 753
 754 \f
 755
 756 char const *
 757 scm_i_tag_name (scm_t_bits tag)
 758 {
 759   switch (tag & 0x7f) /* 7 bits */
 760     {
 761     case scm_tcs_struct:
 762       return "struct";
 763     case scm_tcs_cons_imcar:
 764       return "cons (immediate car)";
 765     case scm_tcs_cons_nimcar:
 766       return "cons (non-immediate car)";
 767     case scm_tc7_pointer:
 768       return "foreign";
 769     case scm_tc7_hashtable:
 770       return "hashtable";
 771     case scm_tc7_fluid:
 772       return "fluid";
 773     case scm_tc7_dynamic_state:
 774       return "dynamic state";
 775     case scm_tc7_frame:
 776       return "frame";
 777     case scm_tc7_objcode:
 778       return "objcode";
 779     case scm_tc7_vm:
 780       return "vm";
 781     case scm_tc7_vm_cont:
 782       return "vm continuation";
 783     case scm_tc7_wvect:
 784       return "weak vector";
 785     case scm_tc7_vector:
 786       return "vector";
 787     case scm_tc7_number:
 788       switch (tag)
 789         {
 790         case scm_tc16_real:
 791           return "real";
 792           break;
 793         case scm_tc16_big:
 794           return "bignum";
 795           break;
 796         case scm_tc16_complex:
 797           return "complex number";
 798           break;
 799         case scm_tc16_fraction:
 800           return "fraction";
 801           break;
 802         }
 803       break;
 804     case scm_tc7_string:
 805       return "string";
 806       break;
 807     case scm_tc7_stringbuf:
 808       return "string buffer";
 809       break;
 810     case scm_tc7_symbol:
 811       return "symbol";
 812       break;
 813     case scm_tc7_variable:
 814       return "variable";
 815       break;
 816     case scm_tc7_port:
 817       return "port";
 818       break;
 819     case scm_tc7_smob:
 820       {
 821         int k = 0xff & (tag >> 8);
 822         return (scm_smobs[k].name);
 823       }
 824       break;
 825     }
 826
 827   return NULL;
 828 }
 829
 830
 831
 832 \f
 833 void
 834 scm_init_gc ()
 835 {
 836   /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'.  */
 837
 838   scm_after_gc_hook = scm_make_hook (SCM_INUM0);
 839   scm_c_define ("after-gc-hook", scm_after_gc_hook);
 840
 841   /* When the async is to run, the cdr of the gc_async pair gets set to
 842      the asyncs queue of the current thread.  */
 843   after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
 844                                                     after_gc_async_thunk),
 845                                   SCM_BOOL_F);
 846
 847   scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
 848   scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
 849   scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
 850
 851 #ifdef HAVE_GC_SET_START_CALLBACK
 852   GC_set_start_callback (run_before_gc_c_hook);
 853 #endif
 854
 855 #include "libguile/gc.x"
 856 }
 857
 858
 859 void
 860 scm_gc_sweep (void)
 861 #define FUNC_NAME "scm_gc_sweep"
 862 {
 863   /* FIXME */
 864   fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
 865 }
 866 #undef FUNC_NAME
 867
 868 /*
 869   Local Variables:
 870   c-file-style: "gnu"
 871   End:
 872 */