libguile/gc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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 02110-1301 USA
  16  */
  17
  18 #define _GNU_SOURCE
  19
  20 /* #define DEBUGINFO */
  21
  22 #if 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 <assert.h>
  32
  33 #ifdef __ia64__
  34 #include <ucontext.h>
  35 extern unsigned long * __libc_ia64_register_backing_store_base;
  36 #endif
  37
  38 #include "libguile/_scm.h"
  39 #include "libguile/eval.h"
  40 #include "libguile/stime.h"
  41 #include "libguile/stackchk.h"
  42 #include "libguile/struct.h"
  43 #include "libguile/smob.h"
  44 #include "libguile/unif.h"
  45 #include "libguile/async.h"
  46 #include "libguile/ports.h"
  47 #include "libguile/root.h"
  48 #include "libguile/strings.h"
  49 #include "libguile/vectors.h"
  50 #include "libguile/weaks.h"
  51 #include "libguile/hashtab.h"
  52 #include "libguile/tags.h"
  53
  54 #include "libguile/private-gc.h"
  55 #include "libguile/validate.h"
  56 #include "libguile/deprecation.h"
  57 #include "libguile/gc.h"
  58 #include "libguile/dynwind.h"
  59
  60 #include "libguile/boehm-gc.h"
  61
  62 #ifdef GUILE_DEBUG_MALLOC
  63 #include "libguile/debug-malloc.h"
  64 #endif
  65
  66 #ifdef HAVE_MALLOC_H
  67 #include <malloc.h>
  68 #endif
  69
  70 #ifdef HAVE_UNISTD_H
  71 #include <unistd.h>
  72 #endif
  73
  74 /* Lock this mutex before doing lazy sweeping.
  75  */
  76 scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  77
  78 /* Set this to != 0 if every cell that is accessed shall be checked:
  79  */
  80 int scm_debug_cell_accesses_p = 0;
  81 int scm_expensive_debug_cell_accesses_p = 0;
  82
  83 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
  84  * the number of cell accesses after which a gc shall be called.
  85  */
  86 int scm_debug_cells_gc_interval = 0;
  87
  88 /*
  89   Global variable, so you can switch it off at runtime by setting
  90   scm_i_cell_validation_already_running.
  91  */
  92 int scm_i_cell_validation_already_running ;
  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 (!scm_in_heap_p (cell))
 112     {
 113       fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
 114                (unsigned long) SCM_UNPACK (cell));
 115       abort ();
 116     }
 117
 118   /* If desired, perform additional garbage collections after a user
 119    * defined number of cell accesses.
 120    */
 121   if (scm_debug_cells_gc_interval)
 122     {
 123       static unsigned int counter = 0;
 124
 125       if (counter != 0)
 126         {
 127           --counter;
 128         }
 129       else
 130         {
 131           counter = scm_debug_cells_gc_interval;
 132           scm_gc ();
 133         }
 134     }
 135 }
 136
 137 void
 138 scm_assert_cell_valid (SCM cell)
 139 {
 140   if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
 141     {
 142       scm_i_cell_validation_already_running = 1;  /* set to avoid recursion */
 143
 144       /*
 145         During GC, no user-code should be run, and the guile core
 146         should use non-protected accessors.
 147       */
 148       if (scm_gc_running_p)
 149         return;
 150
 151       /*
 152         Only scm_in_heap_p and rescanning the heap is wildly
 153         expensive.
 154       */
 155       if (scm_expensive_debug_cell_accesses_p)
 156         scm_i_expensive_validation_check (cell);
 157
 158       if (!SCM_GC_MARK_P (cell))
 159         {
 160           fprintf (stderr,
 161                    "scm_assert_cell_valid: this object is unmarked. \n"
 162                    "It has been garbage-collected in the last GC run: "
 163                    "%lux\n",
 164                    (unsigned long) SCM_UNPACK (cell));
 165           abort ();
 166         }
 167
 168       scm_i_cell_validation_already_running = 0;  /* re-enable */
 169     }
 170 }
 171
 172
 173
 174 SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
 175             (SCM flag),
 176             "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
 177             "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
 178             "but no additional calls to garbage collection are issued.\n"
 179             "If @var{flag} is a number, strict cell access checking is enabled,\n"
 180             "with an additional garbage collection after the given\n"
 181             "number of cell accesses.\n"
 182             "This procedure only exists when the compile-time flag\n"
 183             "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
 184 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
 185 {
 186   if (scm_is_false (flag))
 187     {
 188       scm_debug_cell_accesses_p = 0;
 189     }
 190   else if (scm_is_eq (flag, SCM_BOOL_T))
 191     {
 192       scm_debug_cells_gc_interval = 0;
 193       scm_debug_cell_accesses_p = 1;
 194       scm_expensive_debug_cell_accesses_p = 0;
 195     }
 196   else
 197     {
 198       scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
 199       scm_debug_cell_accesses_p = 1;
 200       scm_expensive_debug_cell_accesses_p = 1;
 201     }
 202   return SCM_UNSPECIFIED;
 203 }
 204 #undef FUNC_NAME
 205
 206
 207 #endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
 208
 209 \f
 210 /* Hooks.  */
 211 scm_t_c_hook scm_before_gc_c_hook;
 212 scm_t_c_hook scm_before_mark_c_hook;
 213 scm_t_c_hook scm_before_sweep_c_hook;
 214 scm_t_c_hook scm_after_sweep_c_hook;
 215 scm_t_c_hook scm_after_gc_c_hook;
 216
 217
 218 /* scm_mtrigger
 219  * is the number of bytes of malloc allocation needed to trigger gc.
 220  */
 221 unsigned long scm_mtrigger;
 222
 223 /* GC Statistics Keeping
 224  */
 225 unsigned long scm_cells_allocated = 0;
 226 unsigned long scm_last_cells_allocated = 0;
 227 unsigned long scm_mallocated = 0;
 228 unsigned long scm_gc_cells_collected;
 229 unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */
 230 unsigned long scm_gc_malloc_collected;
 231 unsigned long scm_gc_ports_collected;
 232 unsigned long scm_gc_time_taken = 0;
 233 static unsigned long t_before_gc;
 234 unsigned long scm_gc_mark_time_taken = 0;
 235 unsigned long scm_gc_times = 0;
 236 unsigned long scm_gc_cells_swept = 0;
 237 double scm_gc_cells_marked_acc = 0.;
 238 double scm_gc_cells_swept_acc = 0.;
 239 int scm_gc_cell_yield_percentage =0;
 240 int scm_gc_malloc_yield_percentage = 0;
 241
 242 static unsigned long protected_obj_count = 0;
 243
 244
 245 SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
 246 SCM_SYMBOL (sym_heap_size, "heap-size");
 247 SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
 248 SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
 249 SCM_SYMBOL (sym_mallocated, "bytes-malloced");
 250 SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
 251 SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
 252 SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
 253 SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
 254 SCM_SYMBOL (sym_times, "gc-times");
 255 SCM_SYMBOL (sym_cells_marked, "cells-marked");
 256 SCM_SYMBOL (sym_cells_swept, "cells-swept");
 257 SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
 258 SCM_SYMBOL (sym_cell_yield, "cell-yield");
 259 SCM_SYMBOL (sym_protected_objects, "protected-objects");
 260 SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
 261
 262
 263 /* Number of calls to SCM_NEWCELL since startup.  */
 264 unsigned scm_newcell_count;
 265 unsigned scm_newcell2_count;
 266
 267
 268 /* {Scheme Interface to GC}
 269  */
 270 static SCM
 271 tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
 272 {
 273   if (scm_is_integer (key))
 274     {
 275       int c_tag = scm_to_int (key);
 276
 277       char const * name = scm_i_tag_name (c_tag);
 278       if (name != NULL)
 279         {
 280           key = scm_from_locale_string (name);
 281         }
 282       else
 283         {
 284           char s[100];
 285           sprintf (s, "tag %d", c_tag);
 286           key = scm_from_locale_string (s);
 287         }
 288     }
 289
 290   return scm_cons (scm_cons (key, val), acc);
 291 }
 292
 293 SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
 294             (),
 295             "Return an alist of statistics of the current live objects. ")
 296 #define FUNC_NAME s_scm_gc_live_object_stats
 297 {
 298   SCM tab = scm_make_hash_table (scm_from_int (57));
 299   SCM alist;
 300
 301   alist
 302     = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
 303
 304   return alist;
 305 }
 306 #undef FUNC_NAME
 307
 308 extern int scm_gc_malloc_yield_percentage;
 309 SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
 310             (),
 311             "Return an association list of statistics about Guile's current\n"
 312             "use of storage.\n")
 313 #define FUNC_NAME s_scm_gc_stats
 314 {
 315   SCM answer;
 316   size_t heap_size, free_bytes, bytes_since_gc, total_bytes;
 317   size_t gc_times;
 318
 319   heap_size      = GC_get_heap_size ();
 320   free_bytes     = GC_get_free_bytes ();
 321   bytes_since_gc = GC_get_bytes_since_gc ();
 322   total_bytes    = GC_get_total_bytes ();
 323   gc_times       = GC_gc_no;
 324
 325   /* njrev: can any of these scm_cons's or scm_list_n signal a memory
 326      error?  If so we need a frame here. */
 327   answer =
 328     scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
 329 #if 0
 330                 scm_cons (sym_cells_allocated,
 331                           scm_from_ulong (local_scm_cells_allocated)),
 332                 scm_cons (sym_mallocated,
 333                           scm_from_ulong (local_scm_mallocated)),
 334                 scm_cons (sym_mtrigger,
 335                           scm_from_ulong (local_scm_mtrigger)),
 336                 scm_cons (sym_gc_mark_time_taken,
 337                           scm_from_ulong (local_scm_gc_mark_time_taken)),
 338                 scm_cons (sym_cells_marked,
 339                           scm_from_double (local_scm_gc_cells_marked)),
 340                 scm_cons (sym_cells_swept,
 341                           scm_from_double (local_scm_gc_cells_swept)),
 342                 scm_cons (sym_malloc_yield,
 343                           scm_from_long(local_scm_gc_malloc_yield_percentage)),
 344                 scm_cons (sym_cell_yield,
 345                           scm_from_long (local_scm_gc_cell_yield_percentage)),
 346                 scm_cons (sym_heap_segments, heap_segs),
 347 #endif
 348                 scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
 349                 scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
 350                 scm_cons (sym_heap_total_allocated,
 351                           scm_from_size_t (total_bytes)),
 352                 scm_cons (sym_protected_objects,
 353                           scm_from_ulong (protected_obj_count)),
 354                 scm_cons (sym_times, scm_from_size_t (gc_times)),
 355                 SCM_UNDEFINED);
 356
 357   return answer;
 358 }
 359 #undef FUNC_NAME
 360
 361
 362
 363
 364 SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
 365             (SCM obj),
 366             "Return an integer that for the lifetime of @var{obj} is uniquely\n"
 367             "returned by this function for @var{obj}")
 368 #define FUNC_NAME s_scm_object_address
 369 {
 370   return scm_from_ulong (SCM_UNPACK (obj));
 371 }
 372 #undef FUNC_NAME
 373
 374
 375 SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
 376             (),
 377             "Disables the garbage collector.  Nested calls are permitted.  "
 378             "GC is re-enabled once @code{gc-enable} has been called the "
 379             "same number of times @code{gc-disable} was called.")
 380 #define FUNC_NAME s_scm_gc_disable
 381 {
 382   GC_disable ();
 383   return SCM_UNSPECIFIED;
 384 }
 385 #undef FUNC_NAME
 386
 387 SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
 388             (),
 389             "Enables the garbage collector.")
 390 #define FUNC_NAME s_scm_gc_enable
 391 {
 392   GC_enable ();
 393   return SCM_UNSPECIFIED;
 394 }
 395 #undef FUNC_NAME
 396
 397
 398 SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 399            (),
 400             "Scans all of SCM objects and reclaims for further use those that are\n"
 401             "no longer accessible.")
 402 #define FUNC_NAME s_scm_gc
 403 {
 404   scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 405   scm_gc_running_p = 1;
 406   scm_i_gc ("call");
 407   /* njrev: It looks as though other places, e.g. scm_realloc,
 408      can call scm_i_gc without acquiring the sweep mutex.  Does this
 409      matter?  Also scm_i_gc (or its descendants) touch the
 410      scm_sys_protects, which are protected in some cases
 411      (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
 412      not by the sweep mutex.  Shouldn't all the GC-relevant objects be
 413      protected in the same way? */
 414   scm_gc_running_p = 0;
 415   scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 416   scm_c_hook_run (&scm_after_gc_c_hook, 0);
 417   return SCM_UNSPECIFIED;
 418 }
 419 #undef FUNC_NAME
 420
 421 void
 422 scm_i_gc (const char *what)
 423 {
 424   GC_gcollect ();
 425 }
 426
 427
 428 \f
 429 /* {GC Protection Helper Functions}
 430  */
 431
 432
 433 /*
 434  * If within a function you need to protect one or more scheme objects from
 435  * garbage collection, pass them as parameters to one of the
 436  * scm_remember_upto_here* functions below.  These functions don't do
 437  * anything, but since the compiler does not know that they are actually
 438  * no-ops, it will generate code that calls these functions with the given
 439  * parameters.  Therefore, you can be sure that the compiler will keep those
 440  * scheme values alive (on the stack or in a register) up to the point where
 441  * scm_remember_upto_here* is called.  In other words, place the call to
 442  * scm_remember_upto_here* _behind_ the last code in your function, that
 443  * depends on the scheme object to exist.
 444  *
 445  * Example: We want to make sure that the string object str does not get
 446  * garbage collected during the execution of 'some_function' in the code
 447  * below, because otherwise the characters belonging to str would be freed and
 448  * 'some_function' might access freed memory.  To make sure that the compiler
 449  * keeps str alive on the stack or in a register such that it is visible to
 450  * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
 451  * call to 'some_function'.  Note that this would not be necessary if str was
 452  * used anyway after the call to 'some_function'.
 453  *   char *chars = scm_i_string_chars (str);
 454  *   some_function (chars);
 455  *   scm_remember_upto_here_1 (str);  // str will be alive up to this point.
 456  */
 457
 458 /* Remove any macro versions of these while defining the functions.
 459    Functions are always included in the library, for upward binary
 460    compatibility and in case combinations of GCC and non-GCC are used.  */
 461 #undef scm_remember_upto_here_1
 462 #undef scm_remember_upto_here_2
 463
 464 void
 465 scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
 466 {
 467   /* Empty.  Protects a single object from garbage collection. */
 468 }
 469
 470 void
 471 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
 472 {
 473   /* Empty.  Protects two objects from garbage collection. */
 474 }
 475
 476 void
 477 scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
 478 {
 479   /* Empty.  Protects any number of objects from garbage collection. */
 480 }
 481
 482 /*
 483   These crazy functions prevent garbage collection
 484   of arguments after the first argument by
 485   ensuring they remain live throughout the
 486   function because they are used in the last
 487   line of the code block.
 488   It'd be better to have a nice compiler hint to
 489   aid the conservative stack-scanning GC. --03/09/00 gjb */
 490 SCM
 491 scm_return_first (SCM elt, ...)
 492 {
 493   return elt;
 494 }
 495
 496 int
 497 scm_return_first_int (int i, ...)
 498 {
 499   return i;
 500 }
 501
 502
 503 SCM
 504 scm_permanent_object (SCM obj)
 505 {
 506   return (scm_gc_protect_object (obj));
 507 }
 508
 509
 510 /* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
 511    other references are dropped, until the object is unprotected by calling
 512    scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
 513    i. e. it is possible to protect the same object several times, but it is
 514    necessary to unprotect the object the same number of times to actually get
 515    the object unprotected.  It is an error to unprotect an object more often
 516    than it has been protected before.  The function scm_protect_object returns
 517    OBJ.
 518 */
 519
 520 /* Implementation note:  For every object X, there is a counter which
 521    scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
 522 */
 523
 524
 525
 526 SCM
 527 scm_gc_protect_object (SCM obj)
 528 {
 529   SCM handle;
 530
 531   /* This critical section barrier will be replaced by a mutex. */
 532   /* njrev: Indeed; if my comment above is correct, there is the same
 533      critsec/mutex inconsistency here. */
 534   SCM_CRITICAL_SECTION_START;
 535
 536   handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
 537   SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
 538
 539   protected_obj_count ++;
 540
 541   SCM_CRITICAL_SECTION_END;
 542
 543   return obj;
 544 }
 545
 546
 547 /* Remove any protection for OBJ established by a prior call to
 548    scm_protect_object.  This function returns OBJ.
 549
 550    See scm_protect_object for more information.  */
 551 SCM
 552 scm_gc_unprotect_object (SCM obj)
 553 {
 554   SCM handle;
 555
 556   /* This critical section barrier will be replaced by a mutex. */
 557   /* njrev: and again. */
 558   SCM_CRITICAL_SECTION_START;
 559
 560   if (scm_gc_running_p)
 561     {
 562       fprintf (stderr, "scm_unprotect_object called during GC.\n");
 563       abort ();
 564     }
 565
 566   handle = scm_hashq_get_handle (scm_protects, obj);
 567
 568   if (scm_is_false (handle))
 569     {
 570       fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
 571       abort ();
 572     }
 573   else
 574     {
 575       SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
 576       if (scm_is_eq (count, scm_from_int (0)))
 577         scm_hashq_remove_x (scm_protects, obj);
 578       else
 579         SCM_SETCDR (handle, count);
 580     }
 581   protected_obj_count --;
 582
 583   SCM_CRITICAL_SECTION_END;
 584
 585   return obj;
 586 }
 587
 588 void
 589 scm_gc_register_root (SCM *p)
 590 {
 591   /* Nothing.  */
 592 }
 593
 594 void
 595 scm_gc_unregister_root (SCM *p)
 596 {
 597   /* Nothing.  */
 598 }
 599
 600 void
 601 scm_gc_register_roots (SCM *b, unsigned long n)
 602 {
 603   SCM *p = b;
 604   for (; p < b + n; ++p)
 605     scm_gc_register_root (p);
 606 }
 607
 608 void
 609 scm_gc_unregister_roots (SCM *b, unsigned long n)
 610 {
 611   SCM *p = b;
 612   for (; p < b + n; ++p)
 613     scm_gc_unregister_root (p);
 614 }
 615
 616 int scm_i_terminating;
 617
 618 \f
 619
 620
 621 /*
 622   MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
 623  */
 624
 625 /* Get an integer from an environment variable.  */
 626 int
 627 scm_getenv_int (const char *var, int def)
 628 {
 629   char *end = 0;
 630   char *val = getenv (var);
 631   long res = def;
 632   if (!val)
 633     return def;
 634   res = strtol (val, &end, 10);
 635   if (end == val)
 636     return def;
 637   return res;
 638 }
 639
 640 void
 641 scm_storage_prehistory ()
 642 {
 643   GC_all_interior_pointers = 0;
 644
 645   GC_INIT ();
 646
 647 #ifdef SCM_I_GSC_USE_PTHREAD_THREADS
 648   /* When using GC 6.8, this call is required to initialize thread-local
 649      freelists (shouldn't be necessary with GC 7.0).  */
 650   GC_init ();
 651 #endif
 652
 653   GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
 654
 655   /* We only need to register a displacement for those types for which the
 656      higher bits of the type tag are used to store a pointer (that is, a
 657      pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
 658      handled in `scm_alloc_struct ()'.  */
 659   GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
 660   GC_REGISTER_DISPLACEMENT (scm_tc3_closure);
 661
 662   /* Sanity check.  */
 663   if (!GC_is_visible (scm_sys_protects))
 664     abort ();
 665
 666   scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 667   scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
 668   scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 669   scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
 670   scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
 671 }
 672
 673 scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 674
 675 int
 676 scm_init_storage ()
 677 {
 678   size_t j;
 679
 680   j = SCM_NUM_PROTECTS;
 681   while (j)
 682     scm_sys_protects[--j] = SCM_BOOL_F;
 683
 684   j = SCM_HEAP_SEG_SIZE;
 685
 686 #if 0
 687   /* We can't have a cleanup handler since we have no thread to run it
 688      in. */
 689
 690 #ifdef HAVE_ATEXIT
 691   atexit (cleanup);
 692 #else
 693 #ifdef HAVE_ON_EXIT
 694   on_exit (cleanup, 0);
 695 #endif
 696 #endif
 697
 698 #endif
 699
 700   scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
 701   scm_protects = scm_c_make_hash_table (31);
 702
 703   return 0;
 704 }
 705
 706 \f
 707
 708 SCM scm_after_gc_hook;
 709
 710 static SCM gc_async;
 711
 712 /* The function gc_async_thunk causes the execution of the after-gc-hook.  It
 713  * is run after the gc, as soon as the asynchronous events are handled by the
 714  * evaluator.
 715  */
 716 static SCM
 717 gc_async_thunk (void)
 718 {
 719   scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
 720   return SCM_UNSPECIFIED;
 721 }
 722
 723
 724 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
 725  * the garbage collection.  The only purpose of this function is to mark the
 726  * gc_async (which will eventually lead to the execution of the
 727  * gc_async_thunk).
 728  */
 729 static void *
 730 mark_gc_async (void * hook_data SCM_UNUSED,
 731                void *func_data SCM_UNUSED,
 732                void *data SCM_UNUSED)
 733 {
 734   /* If cell access debugging is enabled, the user may choose to perform
 735    * additional garbage collections after an arbitrary number of cell
 736    * accesses.  We don't want the scheme level after-gc-hook to be performed
 737    * for each of these garbage collections for the following reason: The
 738    * execution of the after-gc-hook causes cell accesses itself.  Thus, if the
 739    * after-gc-hook was performed with every gc, and if the gc was performed
 740    * after a very small number of cell accesses, then the number of cell
 741    * accesses during the execution of the after-gc-hook will suffice to cause
 742    * the execution of the next gc.  Then, guile would keep executing the
 743    * after-gc-hook over and over again, and would never come to do other
 744    * things.
 745    *
 746    * To overcome this problem, if cell access debugging with additional
 747    * garbage collections is enabled, the after-gc-hook is never run by the
 748    * garbage collecter.  When running guile with cell access debugging and the
 749    * execution of the after-gc-hook is desired, then it is necessary to run
 750    * the hook explicitly from the user code.  This has the effect, that from
 751    * the scheme level point of view it seems that garbage collection is
 752    * performed with a much lower frequency than it actually is.  Obviously,
 753    * this will not work for code that depends on a fixed one to one
 754    * relationship between the execution counts of the C level garbage
 755    * collection hooks and the execution count of the scheme level
 756    * after-gc-hook.
 757    */
 758
 759 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 760   if (scm_debug_cells_gc_interval == 0)
 761     scm_system_async_mark (gc_async);
 762 #else
 763   scm_system_async_mark (gc_async);
 764 #endif
 765
 766   return NULL;
 767 }
 768
 769 char const *
 770 scm_i_tag_name (scm_t_bits tag)
 771 {
 772   if (tag >= 255)
 773     {
 774       if (tag == scm_tc_free_cell)
 775         return "free cell";
 776
 777       {
 778         int k = 0xff & (tag >> 8);
 779         return (scm_smobs[k].name);
 780       }
 781     }
 782
 783   switch (tag) /* 7 bits */
 784     {
 785     case scm_tcs_struct:
 786       return "struct";
 787     case scm_tcs_cons_imcar:
 788       return "cons (immediate car)";
 789     case scm_tcs_cons_nimcar:
 790       return "cons (non-immediate car)";
 791     case scm_tcs_closures:
 792       return "closures";
 793     case scm_tc7_pws:
 794       return "pws";
 795     case scm_tc7_wvect:
 796       return "weak vector";
 797     case scm_tc7_vector:
 798       return "vector";
 799 #ifdef CCLO
 800     case scm_tc7_cclo:
 801       return "compiled closure";
 802 #endif
 803     case scm_tc7_number:
 804       switch (tag)
 805         {
 806         case scm_tc16_real:
 807           return "real";
 808           break;
 809         case scm_tc16_big:
 810           return "bignum";
 811           break;
 812         case scm_tc16_complex:
 813           return "complex number";
 814           break;
 815         case scm_tc16_fraction:
 816           return "fraction";
 817           break;
 818         }
 819       break;
 820     case scm_tc7_string:
 821       return "string";
 822       break;
 823     case scm_tc7_stringbuf:
 824       return "string buffer";
 825       break;
 826     case scm_tc7_symbol:
 827       return "symbol";
 828       break;
 829     case scm_tc7_variable:
 830       return "variable";
 831       break;
 832     case scm_tcs_subrs:
 833       return "subrs";
 834       break;
 835     case scm_tc7_port:
 836       return "port";
 837       break;
 838     case scm_tc7_smob:
 839       return "smob";            /* should not occur. */
 840       break;
 841     }
 842
 843   return NULL;
 844 }
 845
 846
 847
 848 \f
 849 void
 850 scm_init_gc ()
 851 {
 852   /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'.  */
 853
 854   scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
 855   scm_c_define ("after-gc-hook", scm_after_gc_hook);
 856
 857   gc_async = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0,
 858                               gc_async_thunk);
 859
 860   scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
 861
 862 #include "libguile/gc.x"
 863 }
 864
 865
 866 void
 867 scm_gc_sweep (void)
 868 #define FUNC_NAME "scm_gc_sweep"
 869 {
 870   /* FIXME */
 871   fprintf (stderr, "%s: doing nothing\n", __FUNCTION__);
 872 }
 873
 874 #undef FUNC_NAME
 875
 876
 877
 878 /*
 879   Local Variables:
 880   c-file-style: "gnu"
 881   End:
 882 */