libguile/gc-mark.c

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