libguile/gc-mark.c

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