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