libguile/gc-mark.c

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