1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 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 # define SCM_MARK_BACKING_STORE() do { \
69 SCM_STACKITEM * top, * bot; \
71 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
72 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
73 / sizeof (SCM_STACKITEM))); \
74 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
75 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
76 scm_mark_locations (bot, top - bot); } while (0)
78 # define SCM_MARK_BACKING_STORE()
83 Entry point for this file.
91 scm_i_clear_mark_space ();
93 /* Mark every thread's stack and registers */
94 scm_threads_mark_stacks ();
98 scm_gc_mark (scm_sys_protects
[j
]);
100 /* mark the registered roots */
103 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots
); ++i
)
105 SCM l
= SCM_HASHTABLE_BUCKETS (scm_gc_registered_roots
)[i
];
106 for (; !SCM_NULLP (l
); l
= SCM_CDR (l
))
108 SCM
*p
= (SCM
*) (scm_num2long (SCM_CAAR (l
), 0, NULL
));
115 /* FIXME: we should have a means to register C functions to be run
116 * in different phases of GC
118 scm_mark_subr_table ();
125 Mark an object precisely, then recurse.
128 scm_gc_mark (SCM ptr
)
133 if (SCM_GC_MARK_P (ptr
))
136 SCM_SET_GC_MARK (ptr
);
137 scm_gc_mark_dependencies (ptr
);
142 Mark the dependencies of an object.
146 Should prefetch objects before marking, i.e. if marking a cell, we
147 should prefetch the car, and then mark the cdr. This will improve CPU
148 cache misses, because the car is more likely to be in core when we
151 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
152 garbage collector cache misses.
154 Prefetch is supported on GCC >= 3.1
158 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
159 Perhaps this would work better with an explicit markstack?
164 scm_gc_mark_dependencies (SCM p
)
165 #define FUNC_NAME "scm_gc_mark_dependencies"
172 scm_mark_dependencies_again
:
174 cell_type
= SCM_GC_CELL_TYPE (ptr
);
175 switch (SCM_ITAG7 (cell_type
))
177 case scm_tcs_cons_nimcar
:
178 if (SCM_IMP (SCM_CDR (ptr
)))
185 scm_gc_mark (SCM_CAR (ptr
));
188 case scm_tcs_cons_imcar
:
193 scm_gc_mark (SCM_SETTER (ptr
));
194 ptr
= SCM_PROCEDURE (ptr
);
198 /* XXX - use less explicit code. */
199 scm_t_bits word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_struct
;
200 scm_t_bits
* vtable_data
= (scm_t_bits
*) word0
;
201 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
202 long len
= SCM_SYMBOL_LENGTH (layout
);
203 char * fields_desc
= SCM_SYMBOL_CHARS (layout
);
204 scm_t_bits
* struct_data
= (scm_t_bits
*) SCM_STRUCT_DATA (ptr
);
206 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
208 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
209 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
215 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
216 if (fields_desc
[x
] == 'p')
217 scm_gc_mark (SCM_PACK (*struct_data
));
218 if (fields_desc
[x
] == 'p')
220 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
221 for (x
= *struct_data
++; x
; --x
, ++struct_data
)
222 scm_gc_mark (SCM_PACK (*struct_data
));
224 scm_gc_mark (SCM_PACK (*struct_data
));
228 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
232 case scm_tcs_closures
:
233 if (SCM_IMP (SCM_ENV (ptr
)))
235 ptr
= SCM_CLOSCAR (ptr
);
238 scm_gc_mark (SCM_CLOSCAR (ptr
));
242 i
= SCM_VECTOR_LENGTH (ptr
);
247 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
248 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
250 ptr
= SCM_VELTS (ptr
)[0];
255 size_t i
= SCM_CCLO_LENGTH (ptr
);
257 for (j
= 1; j
!= i
; ++j
)
259 SCM obj
= SCM_CCLO_REF (ptr
, j
);
263 ptr
= SCM_CCLO_REF (ptr
, 0);
276 #if SCM_SIZEOF_LONG_LONG != 0
284 if (SCM_TYP16 (ptr
) == scm_tc16_fraction
)
286 scm_gc_mark (SCM_CELL_OBJECT_1 (ptr
));
287 ptr
= SCM_CELL_OBJECT_2 (ptr
);
293 SCM_SET_WVECT_GC_CHAIN (ptr
, scm_weak_vectors
);
294 scm_weak_vectors
= ptr
;
295 if (SCM_IS_WHVEC_ANY (ptr
))
302 len
= SCM_VECTOR_LENGTH (ptr
);
303 weak_keys
= SCM_WVECT_WEAK_KEY_P (ptr
);
304 weak_values
= SCM_WVECT_WEAK_VALUE_P (ptr
);
306 for (x
= 0; x
< len
; ++x
)
309 alist
= SCM_VELTS (ptr
)[x
];
311 /* mark everything on the alist except the keys or
312 * values, according to weak_values and weak_keys. */
313 while ( SCM_CONSP (alist
)
314 && !SCM_GC_MARK_P (alist
)
315 && SCM_CONSP (SCM_CAR (alist
)))
320 kvpair
= SCM_CAR (alist
);
321 next_alist
= SCM_CDR (alist
);
324 * SCM_SET_GC_MARK (alist);
325 * SCM_SET_GC_MARK (kvpair);
327 * It may be that either the key or value is protected by
328 * an escaped reference to part of the spine of this alist.
329 * If we mark the spine here, and only mark one or neither of the
330 * key and value, they may never be properly marked.
331 * This leads to a horrible situation in which an alist containing
332 * freelist cells is exported.
334 * So only mark the spines of these arrays last of all marking.
335 * If somebody confuses us by constructing a weak vector
336 * with a circular alist then we are hosed, but at least we
337 * won't prematurely drop table entries.
340 scm_gc_mark (SCM_CAR (kvpair
));
342 scm_gc_mark (SCM_CDR (kvpair
));
345 if (SCM_NIMP (alist
))
352 ptr
= SCM_PROP_SLOTS (ptr
);
354 case scm_tc7_variable
:
355 ptr
= SCM_CELL_OBJECT_1 (ptr
);
360 i
= SCM_PTOBNUM (ptr
);
361 #if (SCM_DEBUG_CELL_ACCESSES == 1)
362 if (!(i
< scm_numptob
))
364 fprintf (stderr
, "undefined port type");
368 if (SCM_PTAB_ENTRY(ptr
))
369 scm_gc_mark (SCM_FILENAME (ptr
));
370 if (scm_ptobs
[i
].mark
)
372 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
379 switch (SCM_TYP16 (ptr
))
380 { /* should be faster than going through scm_smobs */
381 case scm_tc_free_cell
:
382 /* We have detected a free cell. This can happen if non-object data
383 * on the C stack points into guile's heap and is scanned during
384 * conservative marking. */
387 i
= SCM_SMOBNUM (ptr
);
388 #if (SCM_DEBUG_CELL_ACCESSES == 1)
389 if (!(i
< scm_numsmob
))
391 fprintf (stderr
, "undefined smob type");
395 if (scm_smobs
[i
].mark
)
397 ptr
= (scm_smobs
[i
].mark
) (ptr
);
405 fprintf (stderr
, "unknown type");
410 If we got here, then exhausted recursion options for PTR. we
411 return (careful not to mark PTR, it might be the argument that we
422 int valid_cell
= CELL_P (ptr
);
425 #if (SCM_DEBUG_CELL_ACCESSES == 1)
426 if (scm_debug_cell_accesses_p
)
428 /* We are in debug mode. Check the ptr exhaustively. */
430 valid_cell
= valid_cell
&& (scm_i_find_heap_segment_containing_object (ptr
) >= 0);
436 fprintf (stderr
, "rogue pointer in heap");
441 if (SCM_GC_MARK_P (ptr
))
446 SCM_SET_GC_MARK (ptr
);
448 goto scm_mark_dependencies_again
;
456 /* Mark a region conservatively */
458 scm_mark_locations (SCM_STACKITEM x
[], unsigned long n
)
462 for (m
= 0; m
< n
; ++m
)
464 SCM obj
= * (SCM
*) &x
[m
];
465 long int segment
= scm_i_find_heap_segment_containing_object (obj
);
472 /* The function scm_in_heap_p determines whether an SCM value can be regarded as a
473 * pointer to a cell on the heap.
476 scm_in_heap_p (SCM value
)
478 long int segment
= scm_i_find_heap_segment_containing_object (value
);
479 return (segment
>= 0);
483 #if SCM_ENABLE_DEPRECATED == 1
485 /* If an allocated cell is detected during garbage collection, this
486 * means that some code has just obtained the object but was preempted
487 * before the initialization of the object was completed. This meanst
488 * that some entries of the allocated cell may already contain SCM
489 * objects. Therefore, allocated cells are scanned conservatively.
492 scm_t_bits scm_tc16_allocated
;
495 allocated_mark (SCM cell
)
497 unsigned long int cell_segment
= scm_i_find_heap_segment_containing_object (cell
);
498 unsigned int span
= scm_i_heap_segment_table
[cell_segment
]->span
;
501 for (i
= 1; i
!= span
* 2; ++i
)
503 SCM obj
= SCM_CELL_OBJECT (cell
, i
);
504 long int obj_segment
= scm_i_find_heap_segment_containing_object (obj
);
505 if (obj_segment
>= 0)
512 scm_deprecated_newcell (void)
514 scm_c_issue_deprecation_warning
515 ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
517 return scm_cell (scm_tc16_allocated
, 0);
521 scm_deprecated_newcell2 (void)
523 scm_c_issue_deprecation_warning
524 ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
526 return scm_double_cell (scm_tc16_allocated
, 0, 0, 0);
529 #endif /* SCM_ENABLE_DEPRECATED == 1 */
533 scm_gc_init_mark(void)
535 #if SCM_ENABLE_DEPRECATED == 1
536 scm_tc16_allocated
= scm_make_smob_type ("allocated cell", 0);
537 scm_set_smob_mark (scm_tc16_allocated
, allocated_mark
);