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
20 #ifdef 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 <stdlib.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
scm_mark_all(void)71 scm_mark_all (void)
72 {
73 long j;
74 int loops;
75
76 scm_i_init_weak_vectors_for_gc ();
77 scm_i_init_guardians_for_gc ();
78
79 scm_i_clear_mark_space ();
80
81 /* Mark every thread's stack and registers */
82 scm_threads_mark_stacks ();
83
84 j = SCM_NUM_PROTECTS;
85 while (j--)
86 scm_gc_mark (scm_sys_protects[j]);
87
88 /* mark the registered roots */
89 {
90 size_t i;
91 for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
92 {
93 SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i);
94 for (; !scm_is_null (l); l = SCM_CDR (l))
95 {
96 SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l)));
97 scm_gc_mark (*p);
98 }
99 }
100 }
101
102 scm_mark_subr_table ();
103
104 loops = 0;
105 while (1)
106 {
107 int again;
108 loops++;
109
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.
115 */
116 again = scm_i_mark_weak_vectors_non_weaks ();
117 if (again)
118 continue;
119
120 /* Now we scan all marked guardians and move all unmarked objects
121 from the accessible to the inaccessible list.
122 */
123 scm_i_identify_inaccessible_guardeds ();
124
125 /* When we have identified all inaccessible objects, we can mark
126 them.
127 */
128 again = scm_i_mark_inaccessible_guardeds ();
129
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.
133 */
134 if (again)
135 continue;
136
137 /* Nothing new marked in this round, we are done.
138 */
139 break;
140 }
141
142 /* fprintf (stderr, "%d loops\n", loops); */
143
144 /* Remove all unmarked entries from the weak vectors.
145 */
146 scm_i_remove_weaks_from_weak_vectors ();
147
148 /* Bring hashtables upto date.
149 */
150 scm_i_scan_weak_hashtables ();
151 }
152
153 /* {Mark/Sweep}
154 */
155
156 /*
157 Mark an object precisely, then recurse.
158 */
159 void
scm_gc_mark(SCM ptr)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 /*
173
174 Mark the dependencies of an object.
175
176 Prefetching:
177
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
181 finish the cdr.
182
183 See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
184 garbage collector cache misses.
185
186 Prefetch is supported on GCC >= 3.1
187
188 (Some time later.)
189
190 Tried this with GCC 3.1.1 -- the time differences are barely measurable.
191 Perhaps this would work better with an explicit markstack?
192
193
194 */
195
196 void
scm_gc_mark_dependencies(SCM p)197 scm_gc_mark_dependencies (SCM p)
198 #define FUNC_NAME "scm_gc_mark_dependencies"
199 {
200 register long i;
201 register SCM ptr;
202 SCM cell_type;
203
204 ptr = p;
205 scm_mark_dependencies_again:
206
207 cell_type = SCM_GC_CELL_TYPE (ptr);
208 switch (SCM_ITAG7 (cell_type))
209 {
210 case scm_tcs_cons_nimcar:
211 if (SCM_IMP (SCM_CDR (ptr)))
212 {
213 ptr = SCM_CAR (ptr);
214 goto gc_mark_nimp;
215 }
216
217
218 scm_gc_mark (SCM_CAR (ptr));
219 ptr = SCM_CDR (ptr);
220 goto gc_mark_nimp;
221 case scm_tcs_cons_imcar:
222 ptr = SCM_CDR (ptr);
223 goto gc_mark_loop;
224 case scm_tc7_pws:
225
226 scm_gc_mark (SCM_SETTER (ptr));
227 ptr = SCM_PROCEDURE (ptr);
228 goto gc_mark_loop;
229 case scm_tcs_struct:
230 {
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);
238
239 if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
240 {
241 scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
242 scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
243 }
244 if (len)
245 {
246 long x;
247
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')
252 {
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));
256 else
257 scm_gc_mark (SCM_PACK (*struct_data));
258 }
259 }
260 /* mark vtable */
261 ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
262 goto gc_mark_loop;
263 }
264 break;
265 case scm_tcs_closures:
266 if (SCM_IMP (SCM_ENV (ptr)))
267 {
268 ptr = SCM_CLOSCAR (ptr);
269 goto gc_mark_nimp;
270 }
271 scm_gc_mark (SCM_CLOSCAR (ptr));
272 ptr = SCM_ENV (ptr);
273 goto gc_mark_nimp;
274 case scm_tc7_vector:
275 i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
276 if (i == 0)
277 break;
278 while (--i > 0)
279 {
280 SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
281 if (SCM_NIMP (elt))
282 scm_gc_mark (elt);
283 }
284 ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0);
285 goto gc_mark_loop;
286 #ifdef CCLO
287 case scm_tc7_cclo:
288 {
289 size_t i = SCM_CCLO_LENGTH (ptr);
290 size_t j;
291 for (j = 1; j != i; ++j)
292 {
293 SCM obj = SCM_CCLO_REF (ptr, j);
294 if (!SCM_IMP (obj))
295 scm_gc_mark (obj);
296 }
297 ptr = SCM_CCLO_REF (ptr, 0);
298 goto gc_mark_loop;
299 }
300 #endif
301
302 case scm_tc7_string:
303 ptr = scm_i_string_mark (ptr);
304 goto gc_mark_loop;
305 case scm_tc7_stringbuf:
306 ptr = scm_i_stringbuf_mark (ptr);
307 goto gc_mark_loop;
308
309 case scm_tc7_number:
310 if (SCM_TYP16 (ptr) == scm_tc16_fraction)
311 {
312 scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
313 ptr = SCM_CELL_OBJECT_2 (ptr);
314 goto gc_mark_loop;
315 }
316 break;
317
318 case scm_tc7_wvect:
319 scm_i_mark_weak_vector (ptr);
320 break;
321
322 case scm_tc7_symbol:
323 ptr = scm_i_symbol_mark (ptr);
324 goto gc_mark_loop;
325 case scm_tc7_variable:
326 ptr = SCM_CELL_OBJECT_1 (ptr);
327 goto gc_mark_loop;
328 case scm_tcs_subrs:
329 break;
330 case scm_tc7_port:
331 i = SCM_PTOBNUM (ptr);
332 #if (SCM_DEBUG_CELL_ACCESSES == 1)
333 if (!(i < scm_numptob))
334 {
335 fprintf (stderr, "undefined port type");
336 abort();
337 }
338 #endif
339 if (SCM_PTAB_ENTRY(ptr))
340 scm_gc_mark (SCM_FILENAME (ptr));
341 if (scm_ptobs[i].mark)
342 {
343 ptr = (scm_ptobs[i].mark) (ptr);
344 goto gc_mark_loop;
345 }
346 else
347 return;
348 break;
349 case scm_tc7_smob:
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. */
356 break;
357 default:
358 i = SCM_SMOBNUM (ptr);
359 #if (SCM_DEBUG_CELL_ACCESSES == 1)
360 if (!(i < scm_numsmob))
361 {
362 fprintf (stderr, "undefined smob type");
363 abort();
364 }
365 #endif
366 if (scm_smobs[i].mark)
367 {
368 ptr = (scm_smobs[i].mark) (ptr);
369 goto gc_mark_loop;
370 }
371 else
372 return;
373 }
374 break;
375 default:
376 fprintf (stderr, "unknown type");
377 abort();
378 }
379
380 /*
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
383 were called with.)
384 */
385 return ;
386
387 gc_mark_loop:
388 if (SCM_IMP (ptr))
389 return;
390
391 gc_mark_nimp:
392 {
393 int valid_cell = CELL_P (ptr);
394
395
396 #if (SCM_DEBUG_CELL_ACCESSES == 1)
397 if (scm_debug_cell_accesses_p)
398 {
399 /* We are in debug mode. Check the ptr exhaustively. */
400
401 valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
402 }
403
404 #endif
405 if (!valid_cell)
406 {
407 fprintf (stderr, "rogue pointer in heap");
408 abort();
409 }
410 }
411
412 if (SCM_GC_MARK_P (ptr))
413 {
414 return;
415 }
416
417 SCM_SET_GC_MARK (ptr);
418
419 goto scm_mark_dependencies_again;
420
421 }
422 #undef FUNC_NAME
423
424
425
426
427 /* Mark a region conservatively */
428 void
scm_mark_locations(SCM_STACKITEM x[],unsigned long n)429 scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
430 {
431 unsigned long m;
432
433 for (m = 0; m < n; ++m)
434 {
435 SCM obj = * (SCM *) &x[m];
436 long int segment = scm_i_find_heap_segment_containing_object (obj);
437 if (segment >= 0)
438 scm_gc_mark (obj);
439 }
440 }
441
442
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.
445 */
446 int
scm_in_heap_p(SCM value)447 scm_in_heap_p (SCM value)
448 {
449 long int segment = scm_i_find_heap_segment_containing_object (value);
450 return (segment >= 0);
451 }
452
453
454 #if SCM_ENABLE_DEPRECATED == 1
455
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.
461 */
462
463 scm_t_bits scm_tc16_allocated;
464
465 static SCM
allocated_mark(SCM cell)466 allocated_mark (SCM cell)
467 {
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;
470 unsigned int i;
471
472 for (i = 1; i != span * 2; ++i)
473 {
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)
477 scm_gc_mark (obj);
478 }
479 return SCM_BOOL_F;
480 }
481
482 SCM
scm_deprecated_newcell(void)483 scm_deprecated_newcell (void)
484 {
485 scm_c_issue_deprecation_warning
486 ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
487
488 return scm_cell (scm_tc16_allocated, 0);
489 }
490
491 SCM
scm_deprecated_newcell2(void)492 scm_deprecated_newcell2 (void)
493 {
494 scm_c_issue_deprecation_warning
495 ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
496
497 return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
498 }
499
500 #endif /* SCM_ENABLE_DEPRECATED == 1 */
501
502
503 void
scm_gc_init_mark(void)504 scm_gc_init_mark(void)
505 {
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);
509 #endif
510 }
511
512