1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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"
54 #ifdef GUILE_DEBUG_MALLOC
55 #include "libguile/debug-malloc.h"
67 Entry point for this file.
75 scm_i_clear_mark_space ();
77 /* Mark every thread's stack and registers */
78 scm_threads_mark_stacks ();
82 scm_gc_mark (scm_sys_protects
[j
]);
84 /* mark the registered roots */
87 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots
); ++i
)
89 SCM l
= SCM_HASHTABLE_BUCKET (scm_gc_registered_roots
, i
);
90 for (; !scm_is_null (l
); l
= SCM_CDR (l
))
92 SCM
*p
= (SCM
*) (scm_to_ulong (SCM_CAAR (l
)));
99 /* FIXME: we should have a means to register C functions to be run
100 * in different phases of GC
102 scm_mark_subr_table ();
109 Mark an object precisely, then recurse.
112 scm_gc_mark (SCM ptr
)
117 if (SCM_GC_MARK_P (ptr
))
120 SCM_SET_GC_MARK (ptr
);
121 scm_gc_mark_dependencies (ptr
);
126 Mark the dependencies of an object.
130 Should prefetch objects before marking, i.e. if marking a cell, we
131 should prefetch the car, and then mark the cdr. This will improve CPU
132 cache misses, because the car is more likely to be in core when we
135 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
136 garbage collector cache misses.
138 Prefetch is supported on GCC >= 3.1
142 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
143 Perhaps this would work better with an explicit markstack?
148 scm_gc_mark_dependencies (SCM p
)
149 #define FUNC_NAME "scm_gc_mark_dependencies"
156 scm_mark_dependencies_again
:
158 cell_type
= SCM_GC_CELL_TYPE (ptr
);
159 switch (SCM_ITAG7 (cell_type
))
161 case scm_tcs_cons_nimcar
:
162 if (SCM_IMP (SCM_CDR (ptr
)))
169 scm_gc_mark (SCM_CAR (ptr
));
172 case scm_tcs_cons_imcar
:
177 scm_gc_mark (SCM_SETTER (ptr
));
178 ptr
= SCM_PROCEDURE (ptr
);
182 /* XXX - use less explicit code. */
183 scm_t_bits word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_struct
;
184 scm_t_bits
* vtable_data
= (scm_t_bits
*) word0
;
185 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
186 long len
= scm_i_symbol_length (layout
);
187 const char *fields_desc
= scm_i_symbol_chars (layout
);
188 scm_t_bits
*struct_data
= (scm_t_bits
*) SCM_STRUCT_DATA (ptr
);
190 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
192 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
193 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
199 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
200 if (fields_desc
[x
] == 'p')
201 scm_gc_mark (SCM_PACK (*struct_data
));
202 if (fields_desc
[x
] == 'p')
204 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
205 for (x
= *struct_data
++; x
; --x
, ++struct_data
)
206 scm_gc_mark (SCM_PACK (*struct_data
));
208 scm_gc_mark (SCM_PACK (*struct_data
));
212 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
216 case scm_tcs_closures
:
217 if (SCM_IMP (SCM_ENV (ptr
)))
219 ptr
= SCM_CLOSCAR (ptr
);
222 scm_gc_mark (SCM_CLOSCAR (ptr
));
226 i
= SCM_SIMPLE_VECTOR_LENGTH (ptr
);
231 SCM elt
= SCM_SIMPLE_VECTOR_REF (ptr
, i
);
235 ptr
= SCM_SIMPLE_VECTOR_REF (ptr
, 0);
240 size_t i
= SCM_CCLO_LENGTH (ptr
);
242 for (j
= 1; j
!= i
; ++j
)
244 SCM obj
= SCM_CCLO_REF (ptr
, j
);
248 ptr
= SCM_CCLO_REF (ptr
, 0);
254 ptr
= scm_i_string_mark (ptr
);
256 case scm_tc7_stringbuf
:
257 ptr
= scm_i_stringbuf_mark (ptr
);
261 if (SCM_TYP16 (ptr
) == scm_tc16_fraction
)
263 scm_gc_mark (SCM_CELL_OBJECT_1 (ptr
));
264 ptr
= SCM_CELL_OBJECT_2 (ptr
);
270 SCM_I_SET_WVECT_GC_CHAIN (ptr
, scm_weak_vectors
);
271 scm_weak_vectors
= ptr
;
272 if (SCM_IS_WHVEC_ANY (ptr
))
279 len
= SCM_SIMPLE_VECTOR_LENGTH (ptr
);
280 weak_keys
= SCM_WVECT_WEAK_KEY_P (ptr
);
281 weak_values
= SCM_WVECT_WEAK_VALUE_P (ptr
);
283 for (x
= 0; x
< len
; ++x
)
286 alist
= SCM_SIMPLE_VECTOR_REF (ptr
, x
);
288 /* mark everything on the alist except the keys or
289 * values, according to weak_values and weak_keys. */
290 while ( scm_is_pair (alist
)
291 && !SCM_GC_MARK_P (alist
)
292 && scm_is_pair (SCM_CAR (alist
)))
297 kvpair
= SCM_CAR (alist
);
298 next_alist
= SCM_CDR (alist
);
301 * SCM_SET_GC_MARK (alist);
302 * SCM_SET_GC_MARK (kvpair);
304 * It may be that either the key or value is protected by
305 * an escaped reference to part of the spine of this alist.
306 * If we mark the spine here, and only mark one or neither of the
307 * key and value, they may never be properly marked.
308 * This leads to a horrible situation in which an alist containing
309 * freelist cells is exported.
311 * So only mark the spines of these arrays last of all marking.
312 * If somebody confuses us by constructing a weak vector
313 * with a circular alist then we are hosed, but at least we
314 * won't prematurely drop table entries.
317 scm_gc_mark (SCM_CAR (kvpair
));
319 scm_gc_mark (SCM_CDR (kvpair
));
322 if (SCM_NIMP (alist
))
329 ptr
= scm_i_symbol_mark (ptr
);
331 case scm_tc7_variable
:
332 ptr
= SCM_CELL_OBJECT_1 (ptr
);
337 i
= SCM_PTOBNUM (ptr
);
338 #if (SCM_DEBUG_CELL_ACCESSES == 1)
339 if (!(i
< scm_numptob
))
341 fprintf (stderr
, "undefined port type");
345 if (SCM_PTAB_ENTRY(ptr
))
346 scm_gc_mark (SCM_FILENAME (ptr
));
347 if (scm_ptobs
[i
].mark
)
349 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
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. */
364 i
= SCM_SMOBNUM (ptr
);
365 #if (SCM_DEBUG_CELL_ACCESSES == 1)
366 if (!(i
< scm_numsmob
))
368 fprintf (stderr
, "undefined smob type");
372 if (scm_smobs
[i
].mark
)
374 ptr
= (scm_smobs
[i
].mark
) (ptr
);
382 fprintf (stderr
, "unknown type");
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
399 int valid_cell
= CELL_P (ptr
);
402 #if (SCM_DEBUG_CELL_ACCESSES == 1)
403 if (scm_debug_cell_accesses_p
)
405 /* We are in debug mode. Check the ptr exhaustively. */
407 valid_cell
= valid_cell
&& (scm_i_find_heap_segment_containing_object (ptr
) >= 0);
413 fprintf (stderr
, "rogue pointer in heap");
418 if (SCM_GC_MARK_P (ptr
))
423 SCM_SET_GC_MARK (ptr
);
425 goto scm_mark_dependencies_again
;
433 /* Mark a region conservatively */
435 scm_mark_locations (SCM_STACKITEM x
[], unsigned long n
)
439 for (m
= 0; m
< n
; ++m
)
441 SCM obj
= * (SCM
*) &x
[m
];
442 long int segment
= scm_i_find_heap_segment_containing_object (obj
);
449 /* The function scm_in_heap_p determines whether an SCM value can be regarded as a
450 * pointer to a cell on the heap.
453 scm_in_heap_p (SCM value
)
455 long int segment
= scm_i_find_heap_segment_containing_object (value
);
456 return (segment
>= 0);
460 #if SCM_ENABLE_DEPRECATED == 1
462 /* If an allocated cell is detected during garbage collection, this
463 * means that some code has just obtained the object but was preempted
464 * before the initialization of the object was completed. This meanst
465 * that some entries of the allocated cell may already contain SCM
466 * objects. Therefore, allocated cells are scanned conservatively.
469 scm_t_bits scm_tc16_allocated
;
472 allocated_mark (SCM cell
)
474 unsigned long int cell_segment
= scm_i_find_heap_segment_containing_object (cell
);
475 unsigned int span
= scm_i_heap_segment_table
[cell_segment
]->span
;
478 for (i
= 1; i
!= span
* 2; ++i
)
480 SCM obj
= SCM_CELL_OBJECT (cell
, i
);
481 long int obj_segment
= scm_i_find_heap_segment_containing_object (obj
);
482 if (obj_segment
>= 0)
489 scm_deprecated_newcell (void)
491 scm_c_issue_deprecation_warning
492 ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
494 return scm_cell (scm_tc16_allocated
, 0);
498 scm_deprecated_newcell2 (void)
500 scm_c_issue_deprecation_warning
501 ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
503 return scm_double_cell (scm_tc16_allocated
, 0, 0, 0);
506 #endif /* SCM_ENABLE_DEPRECATED == 1 */
510 scm_gc_init_mark(void)
512 #if SCM_ENABLE_DEPRECATED == 1
513 scm_tc16_allocated
= scm_make_smob_type ("allocated cell", 0);
514 scm_set_smob_mark (scm_tc16_allocated
, allocated_mark
);