1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 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
20 /* #define DEBUGINFO */
31 #include "libguile/_scm.h"
32 #include "libguile/eval.h"
33 #include "libguile/stime.h"
34 #include "libguile/stackchk.h"
35 #include "libguile/struct.h"
36 #include "libguile/smob.h"
37 #include "libguile/unif.h"
38 #include "libguile/async.h"
39 #include "libguile/ports.h"
40 #include "libguile/root.h"
41 #include "libguile/strings.h"
42 #include "libguile/vectors.h"
43 #include "libguile/weaks.h"
44 #include "libguile/hashtab.h"
45 #include "libguile/tags.h"
47 #include "libguile/private-gc.h"
48 #include "libguile/validate.h"
49 #include "libguile/deprecation.h"
50 #include "libguile/gc.h"
51 #include "libguile/dynwind.h"
53 #ifdef GUILE_DEBUG_MALLOC
54 #include "libguile/debug-malloc.h"
65 /* Lock this mutex before doing lazy sweeping.
67 scm_i_pthread_mutex_t scm_i_sweep_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
69 /* Set this to != 0 if every cell that is accessed shall be checked:
71 int scm_debug_cell_accesses_p
= 0;
72 int scm_expensive_debug_cell_accesses_p
= 0;
74 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
75 * the number of cell accesses after which a gc shall be called.
77 int scm_debug_cells_gc_interval
= 0;
80 Global variable, so you can switch it off at runtime by setting
81 scm_i_cell_validation_already_running.
83 int scm_i_cell_validation_already_running
;
85 #if (SCM_DEBUG_CELL_ACCESSES == 1)
90 Assert that the given object is a valid reference to a valid cell. This
91 test involves to determine whether the object is a cell pointer, whether
92 this pointer actually points into a heap segment and whether the cell
93 pointed to is not a free cell. Further, additional garbage collections may
94 get executed after a user defined number of cell accesses. This helps to
95 find places in the C code where references are dropped for extremely short
100 scm_i_expensive_validation_check (SCM cell
)
102 if (!scm_in_heap_p (cell
))
104 fprintf (stderr
, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
105 (unsigned long) SCM_UNPACK (cell
));
109 /* If desired, perform additional garbage collections after a user
110 * defined number of cell accesses.
112 if (scm_debug_cells_gc_interval
)
114 static unsigned int counter
= 0;
122 counter
= scm_debug_cells_gc_interval
;
129 scm_assert_cell_valid (SCM cell
)
131 if (!scm_i_cell_validation_already_running
&& scm_debug_cell_accesses_p
)
133 scm_i_cell_validation_already_running
= 1; /* set to avoid recursion */
136 During GC, no user-code should be run, and the guile core
137 should use non-protected accessors.
139 if (scm_gc_running_p
)
143 Only scm_in_heap_p and rescanning the heap is wildly
146 if (scm_expensive_debug_cell_accesses_p
)
147 scm_i_expensive_validation_check (cell
);
149 if (!SCM_GC_MARK_P (cell
))
152 "scm_assert_cell_valid: this object is unmarked. \n"
153 "It has been garbage-collected in the last GC run: "
155 (unsigned long) SCM_UNPACK (cell
));
159 scm_i_cell_validation_already_running
= 0; /* re-enable */
165 SCM_DEFINE (scm_set_debug_cell_accesses_x
, "set-debug-cell-accesses!", 1, 0, 0,
167 "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
168 "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
169 "but no additional calls to garbage collection are issued.\n"
170 "If @var{flag} is a number, strict cell access checking is enabled,\n"
171 "with an additional garbage collection after the given\n"
172 "number of cell accesses.\n"
173 "This procedure only exists when the compile-time flag\n"
174 "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
175 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
177 if (scm_is_false (flag
))
179 scm_debug_cell_accesses_p
= 0;
181 else if (scm_is_eq (flag
, SCM_BOOL_T
))
183 scm_debug_cells_gc_interval
= 0;
184 scm_debug_cell_accesses_p
= 1;
185 scm_expensive_debug_cell_accesses_p
= 0;
189 scm_debug_cells_gc_interval
= scm_to_signed_integer (flag
, 0, INT_MAX
);
190 scm_debug_cell_accesses_p
= 1;
191 scm_expensive_debug_cell_accesses_p
= 1;
193 return SCM_UNSPECIFIED
;
198 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
204 * is the number of bytes of malloc allocation needed to trigger gc.
206 unsigned long scm_mtrigger
;
208 /* GC Statistics Keeping
210 unsigned long scm_cells_allocated
= 0;
211 unsigned long scm_last_cells_allocated
= 0;
212 unsigned long scm_mallocated
= 0;
214 /* Global GC sweep statistics since the last full GC. */
215 static scm_t_sweep_statistics scm_i_gc_sweep_stats
= { 0, 0 };
216 static scm_t_sweep_statistics scm_i_gc_sweep_stats_1
= { 0, 0 };
218 /* Total count of cells marked/swept. */
219 static double scm_gc_cells_marked_acc
= 0.;
220 static double scm_gc_cells_swept_acc
= 0.;
221 static double scm_gc_cells_allocated_acc
= 0.;
223 static unsigned long scm_gc_time_taken
= 0;
224 static unsigned long t_before_gc
;
225 static unsigned long scm_gc_mark_time_taken
= 0;
227 static unsigned long scm_gc_times
= 0;
229 static int scm_gc_cell_yield_percentage
= 0;
230 static unsigned long protected_obj_count
= 0;
232 /* The following are accessed from `gc-malloc.c' and `gc-card.c'. */
233 int scm_gc_malloc_yield_percentage
= 0;
234 unsigned long scm_gc_malloc_collected
= 0;
237 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
238 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
239 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
240 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
241 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
242 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
243 SCM_SYMBOL (sym_gc_mark_time_taken
, "gc-mark-time-taken");
244 SCM_SYMBOL (sym_times
, "gc-times");
245 SCM_SYMBOL (sym_cells_marked
, "cells-marked");
246 SCM_SYMBOL (sym_cells_swept
, "cells-swept");
247 SCM_SYMBOL (sym_malloc_yield
, "malloc-yield");
248 SCM_SYMBOL (sym_cell_yield
, "cell-yield");
249 SCM_SYMBOL (sym_protected_objects
, "protected-objects");
250 SCM_SYMBOL (sym_total_cells_allocated
, "total-cells-allocated");
253 /* Number of calls to SCM_NEWCELL since startup. */
254 unsigned scm_newcell_count
;
255 unsigned scm_newcell2_count
;
258 /* {Scheme Interface to GC}
261 tag_table_to_type_alist (void *closure
, SCM key
, SCM val
, SCM acc
)
263 if (scm_is_integer (key
))
265 int c_tag
= scm_to_int (key
);
267 char const * name
= scm_i_tag_name (c_tag
);
270 key
= scm_from_locale_string (name
);
275 sprintf (s
, "tag %d", c_tag
);
276 key
= scm_from_locale_string (s
);
280 return scm_cons (scm_cons (key
, val
), acc
);
283 SCM_DEFINE (scm_gc_live_object_stats
, "gc-live-object-stats", 0, 0, 0,
285 "Return an alist of statistics of the current live objects. ")
286 #define FUNC_NAME s_scm_gc_live_object_stats
288 SCM tab
= scm_make_hash_table (scm_from_int (57));
291 scm_i_all_segments_statistics (tab
);
294 = scm_internal_hash_fold (&tag_table_to_type_alist
, NULL
, SCM_EOL
, tab
);
300 extern int scm_gc_malloc_yield_percentage
;
301 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
303 "Return an association list of statistics about Guile's current\n"
305 #define FUNC_NAME s_scm_gc_stats
308 SCM heap_segs
= SCM_EOL
;
309 unsigned long int local_scm_mtrigger
;
310 unsigned long int local_scm_mallocated
;
311 unsigned long int local_scm_heap_size
;
312 int local_scm_gc_cell_yield_percentage
;
313 int local_scm_gc_malloc_yield_percentage
;
314 unsigned long int local_scm_cells_allocated
;
315 unsigned long int local_scm_gc_time_taken
;
316 unsigned long int local_scm_gc_times
;
317 unsigned long int local_scm_gc_mark_time_taken
;
318 unsigned long int local_protected_obj_count
;
319 double local_scm_gc_cells_swept
;
320 double local_scm_gc_cells_marked
;
321 double local_scm_total_cells_allocated
;
323 unsigned long *bounds
= 0;
324 int table_size
= scm_i_heap_segment_table_size
;
325 SCM_CRITICAL_SECTION_START
;
328 temporarily store the numbers, so as not to cause GC.
331 bounds
= malloc (sizeof (unsigned long) * table_size
* 2);
334 for (i
= table_size
; i
--; )
336 bounds
[2*i
] = (unsigned long)scm_i_heap_segment_table
[i
]->bounds
[0];
337 bounds
[2*i
+1] = (unsigned long)scm_i_heap_segment_table
[i
]->bounds
[1];
341 /* Below, we cons to produce the resulting list. We want a snapshot of
342 * the heap situation before consing.
344 local_scm_mtrigger
= scm_mtrigger
;
345 local_scm_mallocated
= scm_mallocated
;
346 local_scm_heap_size
= SCM_HEAP_SIZE
;
348 local_scm_cells_allocated
= scm_cells_allocated
;
350 local_scm_gc_time_taken
= scm_gc_time_taken
;
351 local_scm_gc_mark_time_taken
= scm_gc_mark_time_taken
;
352 local_scm_gc_times
= scm_gc_times
;
353 local_scm_gc_malloc_yield_percentage
= scm_gc_malloc_yield_percentage
;
354 local_scm_gc_cell_yield_percentage
= scm_gc_cell_yield_percentage
;
355 local_protected_obj_count
= protected_obj_count
;
356 local_scm_gc_cells_swept
=
357 (double) scm_gc_cells_swept_acc
358 + (double) scm_i_gc_sweep_stats
.swept
;
359 local_scm_gc_cells_marked
= scm_gc_cells_marked_acc
360 +(double) scm_i_gc_sweep_stats
.swept
361 -(double) scm_i_gc_sweep_stats
.collected
;
363 local_scm_total_cells_allocated
= scm_gc_cells_allocated_acc
364 + (double) (scm_cells_allocated
- scm_last_cells_allocated
);
366 for (i
= table_size
; i
--;)
368 heap_segs
= scm_cons (scm_cons (scm_from_ulong (bounds
[2*i
]),
369 scm_from_ulong (bounds
[2*i
+1])),
372 /* njrev: can any of these scm_cons's or scm_list_n signal a memory
373 error? If so we need a frame here. */
375 scm_list_n (scm_cons (sym_gc_time_taken
,
376 scm_from_ulong (local_scm_gc_time_taken
)),
377 scm_cons (sym_cells_allocated
,
378 scm_from_ulong (local_scm_cells_allocated
)),
379 scm_cons (sym_total_cells_allocated
,
380 scm_from_double (local_scm_total_cells_allocated
)),
381 scm_cons (sym_heap_size
,
382 scm_from_ulong (local_scm_heap_size
)),
383 scm_cons (sym_mallocated
,
384 scm_from_ulong (local_scm_mallocated
)),
385 scm_cons (sym_mtrigger
,
386 scm_from_ulong (local_scm_mtrigger
)),
388 scm_from_ulong (local_scm_gc_times
)),
389 scm_cons (sym_gc_mark_time_taken
,
390 scm_from_ulong (local_scm_gc_mark_time_taken
)),
391 scm_cons (sym_cells_marked
,
392 scm_from_double (local_scm_gc_cells_marked
)),
393 scm_cons (sym_cells_swept
,
394 scm_from_double (local_scm_gc_cells_swept
)),
395 scm_cons (sym_malloc_yield
,
396 scm_from_long(local_scm_gc_malloc_yield_percentage
)),
397 scm_cons (sym_cell_yield
,
398 scm_from_long (local_scm_gc_cell_yield_percentage
)),
399 scm_cons (sym_protected_objects
,
400 scm_from_ulong (local_protected_obj_count
)),
401 scm_cons (sym_heap_segments
, heap_segs
),
404 SCM_CRITICAL_SECTION_END
;
411 /* Update the global sweeping/collection statistics by adding SWEEP_STATS to
412 SCM_I_GC_SWEEP_STATS and updating related variables. */
414 gc_update_stats (scm_t_sweep_statistics sweep_stats
)
416 /* CELLS SWEPT is another word for the number of cells that were examined
417 during GC. YIELD is the number that we cleaned out. MARKED is the number
418 that weren't cleaned. */
420 scm_gc_cell_yield_percentage
= (sweep_stats
.collected
* 100) / SCM_HEAP_SIZE
;
422 scm_i_sweep_statistics_sum (&scm_i_gc_sweep_stats
, sweep_stats
);
424 if ((scm_i_gc_sweep_stats
.collected
> scm_i_gc_sweep_stats
.swept
)
425 || (scm_cells_allocated
< sweep_stats
.collected
))
427 printf ("internal GC error, please report to `"
428 PACKAGE_BUGREPORT
"'\n");
432 scm_gc_cells_allocated_acc
+=
433 (double) (scm_cells_allocated
- scm_last_cells_allocated
);
435 scm_cells_allocated
-= sweep_stats
.collected
;
436 scm_last_cells_allocated
= scm_cells_allocated
;
440 gc_start_stats (const char *what SCM_UNUSED
)
442 t_before_gc
= scm_c_get_internal_run_time ();
444 scm_gc_malloc_collected
= 0;
448 gc_end_stats (scm_t_sweep_statistics sweep_stats
)
450 unsigned long t
= scm_c_get_internal_run_time ();
452 scm_gc_time_taken
+= (t
- t_before_gc
);
454 /* Reset the number of cells swept/collected since the last full GC. */
455 scm_i_gc_sweep_stats_1
= scm_i_gc_sweep_stats
;
456 scm_i_gc_sweep_stats
.collected
= scm_i_gc_sweep_stats
.swept
= 0;
458 gc_update_stats (sweep_stats
);
460 scm_gc_cells_marked_acc
+= (double) scm_i_gc_sweep_stats
.swept
461 - (double) scm_i_gc_sweep_stats
.collected
;
462 scm_gc_cells_swept_acc
+= (double) scm_i_gc_sweep_stats
.swept
;
468 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
470 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
471 "returned by this function for @var{obj}")
472 #define FUNC_NAME s_scm_object_address
474 return scm_from_ulong (SCM_UNPACK (obj
));
479 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
481 "Scans all of SCM objects and reclaims for further use those that are\n"
482 "no longer accessible.")
483 #define FUNC_NAME s_scm_gc
485 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
486 scm_gc_running_p
= 1;
488 /* njrev: It looks as though other places, e.g. scm_realloc,
489 can call scm_i_gc without acquiring the sweep mutex. Does this
490 matter? Also scm_i_gc (or its descendants) touch the
491 scm_sys_protects, which are protected in some cases
492 (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
493 not by the sweep mutex. Shouldn't all the GC-relevant objects be
494 protected in the same way? */
495 scm_gc_running_p
= 0;
496 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
497 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
498 return SCM_UNSPECIFIED
;
505 /* The master is global and common while the freelist will be
506 * individual for each thread.
510 scm_gc_for_newcell (scm_t_cell_type_statistics
*freelist
, SCM
*free_cells
)
514 scm_t_sweep_statistics sweep_stats
;
516 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
517 scm_gc_running_p
= 1;
519 *free_cells
= scm_i_sweep_some_segments (freelist
, &sweep_stats
);
520 gc_update_stats (sweep_stats
);
522 if (*free_cells
== SCM_EOL
&& scm_i_gc_grow_heap_p (freelist
))
524 freelist
->heap_segment_idx
=
525 scm_i_get_new_heap_segment (freelist
,
526 scm_i_gc_sweep_stats
,
529 *free_cells
= scm_i_sweep_some_segments (freelist
, &sweep_stats
);
530 gc_update_stats (sweep_stats
);
533 if (*free_cells
== SCM_EOL
)
536 with the advent of lazy sweep, GC yield is only known just
539 scm_i_adjust_min_yield (freelist
,
540 scm_i_gc_sweep_stats
,
541 scm_i_gc_sweep_stats_1
);
544 out of fresh cells. Try to get some new ones.
550 *free_cells
= scm_i_sweep_some_segments (freelist
, &sweep_stats
);
551 gc_update_stats (sweep_stats
);
554 if (*free_cells
== SCM_EOL
)
557 failed getting new cells. Get new juice or die.
559 freelist
->heap_segment_idx
=
560 scm_i_get_new_heap_segment (freelist
,
561 scm_i_gc_sweep_stats
,
564 *free_cells
= scm_i_sweep_some_segments (freelist
, &sweep_stats
);
565 gc_update_stats (sweep_stats
);
568 if (*free_cells
== SCM_EOL
)
573 *free_cells
= SCM_FREE_CELL_CDR (cell
);
575 scm_gc_running_p
= 0;
576 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
579 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
585 scm_t_c_hook scm_before_gc_c_hook
;
586 scm_t_c_hook scm_before_mark_c_hook
;
587 scm_t_c_hook scm_before_sweep_c_hook
;
588 scm_t_c_hook scm_after_sweep_c_hook
;
589 scm_t_c_hook scm_after_gc_c_hook
;
591 /* Must be called while holding scm_i_sweep_mutex.
595 scm_i_gc (const char *what
)
597 scm_t_sweep_statistics sweep_stats
;
599 scm_i_thread_put_to_sleep ();
601 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
604 fprintf (stderr
,"gc reason %s\n", what
);
607 scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist
))
609 : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2
)) ? "o" : "m"));
612 gc_start_stats (what
);
615 Set freelists to NULL so scm_cons() always triggers gc, causing
616 the assertion above to fail.
618 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
619 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
622 Let's finish the sweep. The conservative GC might point into the
623 garbage, and marking that would create a mess.
625 scm_i_sweep_all_segments ("GC", &sweep_stats
);
627 /* Invariant: the number of cells collected (i.e., freed) must always be
628 lower than or equal to the number of cells "swept" (i.e., visited). */
629 assert (sweep_stats
.collected
<= sweep_stats
.swept
);
631 if (scm_mallocated
< scm_i_deprecated_memory_return
)
633 /* The byte count of allocated objects has underflowed. This is
634 probably because you forgot to report the sizes of objects you
635 have allocated, by calling scm_done_malloc or some such. When
636 the GC freed them, it subtracted their size from
637 scm_mallocated, which underflowed. */
639 "scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
640 "This is probably because the GC hasn't been correctly informed\n"
641 "about object sizes\n");
644 scm_mallocated
-= scm_i_deprecated_memory_return
;
649 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
651 scm_gc_mark_time_taken
+= (scm_c_get_internal_run_time () - t_before_gc
);
655 TODO: the after_sweep hook should probably be moved to just before
656 the mark, since that's where the sweep is finished in lazy
659 MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
660 original meaning implied at least two things: that it would be
663 1. the freelist is re-initialized (no evaluation possible, though)
667 2. the heap is "fresh"
668 (it is well-defined what data is used and what is not)
670 Neither of these conditions would hold just before the mark phase.
672 Of course, the lazy sweeping has muddled the distinction between
673 scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
674 there were no difference, it would still be useful to have two
675 distinct classes of hook functions since this can prevent some
676 bad interference when several modules adds gc hooks.
679 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
681 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
683 gc_end_stats (sweep_stats
);
685 scm_i_thread_wake_up ();
688 For debugging purposes, you could do
689 scm_i_sweep_all_segments("debug"), but then the remains of the
690 cell aren't left to analyse.
696 /* {GC Protection Helper Functions}
701 * If within a function you need to protect one or more scheme objects from
702 * garbage collection, pass them as parameters to one of the
703 * scm_remember_upto_here* functions below. These functions don't do
704 * anything, but since the compiler does not know that they are actually
705 * no-ops, it will generate code that calls these functions with the given
706 * parameters. Therefore, you can be sure that the compiler will keep those
707 * scheme values alive (on the stack or in a register) up to the point where
708 * scm_remember_upto_here* is called. In other words, place the call to
709 * scm_remember_upto_here* _behind_ the last code in your function, that
710 * depends on the scheme object to exist.
712 * Example: We want to make sure that the string object str does not get
713 * garbage collected during the execution of 'some_function' in the code
714 * below, because otherwise the characters belonging to str would be freed and
715 * 'some_function' might access freed memory. To make sure that the compiler
716 * keeps str alive on the stack or in a register such that it is visible to
717 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
718 * call to 'some_function'. Note that this would not be necessary if str was
719 * used anyway after the call to 'some_function'.
720 * char *chars = scm_i_string_chars (str);
721 * some_function (chars);
722 * scm_remember_upto_here_1 (str); // str will be alive up to this point.
725 /* Remove any macro versions of these while defining the functions.
726 Functions are always included in the library, for upward binary
727 compatibility and in case combinations of GCC and non-GCC are used. */
728 #undef scm_remember_upto_here_1
729 #undef scm_remember_upto_here_2
732 scm_remember_upto_here_1 (SCM obj SCM_UNUSED
)
734 /* Empty. Protects a single object from garbage collection. */
738 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED
, SCM obj2 SCM_UNUSED
)
740 /* Empty. Protects two objects from garbage collection. */
744 scm_remember_upto_here (SCM obj SCM_UNUSED
, ...)
746 /* Empty. Protects any number of objects from garbage collection. */
750 These crazy functions prevent garbage collection
751 of arguments after the first argument by
752 ensuring they remain live throughout the
753 function because they are used in the last
754 line of the code block.
755 It'd be better to have a nice compiler hint to
756 aid the conservative stack-scanning GC. --03/09/00 gjb */
758 scm_return_first (SCM elt
, ...)
764 scm_return_first_int (int i
, ...)
771 scm_permanent_object (SCM obj
)
773 SCM cell
= scm_cons (obj
, SCM_EOL
);
774 SCM_CRITICAL_SECTION_START
;
775 SCM_SETCDR (cell
, scm_permobjs
);
777 SCM_CRITICAL_SECTION_END
;
782 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
783 other references are dropped, until the object is unprotected by calling
784 scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
785 i. e. it is possible to protect the same object several times, but it is
786 necessary to unprotect the object the same number of times to actually get
787 the object unprotected. It is an error to unprotect an object more often
788 than it has been protected before. The function scm_protect_object returns
792 /* Implementation note: For every object X, there is a counter which
793 scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
799 scm_gc_protect_object (SCM obj
)
803 /* This critical section barrier will be replaced by a mutex. */
804 /* njrev: Indeed; if my comment above is correct, there is the same
805 critsec/mutex inconsistency here. */
806 SCM_CRITICAL_SECTION_START
;
808 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, scm_from_int (0));
809 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), scm_from_int (1)));
811 protected_obj_count
++;
813 SCM_CRITICAL_SECTION_END
;
819 /* Remove any protection for OBJ established by a prior call to
820 scm_protect_object. This function returns OBJ.
822 See scm_protect_object for more information. */
824 scm_gc_unprotect_object (SCM obj
)
828 /* This critical section barrier will be replaced by a mutex. */
829 /* njrev: and again. */
830 SCM_CRITICAL_SECTION_START
;
832 if (scm_gc_running_p
)
834 fprintf (stderr
, "scm_unprotect_object called during GC.\n");
838 handle
= scm_hashq_get_handle (scm_protects
, obj
);
840 if (scm_is_false (handle
))
842 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
847 SCM count
= scm_difference (SCM_CDR (handle
), scm_from_int (1));
848 if (scm_is_eq (count
, scm_from_int (0)))
849 scm_hashq_remove_x (scm_protects
, obj
);
851 SCM_SETCDR (handle
, count
);
853 protected_obj_count
--;
855 SCM_CRITICAL_SECTION_END
;
861 scm_gc_register_root (SCM
*p
)
864 SCM key
= scm_from_ulong ((unsigned long) p
);
866 /* This critical section barrier will be replaced by a mutex. */
867 /* njrev: and again. */
868 SCM_CRITICAL_SECTION_START
;
870 handle
= scm_hashv_create_handle_x (scm_gc_registered_roots
, key
,
872 /* njrev: note also that the above can probably signal an error */
873 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), scm_from_int (1)));
875 SCM_CRITICAL_SECTION_END
;
879 scm_gc_unregister_root (SCM
*p
)
882 SCM key
= scm_from_ulong ((unsigned long) p
);
884 /* This critical section barrier will be replaced by a mutex. */
885 /* njrev: and again. */
886 SCM_CRITICAL_SECTION_START
;
888 handle
= scm_hashv_get_handle (scm_gc_registered_roots
, key
);
890 if (scm_is_false (handle
))
892 fprintf (stderr
, "scm_gc_unregister_root called on unregistered root\n");
897 SCM count
= scm_difference (SCM_CDR (handle
), scm_from_int (1));
898 if (scm_is_eq (count
, scm_from_int (0)))
899 scm_hashv_remove_x (scm_gc_registered_roots
, key
);
901 SCM_SETCDR (handle
, count
);
904 SCM_CRITICAL_SECTION_END
;
908 scm_gc_register_roots (SCM
*b
, unsigned long n
)
911 for (; p
< b
+ n
; ++p
)
912 scm_gc_register_root (p
);
916 scm_gc_unregister_roots (SCM
*b
, unsigned long n
)
919 for (; p
< b
+ n
; ++p
)
920 scm_gc_unregister_root (p
);
923 int scm_i_terminating
;
929 MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
932 /* Get an integer from an environment variable. */
934 scm_getenv_int (const char *var
, int def
)
937 char *val
= getenv (var
);
941 res
= strtol (val
, &end
, 10);
948 scm_storage_prehistory ()
950 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
951 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
952 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
953 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
954 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
957 scm_i_pthread_mutex_t scm_i_gc_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
964 j
= SCM_NUM_PROTECTS
;
966 scm_sys_protects
[--j
] = SCM_BOOL_F
;
968 scm_gc_init_freelist();
969 scm_gc_init_malloc ();
971 j
= SCM_HEAP_SEG_SIZE
;
974 /* We can't have a cleanup handler since we have no thread to run it
981 on_exit (cleanup
, 0);
987 scm_stand_in_procs
= scm_make_weak_key_hash_table (scm_from_int (257));
988 scm_permobjs
= SCM_EOL
;
989 scm_protects
= scm_c_make_hash_table (31);
990 scm_gc_registered_roots
= scm_c_make_hash_table (31);
997 SCM scm_after_gc_hook
;
1001 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
1002 * is run after the gc, as soon as the asynchronous events are handled by the
1006 gc_async_thunk (void)
1008 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
1009 return SCM_UNSPECIFIED
;
1013 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
1014 * the garbage collection. The only purpose of this function is to mark the
1015 * gc_async (which will eventually lead to the execution of the
1019 mark_gc_async (void * hook_data SCM_UNUSED
,
1020 void *fn_data SCM_UNUSED
,
1021 void *data SCM_UNUSED
)
1023 /* If cell access debugging is enabled, the user may choose to perform
1024 * additional garbage collections after an arbitrary number of cell
1025 * accesses. We don't want the scheme level after-gc-hook to be performed
1026 * for each of these garbage collections for the following reason: The
1027 * execution of the after-gc-hook causes cell accesses itself. Thus, if the
1028 * after-gc-hook was performed with every gc, and if the gc was performed
1029 * after a very small number of cell accesses, then the number of cell
1030 * accesses during the execution of the after-gc-hook will suffice to cause
1031 * the execution of the next gc. Then, guile would keep executing the
1032 * after-gc-hook over and over again, and would never come to do other
1035 * To overcome this problem, if cell access debugging with additional
1036 * garbage collections is enabled, the after-gc-hook is never run by the
1037 * garbage collecter. When running guile with cell access debugging and the
1038 * execution of the after-gc-hook is desired, then it is necessary to run
1039 * the hook explicitly from the user code. This has the effect, that from
1040 * the scheme level point of view it seems that garbage collection is
1041 * performed with a much lower frequency than it actually is. Obviously,
1042 * this will not work for code that depends on a fixed one to one
1043 * relationship between the execution counts of the C level garbage
1044 * collection hooks and the execution count of the scheme level
1048 #if (SCM_DEBUG_CELL_ACCESSES == 1)
1049 if (scm_debug_cells_gc_interval
== 0)
1050 scm_system_async_mark (gc_async
);
1052 scm_system_async_mark (gc_async
);
1061 scm_gc_init_mark ();
1063 scm_after_gc_hook
= scm_permanent_object (scm_make_hook (SCM_INUM0
));
1064 scm_c_define ("after-gc-hook", scm_after_gc_hook
);
1066 gc_async
= scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0
,
1069 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
1071 #include "libguile/gc.x"
1076 # include <sys/param.h>
1077 # include <sys/pstat.h>
1079 scm_ia64_register_backing_store_base (void)
1081 struct pst_vm_status vm_status
;
1083 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
1084 if (vm_status
.pst_type
== PS_RSESTACK
)
1085 return (void *) vm_status
.pst_vaddr
;
1089 scm_ia64_ar_bsp (const void *ctx
)
1092 __uc_get_ar_bsp(ctx
, &bsp
);
1093 return (void *) bsp
;
1097 # include <ucontext.h>
1099 scm_ia64_register_backing_store_base (void)
1101 extern void *__libc_ia64_register_backing_store_base
;
1102 return __libc_ia64_register_backing_store_base
;
1105 scm_ia64_ar_bsp (const void *opaque
)
1107 const ucontext_t
*ctx
= opaque
;
1108 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
1111 #endif /* __ia64__ */
1115 #define FUNC_NAME "scm_gc_sweep"
1117 scm_i_deprecated_memory_return
= 0;
1119 scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist
);
1120 scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2
);
1123 NOTHING HERE: LAZY SWEEPING !
1125 scm_i_reset_segments ();
1127 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
1128 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
1130 /* Invalidate the freelists of other threads. */
1131 scm_i_thread_invalidate_freelists ();