1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
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.
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.
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
31 extern unsigned long * __libc_ia64_register_backing_store_base
;
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"
55 #ifdef GUILE_DEBUG_MALLOC
56 #include "libguile/debug-malloc.h"
68 Entry point for this file.
76 scm_i_init_weak_vectors_for_gc ();
77 scm_i_init_guardians_for_gc ();
79 scm_i_clear_mark_space ();
81 /* Mark every thread's stack and registers */
82 scm_threads_mark_stacks ();
86 scm_gc_mark (scm_sys_protects
[j
]);
88 /* mark the registered roots */
91 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots
); ++i
)
93 SCM l
= SCM_HASHTABLE_BUCKET (scm_gc_registered_roots
, i
);
94 for (; !scm_is_null (l
); l
= SCM_CDR (l
))
96 SCM
*p
= (SCM
*) (scm_to_ulong (SCM_CAAR (l
)));
102 scm_mark_subr_table ();
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.
116 again
= scm_i_mark_weak_vectors_non_weaks ();
120 /* Now we scan all marked guardians and move all unmarked objects
121 from the accessible to the inaccessible list.
123 scm_i_identify_inaccessible_guardeds ();
125 /* When we have identified all inaccessible objects, we can mark
128 again
= scm_i_mark_inaccessible_guardeds ();
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.
137 /* Nothing new marked in this round, we are done.
142 /* fprintf (stderr, "%d loops\n", loops); */
144 /* Remove all unmarked entries from the weak vectors.
146 scm_i_remove_weaks_from_weak_vectors ();
148 /* Bring hashtables upto date.
150 scm_i_scan_weak_hashtables ();
157 Mark an object precisely, then recurse.
160 scm_gc_mark (SCM ptr
)
165 if (SCM_GC_MARK_P (ptr
))
168 SCM_SET_GC_MARK (ptr
);
169 scm_gc_mark_dependencies (ptr
);
174 Mark the dependencies of an object.
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
183 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
184 garbage collector cache misses.
186 Prefetch is supported on GCC >= 3.1
190 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
191 Perhaps this would work better with an explicit markstack?
197 scm_gc_mark_dependencies (SCM p
)
198 #define FUNC_NAME "scm_gc_mark_dependencies"
205 scm_mark_dependencies_again
:
207 cell_type
= SCM_GC_CELL_TYPE (ptr
);
208 switch (SCM_ITAG7 (cell_type
))
210 case scm_tcs_cons_nimcar
:
211 if (SCM_IMP (SCM_CDR (ptr
)))
218 scm_gc_mark (SCM_CAR (ptr
));
221 case scm_tcs_cons_imcar
:
226 scm_gc_mark (SCM_SETTER (ptr
));
227 ptr
= SCM_PROCEDURE (ptr
);
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
);
239 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
241 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
242 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
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')
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
));
257 scm_gc_mark (SCM_PACK (*struct_data
));
261 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
265 case scm_tcs_closures
:
266 if (SCM_IMP (SCM_ENV (ptr
)))
268 ptr
= SCM_CLOSCAR (ptr
);
271 scm_gc_mark (SCM_CLOSCAR (ptr
));
275 i
= SCM_SIMPLE_VECTOR_LENGTH (ptr
);
280 SCM elt
= SCM_SIMPLE_VECTOR_REF (ptr
, i
);
284 ptr
= SCM_SIMPLE_VECTOR_REF (ptr
, 0);
289 size_t i
= SCM_CCLO_LENGTH (ptr
);
291 for (j
= 1; j
!= i
; ++j
)
293 SCM obj
= SCM_CCLO_REF (ptr
, j
);
297 ptr
= SCM_CCLO_REF (ptr
, 0);
303 ptr
= scm_i_string_mark (ptr
);
305 case scm_tc7_stringbuf
:
306 ptr
= scm_i_stringbuf_mark (ptr
);
310 if (SCM_TYP16 (ptr
) == scm_tc16_fraction
)
312 scm_gc_mark (SCM_CELL_OBJECT_1 (ptr
));
313 ptr
= SCM_CELL_OBJECT_2 (ptr
);
319 scm_i_mark_weak_vector (ptr
);
323 ptr
= scm_i_symbol_mark (ptr
);
325 case scm_tc7_variable
:
326 ptr
= SCM_CELL_OBJECT_1 (ptr
);
331 i
= SCM_PTOBNUM (ptr
);
332 #if (SCM_DEBUG_CELL_ACCESSES == 1)
333 if (!(i
< scm_numptob
))
335 fprintf (stderr
, "undefined port type");
339 if (SCM_PTAB_ENTRY(ptr
))
340 scm_gc_mark (SCM_FILENAME (ptr
));
341 if (scm_ptobs
[i
].mark
)
343 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
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. */
358 i
= SCM_SMOBNUM (ptr
);
359 #if (SCM_DEBUG_CELL_ACCESSES == 1)
360 if (!(i
< scm_numsmob
))
362 fprintf (stderr
, "undefined smob type");
366 if (scm_smobs
[i
].mark
)
368 ptr
= (scm_smobs
[i
].mark
) (ptr
);
376 fprintf (stderr
, "unknown type");
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
393 int valid_cell
= CELL_P (ptr
);
396 #if (SCM_DEBUG_CELL_ACCESSES == 1)
397 if (scm_debug_cell_accesses_p
)
399 /* We are in debug mode. Check the ptr exhaustively. */
401 valid_cell
= valid_cell
&& (scm_i_find_heap_segment_containing_object (ptr
) >= 0);
407 fprintf (stderr
, "rogue pointer in heap");
412 if (SCM_GC_MARK_P (ptr
))
417 SCM_SET_GC_MARK (ptr
);
419 goto scm_mark_dependencies_again
;
427 /* Mark a region conservatively */
429 scm_mark_locations (SCM_STACKITEM x
[], unsigned long n
)
433 for (m
= 0; m
< n
; ++m
)
435 SCM obj
= * (SCM
*) &x
[m
];
436 long int segment
= scm_i_find_heap_segment_containing_object (obj
);
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.
447 scm_in_heap_p (SCM value
)
449 long int segment
= scm_i_find_heap_segment_containing_object (value
);
450 return (segment
>= 0);
454 #if SCM_ENABLE_DEPRECATED == 1
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.
463 scm_t_bits scm_tc16_allocated
;
466 allocated_mark (SCM cell
)
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
;
472 for (i
= 1; i
!= span
* 2; ++i
)
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)
483 scm_deprecated_newcell (void)
485 scm_c_issue_deprecation_warning
486 ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
488 return scm_cell (scm_tc16_allocated
, 0);
492 scm_deprecated_newcell2 (void)
494 scm_c_issue_deprecation_warning
495 ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
497 return scm_double_cell (scm_tc16_allocated
, 0, 0, 0);
500 #endif /* SCM_ENABLE_DEPRECATED == 1 */
504 scm_gc_init_mark(void)
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
);