libguile/gc-mark.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44 #include <stdio.h>
  45 #include <errno.h>
  46 #include <string.h>
  47 #include <assert.h>
  48
  49 #ifdef __ia64__
  50 #include <ucontext.h>
  51 extern unsigned long * __libc_ia64_register_backing_store_base;
  52 #endif
  53
  54 #include "libguile/_scm.h"
  55 #include "libguile/eval.h"
  56 #include "libguile/stime.h"
  57 #include "libguile/stackchk.h"
  58 #include "libguile/struct.h"
  59 #include "libguile/smob.h"
  60 #include "libguile/unif.h"
  61 #include "libguile/async.h"
  62 #include "libguile/ports.h"
  63 #include "libguile/root.h"
  64 #include "libguile/strings.h"
  65 #include "libguile/vectors.h"
  66 #include "libguile/weaks.h"
  67 #include "libguile/hashtab.h"
  68 #include "libguile/tags.h"
  69 #include "libguile/private-gc.h"
  70 #include "libguile/validate.h"
  71 #include "libguile/deprecation.h"
  72 #include "libguile/gc.h"
  73
  74 #ifdef GUILE_DEBUG_MALLOC
  75 #include "libguile/debug-malloc.h"
  76 #endif
  77
  78 #ifdef HAVE_MALLOC_H
  79 #include <malloc.h>
  80 #endif
  81
  82 #ifdef HAVE_UNISTD_H
  83 #include <unistd.h>
  84 #endif
  85
  86
  87
  88
  89 #ifdef __ia64__
  90 # define SCM_MARK_BACKING_STORE() do {                                \
  91     ucontext_t ctx;                                                   \
  92     SCM_STACKITEM * top, * bot;                                       \
  93     getcontext (&ctx);                                                \
  94     scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
  95       ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
  96        / sizeof (SCM_STACKITEM)));                                    \
  97     bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base;  \
  98     top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp;                \
  99     scm_mark_locations (bot, top - bot); } while (0)
 100 #else
 101 # define SCM_MARK_BACKING_STORE()
 102 #endif
 103
 104 /*
 105   Entry point for this file.
 106  */
 107 void
 108 scm_mark_all (void)
 109 {
 110   long j;
 111
 112
 113   scm_i_clear_mark_space ();
 114
 115 #ifndef USE_THREADS
 116
 117   /* Mark objects on the C stack. */
 118   SCM_FLUSH_REGISTER_WINDOWS;
 119   /* This assumes that all registers are saved into the jmp_buf */
 120   setjmp (scm_save_regs_gc_mark);
 121   scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
 122                       (   (size_t) (sizeof (SCM_STACKITEM) - 1 +
 123                                        sizeof scm_save_regs_gc_mark)
 124                           / sizeof (SCM_STACKITEM)));
 125
 126   {
 127     unsigned long stack_len = scm_stack_size (scm_stack_base);
 128 #ifdef SCM_STACK_GROWS_UP
 129     scm_mark_locations (scm_stack_base, stack_len);
 130 #else
 131     scm_mark_locations (scm_stack_base - stack_len, stack_len);
 132 #endif
 133   }
 134   SCM_MARK_BACKING_STORE();
 135
 136 #else /* USE_THREADS */
 137
 138   /* Mark every thread's stack and registers */
 139   scm_threads_mark_stacks ();
 140
 141 #endif /* USE_THREADS */
 142
 143   j = SCM_NUM_PROTECTS;
 144   while (j--)
 145     scm_gc_mark (scm_sys_protects[j]);
 146
 147   /* mark the registered roots */
 148   {
 149     size_t i;
 150     for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i)
 151       {
 152         SCM l = SCM_VELTS (scm_gc_registered_roots)[i];
 153         for (; !SCM_NULLP (l); l = SCM_CDR (l))
 154           {
 155             SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
 156             scm_gc_mark (*p);
 157           }
 158       }
 159   }
 160
 161   /* FIXME: we should have a means to register C functions to be run
 162    * in different phases of GC
 163    */
 164   scm_mark_subr_table ();
 165
 166 #ifndef USE_THREADS
 167   scm_gc_mark (scm_root->handle);
 168 #endif
 169 }
 170
 171 /* {Mark/Sweep}
 172  */
 173
 174
 175 /*
 176   Mark an object precisely, then recurse.
 177  */
 178 void
 179 scm_gc_mark (SCM ptr)
 180 {
 181   if (SCM_IMP (ptr))
 182     return ;
 183
 184   if (SCM_GC_MARK_P (ptr))
 185     return;
 186
 187   SCM_SET_GC_MARK (ptr);
 188   scm_gc_mark_dependencies (ptr);
 189 }
 190
 191 /*
 192
 193 Mark the dependencies of an object.
 194
 195 Prefetching:
 196
 197 Should prefetch objects before marking, i.e. if marking a cell, we
 198 should prefetch the car, and then mark the cdr. This will improve CPU
 199 cache misses, because the car is more likely to be in core when we
 200 finish the cdr.
 201
 202 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
 203 garbage collector cache misses.
 204
 205 Prefetch is supported on GCC >= 3.1
 206
 207 (Some time later.)
 208
 209 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
 210 Perhaps this would work better with an explicit markstack?
 211
 212
 213 */
 214 void
 215 scm_gc_mark_dependencies (SCM p)
 216 #define FUNC_NAME "scm_gc_mark_dependencies"
 217 {
 218   register long i;
 219   register SCM ptr;
 220   scm_t_bits cell_type;
 221
 222   ptr = p;
 223  scm_mark_dependencies_again:
 224
 225   cell_type = SCM_GC_CELL_TYPE (ptr);
 226   switch (SCM_ITAG7 (cell_type))
 227     {
 228     case scm_tcs_cons_nimcar:
 229       if (SCM_IMP (SCM_CDR (ptr)))
 230         {
 231           ptr = SCM_CAR (ptr);
 232           goto gc_mark_nimp;
 233         }
 234
 235
 236       scm_gc_mark (SCM_CAR (ptr));
 237       ptr = SCM_CDR (ptr);
 238       goto gc_mark_nimp;
 239     case scm_tcs_cons_imcar:
 240       ptr = SCM_CDR (ptr);
 241       goto gc_mark_loop;
 242     case scm_tc7_pws:
 243
 244       scm_gc_mark (SCM_SETTER (ptr));
 245       ptr = SCM_PROCEDURE (ptr);
 246       goto gc_mark_loop;
 247     case scm_tcs_struct:
 248       {
 249         /* XXX - use less explicit code. */
 250         scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
 251         scm_t_bits * vtable_data = (scm_t_bits *) word0;
 252         SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
 253         long len = SCM_SYMBOL_LENGTH (layout);
 254         char * fields_desc = SCM_SYMBOL_CHARS (layout);
 255         scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
 256
 257         if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 258           {
 259             scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
 260             scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
 261           }
 262         if (len)
 263           {
 264             long x;
 265
 266             for (x = 0; x < len - 2; x += 2, ++struct_data)
 267               if (fields_desc[x] == 'p')
 268                 scm_gc_mark (SCM_PACK (*struct_data));
 269             if (fields_desc[x] == 'p')
 270               {
 271                 if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
 272                   for (x = *struct_data++; x; --x, ++struct_data)
 273                     scm_gc_mark (SCM_PACK (*struct_data));
 274                 else
 275                   scm_gc_mark (SCM_PACK (*struct_data));
 276               }
 277           }
 278         /* mark vtable */
 279         ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
 280         goto gc_mark_loop;
 281       }
 282       break;
 283     case scm_tcs_closures:
 284       if (SCM_IMP (SCM_ENV (ptr)))
 285         {
 286           ptr = SCM_CLOSCAR (ptr);
 287           goto gc_mark_nimp;
 288         }
 289       scm_gc_mark (SCM_CLOSCAR (ptr));
 290       ptr = SCM_ENV (ptr);
 291       goto gc_mark_nimp;
 292     case scm_tc7_vector:
 293       i = SCM_VECTOR_LENGTH (ptr);
 294       if (i == 0)
 295         break;
 296       while (--i > 0)
 297         {
 298           if (SCM_NIMP (SCM_VELTS (ptr)[i]))
 299             scm_gc_mark (SCM_VELTS (ptr)[i]);
 300         }
 301       ptr = SCM_VELTS (ptr)[0];
 302       goto gc_mark_loop;
 303 #ifdef CCLO
 304     case scm_tc7_cclo:
 305       {
 306         size_t i = SCM_CCLO_LENGTH (ptr);
 307         size_t j;
 308         for (j = 1; j != i; ++j)
 309           {
 310             SCM obj = SCM_CCLO_REF (ptr, j);
 311             if (!SCM_IMP (obj))
 312               scm_gc_mark (obj);
 313           }
 314         ptr = SCM_CCLO_REF (ptr, 0);
 315         goto gc_mark_loop;
 316       }
 317 #endif
 318 #ifdef HAVE_ARRAYS
 319     case scm_tc7_bvect:
 320     case scm_tc7_byvect:
 321     case scm_tc7_ivect:
 322     case scm_tc7_uvect:
 323     case scm_tc7_fvect:
 324     case scm_tc7_dvect:
 325     case scm_tc7_cvect:
 326     case scm_tc7_svect:
 327 #ifdef HAVE_LONG_LONGS
 328     case scm_tc7_llvect:
 329 #endif
 330 #endif
 331     case scm_tc7_string:
 332       break;
 333
 334     case scm_tc7_wvect:
 335       SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
 336       scm_weak_vectors = ptr;
 337       if (SCM_IS_WHVEC_ANY (ptr))
 338         {
 339           long x;
 340           long len;
 341           int weak_keys;
 342           int weak_values;
 343
 344           len = SCM_VECTOR_LENGTH (ptr);
 345           weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
 346           weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
 347
 348           for (x = 0; x < len; ++x)
 349             {
 350               SCM alist;
 351               alist = SCM_VELTS (ptr)[x];
 352
 353               /* mark everything on the alist except the keys or
 354                * values, according to weak_values and weak_keys.  */
 355               while (   SCM_CONSP (alist)
 356                      && !SCM_GC_MARK_P (alist)
 357                      && SCM_CONSP (SCM_CAR (alist)))
 358                 {
 359                   SCM kvpair;
 360                   SCM next_alist;
 361
 362                   kvpair = SCM_CAR (alist);
 363                   next_alist = SCM_CDR (alist);
 364                   /*
 365                    * Do not do this:
 366                    *    SCM_SET_GC_MARK (alist);
 367                    *    SCM_SET_GC_MARK (kvpair);
 368                    *
 369                    * It may be that either the key or value is protected by
 370                    * an escaped reference to part of the spine of this alist.
 371                    * If we mark the spine here, and only mark one or neither of the
 372                    * key and value, they may never be properly marked.
 373                    * This leads to a horrible situation in which an alist containing
 374                    * freelist cells is exported.
 375                    *
 376                    * So only mark the spines of these arrays last of all marking.
 377                    * If somebody confuses us by constructing a weak vector
 378                    * with a circular alist then we are hosed, but at least we
 379                    * won't prematurely drop table entries.
 380                    */
 381                   if (!weak_keys)
 382                     scm_gc_mark (SCM_CAR (kvpair));
 383                   if (!weak_values)
 384                     scm_gc_mark (SCM_CDR (kvpair));
 385                   alist = next_alist;
 386                 }
 387               if (SCM_NIMP (alist))
 388                 scm_gc_mark (alist);
 389             }
 390         }
 391       break;
 392
 393     case scm_tc7_symbol:
 394       ptr = SCM_PROP_SLOTS (ptr);
 395       goto gc_mark_loop;
 396     case scm_tc7_variable:
 397       ptr = SCM_CELL_OBJECT_1 (ptr);
 398       goto gc_mark_loop;
 399     case scm_tcs_subrs:
 400       break;
 401     case scm_tc7_port:
 402       i = SCM_PTOBNUM (ptr);
 403 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 404       if (!(i < scm_numptob))
 405         SCM_MISC_ERROR ("undefined port type", SCM_EOL);
 406 #endif
 407       if (SCM_PTAB_ENTRY(ptr))
 408         scm_gc_mark (SCM_FILENAME (ptr));
 409       if (scm_ptobs[i].mark)
 410         {
 411           ptr = (scm_ptobs[i].mark) (ptr);
 412           goto gc_mark_loop;
 413         }
 414       else
 415         return;
 416       break;
 417     case scm_tc7_smob:
 418       switch (SCM_TYP16 (ptr))
 419         { /* should be faster than going through scm_smobs */
 420         case scm_tc_free_cell:
 421           /* We have detected a free cell.  This can happen if non-object data
 422            * on the C stack points into guile's heap and is scanned during
 423            * conservative marking.  */
 424           break;
 425         case scm_tc16_big:
 426         case scm_tc16_real:
 427         case scm_tc16_complex:
 428           break;
 429         default:
 430           i = SCM_SMOBNUM (ptr);
 431 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 432           if (!(i < scm_numsmob))
 433             SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
 434 #endif
 435           if (scm_smobs[i].mark)
 436             {
 437               ptr = (scm_smobs[i].mark) (ptr);
 438               goto gc_mark_loop;
 439             }
 440           else
 441             return;
 442         }
 443       break;
 444     default:
 445       SCM_MISC_ERROR ("unknown type", SCM_EOL);
 446     }
 447
 448   /*
 449     If we got here, then exhausted recursion options for PTR.  we
 450     return (careful not to mark PTR, it might be the argument that we
 451     were called with.)
 452    */
 453   return ;
 454
 455 gc_mark_loop:
 456   if (SCM_IMP (ptr))
 457     return;
 458
 459  gc_mark_nimp:
 460   {
 461     int valid_cell = CELL_P (ptr);
 462
 463
 464 #if (SCM_DEBUG_CELL_ACCESSES == 1)
 465     if (scm_debug_cell_accesses_p)
 466       {
 467     /* We are in debug mode.  Check the ptr exhaustively. */
 468
 469         valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
 470       }
 471
 472 #endif
 473     if (!valid_cell)
 474       SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
 475   }
 476
 477  if (SCM_GC_MARK_P (ptr))
 478     return;
 479
 480   SCM_SET_GC_MARK (ptr);
 481   goto   scm_mark_dependencies_again;
 482
 483 }
 484 #undef FUNC_NAME
 485
 486
 487
 488 /* Mark a region conservatively */
 489 void
 490 scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
 491 {
 492   unsigned long m;
 493
 494   for (m = 0; m < n; ++m)
 495     {
 496       SCM obj = * (SCM *) &x[m];
 497       long int segment = scm_i_find_heap_segment_containing_object (obj);
 498       if (segment >= 0)
 499         scm_gc_mark (obj);
 500     }
 501 }
 502
 503
 504 /* The function scm_in_heap_p determines whether an SCM value can be regarded as a
 505  * pointer to a cell on the heap.
 506  */
 507 int
 508 scm_in_heap_p (SCM value)
 509 {
 510   long int segment = scm_i_find_heap_segment_containing_object (value);
 511   return (segment >= 0);
 512 }
 513
 514
 515 #if SCM_ENABLE_DEPRECATED == 1
 516
 517 /* If an allocated cell is detected during garbage collection, this
 518  * means that some code has just obtained the object but was preempted
 519  * before the initialization of the object was completed.  This meanst
 520  * that some entries of the allocated cell may already contain SCM
 521  * objects.  Therefore, allocated cells are scanned conservatively.
 522  */
 523
 524 scm_t_bits scm_tc16_allocated;
 525
 526 static SCM
 527 allocated_mark (SCM cell)
 528 {
 529   unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
 530   unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
 531   unsigned int i;
 532
 533   for (i = 1; i != span * 2; ++i)
 534     {
 535       SCM obj = SCM_CELL_OBJECT (cell, i);
 536       long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
 537       if (obj_segment >= 0)
 538         scm_gc_mark (obj);
 539     }
 540   return SCM_BOOL_F;
 541 }
 542
 543 SCM
 544 scm_deprecated_newcell (void)
 545 {
 546   scm_c_issue_deprecation_warning
 547     ("SCM_NEWCELL is deprecated.  Use `scm_cell' instead.\n");
 548
 549   return scm_cell (scm_tc16_allocated, 0);
 550 }
 551
 552 SCM
 553 scm_deprecated_newcell2 (void)
 554 {
 555   scm_c_issue_deprecation_warning
 556     ("SCM_NEWCELL2 is deprecated.  Use `scm_double_cell' instead.\n");
 557
 558   return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
 559 }
 560
 561 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 562
 563
 564 void
 565 scm_gc_init_mark(void)
 566 {
 567 #if SCM_ENABLE_DEPRECATED == 1
 568   scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
 569   scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
 570 #endif
 571 }
 572
 573