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