guile18/libguile/gc-mark.c

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