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 #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   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
  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   scm_mark_subr_table ();
 104
 105   loops = 0;
 106   while (1)
 107     {
 108       int again;
 109       loops++;
 110
 111       /* Mark the non-weak references of weak vectors.  For a weak key
 112          alist vector, this would mark the values for keys that are
 113          marked.  We need to do this in a loop until everything
 114          settles down since the newly marked values might be keys in
 115          other weak key alist vectors, for example.
 116       */
 117       again = scm_i_mark_weak_vectors_non_weaks ();
 118       if (again)
 119         continue;
 120
 121       /* Now we scan all marked guardians and move all unmarked objects
 122          from the accessible to the inaccessible list.
 123       */
 124       scm_i_identify_inaccessible_guardeds ();
 125
 126       /* When we have identified all inaccessible objects, we can mark
 127          them.
 128       */
 129       again = scm_i_mark_inaccessible_guardeds ();
 130
 131       /* This marking might have changed the situation for weak vectors
 132          and might have turned up new guardians that need to be processed,
 133          so we do it all over again.
 134       */
 135       if (again)
 136         continue;
 137
 138       /* Nothing new marked in this round, we are done.
 139        */
 140       break;
 141     }
 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   scm_i_marking = 0;
 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 void
 173 ensure_marking (void)
 174 {
 175   assert (scm_i_marking);
 176 }
 177
 178 /*
 179
 180 Mark the dependencies of an object.
 181
 182 Prefetching:
 183
 184 Should prefetch objects before marking, i.e. if marking a cell, we
 185 should prefetch the car, and then mark the cdr. This will improve CPU
 186 cache misses, because the car is more likely to be in cache when we
 187 finish the cdr.
 188
 189 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
 190 garbage collector cache misses.
 191
 192 Prefetch is supported on GCC >= 3.1
 193
 194 (Some time later.)
 195
 196 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
 197 Perhaps this would work better with an explicit markstack?
 198
 199
 200 */
 201
 202 void
 203 scm_gc_mark_dependencies (SCM p)
 204 #define FUNC_NAME "scm_gc_mark_dependencies"
 205 {
 206   register long i;
 207   register SCM ptr;
 208   SCM cell_type;
 209
 210   ptr = p;
 211  scm_mark_dependencies_again:
 212
 213   cell_type = SCM_GC_CELL_TYPE (ptr);
 214   switch (SCM_ITAG7 (cell_type))
 215     {
 216     case scm_tcs_cons_nimcar:
 217       if (SCM_IMP (SCM_CDR (ptr)))
 218         {
 219           ptr = SCM_CAR (ptr);
 220           goto gc_mark_nimp;
 221         }
 222
 223
 224       scm_gc_mark (SCM_CAR (ptr));
 225       ptr = SCM_CDR (ptr);
 226       goto gc_mark_nimp;
 227     case scm_tcs_cons_imcar:
 228       ptr = SCM_CDR (ptr);
 229       goto gc_mark_loop;
 230     case scm_tc7_pws:
 231
 232       scm_gc_mark (SCM_SETTER (ptr));
 233       ptr = SCM_PROCEDURE (ptr);
 234       goto gc_mark_loop;
 235     case scm_tcs_struct:
 236       {
 237         /* XXX - use less explicit code. */
 238         scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
 239         scm_t_bits * vtable_data = (scm_t_bits *) word0;
 240         SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
 241         long len = scm_i_symbol_length (layout);
 242         const char *fields_desc = scm_i_symbol_chars (layout);
 243         scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
 244
 245         if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 246           {
 247             scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
 248             scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
 249           }
 250         if (len)
 251           {
 252             long x;
 253
 254             for (x = 0; x < len - 2; x += 2, ++struct_data)
 255               if (fields_desc[x] == 'p')
 256                 scm_gc_mark (SCM_PACK (*struct_data));
 257             if (fields_desc[x] == 'p')
 258               {
 259                 if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
 260                   for (x = *struct_data++; x; --x, ++struct_data)
 261                     scm_gc_mark (SCM_PACK (*struct_data));
 262                 else
 263                   scm_gc_mark (SCM_PACK (*struct_data));
 264               }
 265           }
 266         /* mark vtable */
 267         ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
 268         goto gc_mark_loop;
 269       }
 270       break;
 271     case scm_tcs_closures:
 272       if (SCM_IMP (SCM_ENV (ptr)))
 273         {
 274           ptr = SCM_CLOSCAR (ptr);
 275           goto gc_mark_nimp;
 276         }
 277       scm_gc_mark (SCM_CLOSCAR (ptr));
 278       ptr = SCM_ENV (ptr);
 279       goto gc_mark_nimp;
 280     case scm_tc7_vector:
 281       i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
 282       if (i == 0)
 283         break;
 284       while (--i > 0)
 285         {
 286           SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
 287           if (SCM_NIMP (elt))
 288             scm_gc_mark (elt);
 289         }
 290       ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0);
 291       goto gc_mark_loop;
 292 #ifdef CCLO
 293     case scm_tc7_cclo:
 294       {
 295         size_t i = SCM_CCLO_LENGTH (ptr);
 296         size_t j;
 297         for (j = 1; j != i; ++j)
 298           {
 299             SCM obj = SCM_CCLO_REF (ptr, j);
 300             if (!SCM_IMP (obj))
 301               scm_gc_mark (obj);
 302           }
 303         ptr = SCM_CCLO_REF (ptr, 0);
 304         goto gc_mark_loop;
 305       }
 306 #endif
 307
 308     case scm_tc7_string:
 309       ptr = scm_i_string_mark (ptr);
 310       goto gc_mark_loop;
 311     case scm_tc7_stringbuf:
 312       ptr = scm_i_stringbuf_mark (ptr);
 313       goto gc_mark_loop;
 314
 315     case scm_tc7_number:
 316       if (SCM_TYP16 (ptr) == scm_tc16_fraction)
 317         {
 318           scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
 319           ptr = SCM_CELL_OBJECT_2 (ptr);
 320           goto gc_mark_loop;
 321         }
 322       break;
 323
 324     case scm_tc7_wvect:
 325       scm_i_mark_weak_vector (ptr);
 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     return;
 420
 421   SCM_SET_GC_MARK (ptr);
 422
 423   goto   scm_mark_dependencies_again;
 424
 425 }
 426 #undef FUNC_NAME
 427
 428
 429 /* Mark a region conservatively */
 430 void
 431 scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
 432 {
 433   unsigned long m;
 434
 435   for (m = 0; m < n; ++m)
 436     {
 437       SCM obj = * (SCM *) &x[m];
 438       long int segment = scm_i_find_heap_segment_containing_object (obj);
 439       if (segment >= 0)
 440         scm_gc_mark (obj);
 441     }
 442 }
 443
 444
 445 /* The function scm_in_heap_p determines whether an SCM value can be regarded as a
 446  * pointer to a cell on the heap.
 447  */
 448 int
 449 scm_in_heap_p (SCM value)
 450 {
 451   long int segment = scm_i_find_heap_segment_containing_object (value);
 452   return (segment >= 0);
 453 }
 454
 455
 456 #if SCM_ENABLE_DEPRECATED == 1
 457
 458 /* If an allocated cell is detected during garbage collection, this
 459  * means that some code has just obtained the object but was preempted
 460  * before the initialization of the object was completed.  This meanst
 461  * that some entries of the allocated cell may already contain SCM
 462  * objects.  Therefore, allocated cells are scanned conservatively.
 463  */
 464
 465 scm_t_bits scm_tc16_allocated;
 466
 467 static SCM
 468 allocated_mark (SCM cell)
 469 {
 470   unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
 471   unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
 472   unsigned int i;
 473
 474   for (i = 1; i != span * 2; ++i)
 475     {
 476       SCM obj = SCM_CELL_OBJECT (cell, i);
 477       long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
 478       if (obj_segment >= 0)
 479         scm_gc_mark (obj);
 480     }
 481   return SCM_BOOL_F;
 482 }
 483
 484 SCM
 485 scm_deprecated_newcell (void)
 486 {
 487   scm_c_issue_deprecation_warning
 488     ("SCM_NEWCELL is deprecated.  Use `scm_cell' instead.\n");
 489
 490   return scm_cell (scm_tc16_allocated, 0);
 491 }
 492
 493 SCM
 494 scm_deprecated_newcell2 (void)
 495 {
 496   scm_c_issue_deprecation_warning
 497     ("SCM_NEWCELL2 is deprecated.  Use `scm_double_cell' instead.\n");
 498
 499   return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
 500 }
 501
 502 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 503
 504
 505 void
 506 scm_gc_init_mark(void)
 507 {
 508 #if SCM_ENABLE_DEPRECATED == 1
 509   scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
 510   scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
 511 #endif
 512 }
 513