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
18 /* #define DEBUGINFO */
29 #include "libguile/_scm.h"
30 #include "libguile/eval.h"
31 #include "libguile/stime.h"
32 #include "libguile/stackchk.h"
33 #include "libguile/struct.h"
34 #include "libguile/smob.h"
35 #include "libguile/unif.h"
36 #include "libguile/async.h"
37 #include "libguile/ports.h"
38 #include "libguile/root.h"
39 #include "libguile/strings.h"
40 #include "libguile/vectors.h"
41 #include "libguile/weaks.h"
42 #include "libguile/hashtab.h"
43 #include "libguile/tags.h"
45 #include "libguile/private-gc.h"
46 #include "libguile/validate.h"
47 #include "libguile/deprecation.h"
48 #include "libguile/gc.h"
49 #include "libguile/dynwind.h"
51 #ifdef GUILE_DEBUG_MALLOC
52 #include "libguile/debug-malloc.h"
63 /* Lock this mutex before doing lazy sweeping.
65 scm_i_pthread_mutex_t scm_i_sweep_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
67 /* Set this to != 0 if every cell that is accessed shall be checked:
69 int scm_debug_cell_accesses_p
= 0;
70 int scm_expensive_debug_cell_accesses_p
= 0;
72 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
73 * the number of cell accesses after which a gc shall be called.
75 int scm_debug_cells_gc_interval
= 0;
78 Global variable, so you can switch it off at runtime by setting
79 scm_i_cell_validation_already_running.
81 int scm_i_cell_validation_already_running
;
83 #if (SCM_DEBUG_CELL_ACCESSES == 1)
88 Assert that the given object is a valid reference to a valid cell. This
89 test involves to determine whether the object is a cell pointer, whether
90 this pointer actually points into a heap segment and whether the cell
91 pointed to is not a free cell. Further, additional garbage collections may
92 get executed after a user defined number of cell accesses. This helps to
93 find places in the C code where references are dropped for extremely short
98 scm_i_expensive_validation_check (SCM cell
)
100 if (!scm_in_heap_p (cell
))
102 fprintf (stderr
, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
103 (unsigned long) SCM_UNPACK (cell
));
107 /* If desired, perform additional garbage collections after a user
108 * defined number of cell accesses.
110 if (scm_debug_cells_gc_interval
)
112 static unsigned int counter
= 0;
120 counter
= scm_debug_cells_gc_interval
;
127 scm_assert_cell_valid (SCM cell
)
129 if (!scm_i_cell_validation_already_running
&& scm_debug_cell_accesses_p
)
131 scm_i_cell_validation_already_running
= 1; /* set to avoid recursion */
134 During GC, no user-code should be run, and the guile core
135 should use non-protected accessors.
137 if (scm_gc_running_p
)
141 Only scm_in_heap_p and rescanning the heap is wildly
144 if (scm_expensive_debug_cell_accesses_p
)
145 scm_i_expensive_validation_check (cell
);
147 if (!SCM_GC_MARK_P (cell
))
150 "scm_assert_cell_valid: this object is unmarked. \n"
151 "It has been garbage-collected in the last GC run: "
153 (unsigned long) SCM_UNPACK (cell
));
157 scm_i_cell_validation_already_running
= 0; /* re-enable */
163 SCM_DEFINE (scm_set_debug_cell_accesses_x
, "set-debug-cell-accesses!", 1, 0, 0,
165 "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
166 "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
167 "but no additional calls to garbage collection are issued.\n"
168 "If @var{flag} is a number, strict cell access checking is enabled,\n"
169 "with an additional garbage collection after the given\n"
170 "number of cell accesses.\n"
171 "This procedure only exists when the compile-time flag\n"
172 "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
173 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
175 if (scm_is_false (flag
))
177 scm_debug_cell_accesses_p
= 0;
179 else if (scm_is_eq (flag
, SCM_BOOL_T
))
181 scm_debug_cells_gc_interval
= 0;
182 scm_debug_cell_accesses_p
= 1;
183 scm_expensive_debug_cell_accesses_p
= 0;
187 scm_debug_cells_gc_interval
= scm_to_signed_integer (flag
, 0, INT_MAX
);
188 scm_debug_cell_accesses_p
= 1;
189 scm_expensive_debug_cell_accesses_p
= 1;
191 return SCM_UNSPECIFIED
;
196 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
202 * is the number of bytes of malloc allocation needed to trigger gc.
204 unsigned long scm_mtrigger
;
206 /* GC Statistics Keeping
208 unsigned long scm_cells_allocated
= 0;
209 unsigned long scm_last_cells_allocated
= 0;
210 unsigned long scm_mallocated
= 0;
211 long int scm_i_find_heap_calls
= 0;
212 /* Global GC sweep statistics since the last full GC. */
213 scm_t_sweep_statistics scm_i_gc_sweep_stats
= { 0, 0 };
215 /* Total count of cells marked/swept. */
216 static double scm_gc_cells_marked_acc
= 0.;
217 static double scm_gc_cells_marked_conservatively_acc
= 0.;
218 static double scm_gc_cells_swept_acc
= 0.;
219 static double scm_gc_cells_allocated_acc
= 0.;
221 static unsigned long scm_gc_time_taken
= 0;
222 static unsigned long scm_gc_mark_time_taken
= 0;
224 static unsigned long scm_gc_times
= 0;
226 static int scm_gc_cell_yield_percentage
= 0;
227 static unsigned long protected_obj_count
= 0;
229 /* The following are accessed from `gc-malloc.c' and `gc-card.c'. */
230 int scm_gc_malloc_yield_percentage
= 0;
231 unsigned long scm_gc_malloc_collected
= 0;
234 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
235 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
236 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
237 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
238 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
239 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
240 SCM_SYMBOL (sym_gc_mark_time_taken
, "gc-mark-time-taken");
241 SCM_SYMBOL (sym_times
, "gc-times");
242 SCM_SYMBOL (sym_cells_marked
, "cells-marked");
243 SCM_SYMBOL (sym_cells_marked_conservatively
, "cells-marked-conservatively");
244 SCM_SYMBOL (sym_cells_swept
, "cells-swept");
245 SCM_SYMBOL (sym_malloc_yield
, "malloc-yield");
246 SCM_SYMBOL (sym_cell_yield
, "cell-yield");
247 SCM_SYMBOL (sym_protected_objects
, "protected-objects");
248 SCM_SYMBOL (sym_total_cells_allocated
, "total-cells-allocated");
251 /* Number of calls to SCM_NEWCELL since startup. */
252 unsigned scm_newcell_count
;
253 unsigned scm_newcell2_count
;
256 /* {Scheme Interface to GC}
259 tag_table_to_type_alist (void *closure
, SCM key
, SCM val
, SCM acc
)
261 if (scm_is_integer (key
))
263 int c_tag
= scm_to_int (key
);
265 char const * name
= scm_i_tag_name (c_tag
);
268 key
= scm_from_locale_string (name
);
273 sprintf (s
, "tag %d", c_tag
);
274 key
= scm_from_locale_string (s
);
278 return scm_cons (scm_cons (key
, val
), acc
);
281 SCM_DEFINE (scm_gc_live_object_stats
, "gc-live-object-stats", 0, 0, 0,
283 "Return an alist of statistics of the current live objects. ")
284 #define FUNC_NAME s_scm_gc_live_object_stats
286 SCM tab
= scm_make_hash_table (scm_from_int (57));
289 scm_i_all_segments_statistics (tab
);
292 = scm_internal_hash_fold (&tag_table_to_type_alist
, NULL
, SCM_EOL
, tab
);
298 extern int scm_gc_malloc_yield_percentage
;
299 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
301 "Return an association list of statistics about Guile's current\n"
303 #define FUNC_NAME s_scm_gc_stats
306 SCM heap_segs
= SCM_EOL
;
307 unsigned long int local_scm_mtrigger
;
308 unsigned long int local_scm_mallocated
;
309 unsigned long int local_scm_heap_size
;
310 int local_scm_gc_cell_yield_percentage
;
311 int local_scm_gc_malloc_yield_percentage
;
312 unsigned long int local_scm_cells_allocated
;
313 unsigned long int local_scm_gc_time_taken
;
314 unsigned long int local_scm_gc_times
;
315 unsigned long int local_scm_gc_mark_time_taken
;
316 unsigned long int local_protected_obj_count
;
317 double local_scm_gc_cells_swept
;
318 double local_scm_gc_cells_marked
;
319 double local_scm_gc_cells_marked_conservatively
;
320 double local_scm_total_cells_allocated
;
322 unsigned long *bounds
= 0;
324 SCM_CRITICAL_SECTION_START
;
326 bounds
= scm_i_segment_table_info (&table_size
);
328 /* Below, we cons to produce the resulting list. We want a snapshot of
329 * the heap situation before consing.
331 local_scm_mtrigger
= scm_mtrigger
;
332 local_scm_mallocated
= scm_mallocated
;
333 local_scm_heap_size
=
334 (scm_i_master_freelist
.heap_total_cells
+ scm_i_master_freelist2
.heap_total_cells
);
336 local_scm_cells_allocated
=
337 scm_cells_allocated
+ scm_i_gc_sweep_stats
.collected
;
339 local_scm_gc_time_taken
= scm_gc_time_taken
;
340 local_scm_gc_mark_time_taken
= scm_gc_mark_time_taken
;
341 local_scm_gc_times
= scm_gc_times
;
342 local_scm_gc_malloc_yield_percentage
= scm_gc_malloc_yield_percentage
;
343 local_scm_gc_cell_yield_percentage
= scm_gc_cell_yield_percentage
;
344 local_protected_obj_count
= protected_obj_count
;
345 local_scm_gc_cells_swept
=
346 (double) scm_gc_cells_swept_acc
347 + (double) scm_i_gc_sweep_stats
.swept
;
348 local_scm_gc_cells_marked
= scm_gc_cells_marked_acc
349 + (double) scm_i_gc_sweep_stats
.swept
350 - (double) scm_i_gc_sweep_stats
.collected
;
351 local_scm_gc_cells_marked_conservatively
352 = scm_gc_cells_marked_conservatively_acc
;
354 local_scm_total_cells_allocated
= scm_gc_cells_allocated_acc
355 + (double) scm_i_gc_sweep_stats
.collected
;
357 for (i
= table_size
; i
--;)
359 heap_segs
= scm_cons (scm_cons (scm_from_ulong (bounds
[2*i
]),
360 scm_from_ulong (bounds
[2*i
+1])),
364 /* njrev: can any of these scm_cons's or scm_list_n signal a memory
365 error? If so we need a frame here. */
367 scm_list_n (scm_cons (sym_gc_time_taken
,
368 scm_from_ulong (local_scm_gc_time_taken
)),
369 scm_cons (sym_cells_allocated
,
370 scm_from_ulong (local_scm_cells_allocated
)),
371 scm_cons (sym_total_cells_allocated
,
372 scm_from_double (local_scm_total_cells_allocated
)),
373 scm_cons (sym_heap_size
,
374 scm_from_ulong (local_scm_heap_size
)),
375 scm_cons (sym_cells_marked_conservatively
,
376 scm_from_ulong (local_scm_gc_cells_marked_conservatively
)),
377 scm_cons (sym_mallocated
,
378 scm_from_ulong (local_scm_mallocated
)),
379 scm_cons (sym_mtrigger
,
380 scm_from_ulong (local_scm_mtrigger
)),
382 scm_from_ulong (local_scm_gc_times
)),
383 scm_cons (sym_gc_mark_time_taken
,
384 scm_from_ulong (local_scm_gc_mark_time_taken
)),
385 scm_cons (sym_cells_marked
,
386 scm_from_double (local_scm_gc_cells_marked
)),
387 scm_cons (sym_cells_swept
,
388 scm_from_double (local_scm_gc_cells_swept
)),
389 scm_cons (sym_malloc_yield
,
390 scm_from_long (local_scm_gc_malloc_yield_percentage
)),
391 scm_cons (sym_cell_yield
,
392 scm_from_long (local_scm_gc_cell_yield_percentage
)),
393 scm_cons (sym_protected_objects
,
394 scm_from_ulong (local_protected_obj_count
)),
395 scm_cons (sym_heap_segments
, heap_segs
),
397 SCM_CRITICAL_SECTION_END
;
405 Update nice-to-know-statistics.
410 /* CELLS SWEPT is another word for the number of cells that were examined
411 during GC. YIELD is the number that we cleaned out. MARKED is the number
412 that weren't cleaned. */
413 scm_gc_cell_yield_percentage
= (scm_i_gc_sweep_stats
.collected
* 100) /
414 (scm_i_master_freelist
.heap_total_cells
+ scm_i_master_freelist2
.heap_total_cells
);
416 scm_gc_cells_allocated_acc
+=
417 (double) scm_i_gc_sweep_stats
.collected
;
418 scm_gc_cells_marked_acc
+= (double) scm_cells_allocated
;
419 scm_gc_cells_marked_conservatively_acc
+= (double) scm_i_find_heap_calls
;
420 scm_gc_cells_swept_acc
+= (double) scm_i_gc_sweep_stats
.swept
;
425 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
427 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
428 "returned by this function for @var{obj}")
429 #define FUNC_NAME s_scm_object_address
431 return scm_from_ulong (SCM_UNPACK (obj
));
436 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
438 "Scans all of SCM objects and reclaims for further use those that are\n"
439 "no longer accessible.")
440 #define FUNC_NAME s_scm_gc
442 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
443 scm_gc_running_p
= 1;
445 /* njrev: It looks as though other places, e.g. scm_realloc,
446 can call scm_i_gc without acquiring the sweep mutex. Does this
447 matter? Also scm_i_gc (or its descendants) touch the
448 scm_sys_protects, which are protected in some cases
449 (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
450 not by the sweep mutex. Shouldn't all the GC-relevant objects be
451 protected in the same way? */
452 scm_gc_running_p
= 0;
453 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
454 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
455 return SCM_UNSPECIFIED
;
462 /* The master is global and common while the freelist will be
463 * individual for each thread.
467 scm_gc_for_newcell (scm_t_cell_type_statistics
*freelist
, SCM
*free_cells
)
472 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
473 scm_gc_running_p
= 1;
475 *free_cells
= scm_i_sweep_for_freelist (freelist
);
476 if (*free_cells
== SCM_EOL
)
478 float delta
= scm_i_gc_heap_size_delta (freelist
);
481 size_t bytes
= ((unsigned long) delta
) * sizeof (scm_t_cell
);
482 freelist
->heap_segment_idx
=
483 scm_i_get_new_heap_segment (freelist
, bytes
, abort_on_error
);
485 *free_cells
= scm_i_sweep_for_freelist (freelist
);
489 if (*free_cells
== SCM_EOL
)
492 out of fresh cells. Try to get some new ones.
494 char reason
[] = "0-cells";
495 reason
[0] += freelist
->span
;
500 *free_cells
= scm_i_sweep_for_freelist (freelist
);
503 if (*free_cells
== SCM_EOL
)
506 failed getting new cells. Get new juice or die.
508 float delta
= scm_i_gc_heap_size_delta (freelist
);
509 assert (delta
> 0.0);
510 size_t bytes
= ((unsigned long) delta
) * sizeof (scm_t_cell
);
511 freelist
->heap_segment_idx
=
512 scm_i_get_new_heap_segment (freelist
, bytes
, abort_on_error
);
514 *free_cells
= scm_i_sweep_for_freelist (freelist
);
517 if (*free_cells
== SCM_EOL
)
522 *free_cells
= SCM_FREE_CELL_CDR (cell
);
524 scm_gc_running_p
= 0;
525 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
528 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
534 scm_t_c_hook scm_before_gc_c_hook
;
535 scm_t_c_hook scm_before_mark_c_hook
;
536 scm_t_c_hook scm_before_sweep_c_hook
;
537 scm_t_c_hook scm_after_sweep_c_hook
;
538 scm_t_c_hook scm_after_gc_c_hook
;
541 scm_check_deprecated_memory_return ()
543 if (scm_mallocated
< scm_i_deprecated_memory_return
)
545 /* The byte count of allocated objects has underflowed. This is
546 probably because you forgot to report the sizes of objects you
547 have allocated, by calling scm_done_malloc or some such. When
548 the GC freed them, it subtracted their size from
549 scm_mallocated, which underflowed. */
551 "scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
552 "This is probably because the GC hasn't been correctly informed\n"
553 "about object sizes\n");
556 scm_mallocated
-= scm_i_deprecated_memory_return
;
557 scm_i_deprecated_memory_return
= 0;
560 /* Must be called while holding scm_i_sweep_mutex.
562 This function is fairly long, but it touches various global
563 variables. To not obscure the side effects on global variables,
564 this function has not been split up.
567 scm_i_gc (const char *what
)
569 unsigned long t_before_gc
= 0;
571 scm_i_thread_put_to_sleep ();
573 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
576 fprintf (stderr
,"gc reason %s\n", what
);
578 scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist
))
580 : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2
)) ? "o" : "m"));
583 t_before_gc
= scm_c_get_internal_run_time ();
584 scm_gc_malloc_collected
= 0;
587 Set freelists to NULL so scm_cons () always triggers gc, causing
588 the assertion above to fail.
590 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
591 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
594 Let's finish the sweep. The conservative GC might point into the
595 garbage, and marking that would create a mess.
597 scm_i_sweep_all_segments ("GC", &scm_i_gc_sweep_stats
);
598 scm_check_deprecated_memory_return ();
600 #if (SCM_DEBUG_CELL_ACCESSES == 0 && SCM_SIZEOF_UNSIGNED_LONG ==4)
601 /* Sanity check our numbers. */
602 /* TODO(hanwen): figure out why the stats are off on x64_64. */
603 /* If this was not true, someone touched mark bits outside of the
605 assert (scm_cells_allocated
== scm_i_marked_count ());
606 assert (scm_i_gc_sweep_stats
.swept
607 == (scm_i_master_freelist
.heap_total_cells
608 + scm_i_master_freelist2
.heap_total_cells
));
609 assert (scm_i_gc_sweep_stats
.collected
+ scm_cells_allocated
610 == scm_i_gc_sweep_stats
.swept
);
611 #endif /* SCM_DEBUG_CELL_ACCESSES */
614 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
617 scm_gc_mark_time_taken
+= (scm_c_get_internal_run_time () - t_before_gc
);
619 scm_cells_allocated
= scm_i_marked_count ();
623 TODO: the after_sweep hook should probably be moved to just before
624 the mark, since that's where the sweep is finished in lazy
627 MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
628 original meaning implied at least two things: that it would be
631 1. the freelist is re-initialized (no evaluation possible, though)
635 2. the heap is "fresh"
636 (it is well-defined what data is used and what is not)
638 Neither of these conditions would hold just before the mark phase.
640 Of course, the lazy sweeping has muddled the distinction between
641 scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
642 there were no difference, it would still be useful to have two
643 distinct classes of hook functions since this can prevent some
644 bad interference when several modules adds gc hooks.
646 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
649 Nothing here: lazy sweeping.
651 scm_i_reset_segments ();
653 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
654 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
656 /* Invalidate the freelists of other threads. */
657 scm_i_thread_invalidate_freelists ();
659 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
663 scm_i_gc_sweep_stats
.collected
= scm_i_gc_sweep_stats
.swept
= 0;
664 scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist
);
665 scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2
);
667 /* Arguably, this statistic is fairly useless: marking will dominate
670 scm_gc_time_taken
+= (scm_c_get_internal_run_time () - t_before_gc
);
672 scm_i_thread_wake_up ();
674 For debugging purposes, you could do
675 scm_i_sweep_all_segments ("debug"), but then the remains of the
676 cell aren't left to analyse.
682 /* {GC Protection Helper Functions}
687 * If within a function you need to protect one or more scheme objects from
688 * garbage collection, pass them as parameters to one of the
689 * scm_remember_upto_here* functions below. These functions don't do
690 * anything, but since the compiler does not know that they are actually
691 * no-ops, it will generate code that calls these functions with the given
692 * parameters. Therefore, you can be sure that the compiler will keep those
693 * scheme values alive (on the stack or in a register) up to the point where
694 * scm_remember_upto_here* is called. In other words, place the call to
695 * scm_remember_upto_here* _behind_ the last code in your function, that
696 * depends on the scheme object to exist.
698 * Example: We want to make sure that the string object str does not get
699 * garbage collected during the execution of 'some_function' in the code
700 * below, because otherwise the characters belonging to str would be freed and
701 * 'some_function' might access freed memory. To make sure that the compiler
702 * keeps str alive on the stack or in a register such that it is visible to
703 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
704 * call to 'some_function'. Note that this would not be necessary if str was
705 * used anyway after the call to 'some_function'.
706 * char *chars = scm_i_string_chars (str);
707 * some_function (chars);
708 * scm_remember_upto_here_1 (str); // str will be alive up to this point.
711 /* Remove any macro versions of these while defining the functions.
712 Functions are always included in the library, for upward binary
713 compatibility and in case combinations of GCC and non-GCC are used. */
714 #undef scm_remember_upto_here_1
715 #undef scm_remember_upto_here_2
718 scm_remember_upto_here_1 (SCM obj SCM_UNUSED
)
720 /* Empty. Protects a single object from garbage collection. */
724 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED
, SCM obj2 SCM_UNUSED
)
726 /* Empty. Protects two objects from garbage collection. */
730 scm_remember_upto_here (SCM obj SCM_UNUSED
, ...)
732 /* Empty. Protects any number of objects from garbage collection. */
736 These crazy functions prevent garbage collection
737 of arguments after the first argument by
738 ensuring they remain live throughout the
739 function because they are used in the last
740 line of the code block.
741 It'd be better to have a nice compiler hint to
742 aid the conservative stack-scanning GC. --03/09/00 gjb */
744 scm_return_first (SCM elt
, ...)
750 scm_return_first_int (int i
, ...)
757 scm_permanent_object (SCM obj
)
759 SCM cell
= scm_cons (obj
, SCM_EOL
);
760 SCM_CRITICAL_SECTION_START
;
761 SCM_SETCDR (cell
, scm_permobjs
);
763 SCM_CRITICAL_SECTION_END
;
768 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
769 other references are dropped, until the object is unprotected by calling
770 scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
771 i. e. it is possible to protect the same object several times, but it is
772 necessary to unprotect the object the same number of times to actually get
773 the object unprotected. It is an error to unprotect an object more often
774 than it has been protected before. The function scm_protect_object returns
778 /* Implementation note: For every object X, there is a counter which
779 scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
785 scm_gc_protect_object (SCM obj
)
789 /* This critical section barrier will be replaced by a mutex. */
790 /* njrev: Indeed; if my comment above is correct, there is the same
791 critsec/mutex inconsistency here. */
792 SCM_CRITICAL_SECTION_START
;
794 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, scm_from_int (0));
795 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), scm_from_int (1)));
797 protected_obj_count
++;
799 SCM_CRITICAL_SECTION_END
;
805 /* Remove any protection for OBJ established by a prior call to
806 scm_protect_object. This function returns OBJ.
808 See scm_protect_object for more information. */
810 scm_gc_unprotect_object (SCM obj
)
814 /* This critical section barrier will be replaced by a mutex. */
815 /* njrev: and again. */
816 SCM_CRITICAL_SECTION_START
;
818 if (scm_gc_running_p
)
820 fprintf (stderr
, "scm_unprotect_object called during GC.\n");
824 handle
= scm_hashq_get_handle (scm_protects
, obj
);
826 if (scm_is_false (handle
))
828 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
833 SCM count
= scm_difference (SCM_CDR (handle
), scm_from_int (1));
834 if (scm_is_eq (count
, scm_from_int (0)))
835 scm_hashq_remove_x (scm_protects
, obj
);
837 SCM_SETCDR (handle
, count
);
839 protected_obj_count
--;
841 SCM_CRITICAL_SECTION_END
;
847 scm_gc_register_root (SCM
*p
)
850 SCM key
= scm_from_ulong ((unsigned long) p
);
852 /* This critical section barrier will be replaced by a mutex. */
853 /* njrev: and again. */
854 SCM_CRITICAL_SECTION_START
;
856 handle
= scm_hashv_create_handle_x (scm_gc_registered_roots
, key
,
858 /* njrev: note also that the above can probably signal an error */
859 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), scm_from_int (1)));
861 SCM_CRITICAL_SECTION_END
;
865 scm_gc_unregister_root (SCM
*p
)
868 SCM key
= scm_from_ulong ((unsigned long) p
);
870 /* This critical section barrier will be replaced by a mutex. */
871 /* njrev: and again. */
872 SCM_CRITICAL_SECTION_START
;
874 handle
= scm_hashv_get_handle (scm_gc_registered_roots
, key
);
876 if (scm_is_false (handle
))
878 fprintf (stderr
, "scm_gc_unregister_root called on unregistered root\n");
883 SCM count
= scm_difference (SCM_CDR (handle
), scm_from_int (1));
884 if (scm_is_eq (count
, scm_from_int (0)))
885 scm_hashv_remove_x (scm_gc_registered_roots
, key
);
887 SCM_SETCDR (handle
, count
);
890 SCM_CRITICAL_SECTION_END
;
894 scm_gc_register_roots (SCM
*b
, unsigned long n
)
897 for (; p
< b
+ n
; ++p
)
898 scm_gc_register_root (p
);
902 scm_gc_unregister_roots (SCM
*b
, unsigned long n
)
905 for (; p
< b
+ n
; ++p
)
906 scm_gc_unregister_root (p
);
909 int scm_i_terminating
;
915 MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
918 /* Get an integer from an environment variable. */
920 scm_getenv_int (const char *var
, int def
)
923 char *val
= getenv (var
);
927 res
= strtol (val
, &end
, 10);
934 scm_storage_prehistory ()
936 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
937 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
938 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
939 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
940 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
943 scm_i_pthread_mutex_t scm_i_gc_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
950 j
= SCM_NUM_PROTECTS
;
952 scm_sys_protects
[--j
] = SCM_BOOL_F
;
954 scm_gc_init_freelist ();
955 scm_gc_init_malloc ();
958 /* We can't have a cleanup handler since we have no thread to run it
965 on_exit (cleanup
, 0);
971 scm_stand_in_procs
= scm_make_weak_key_hash_table (scm_from_int (257));
972 scm_permobjs
= SCM_EOL
;
973 scm_protects
= scm_c_make_hash_table (31);
974 scm_gc_registered_roots
= scm_c_make_hash_table (31);
981 SCM scm_after_gc_hook
;
985 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
986 * is run after the gc, as soon as the asynchronous events are handled by the
990 gc_async_thunk (void)
992 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
993 return SCM_UNSPECIFIED
;
997 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
998 * the garbage collection. The only purpose of this function is to mark the
999 * gc_async (which will eventually lead to the execution of the
1003 mark_gc_async (void * hook_data SCM_UNUSED
,
1004 void *fn_data SCM_UNUSED
,
1005 void *data SCM_UNUSED
)
1007 /* If cell access debugging is enabled, the user may choose to perform
1008 * additional garbage collections after an arbitrary number of cell
1009 * accesses. We don't want the scheme level after-gc-hook to be performed
1010 * for each of these garbage collections for the following reason: The
1011 * execution of the after-gc-hook causes cell accesses itself. Thus, if the
1012 * after-gc-hook was performed with every gc, and if the gc was performed
1013 * after a very small number of cell accesses, then the number of cell
1014 * accesses during the execution of the after-gc-hook will suffice to cause
1015 * the execution of the next gc. Then, guile would keep executing the
1016 * after-gc-hook over and over again, and would never come to do other
1019 * To overcome this problem, if cell access debugging with additional
1020 * garbage collections is enabled, the after-gc-hook is never run by the
1021 * garbage collecter. When running guile with cell access debugging and the
1022 * execution of the after-gc-hook is desired, then it is necessary to run
1023 * the hook explicitly from the user code. This has the effect, that from
1024 * the scheme level point of view it seems that garbage collection is
1025 * performed with a much lower frequency than it actually is. Obviously,
1026 * this will not work for code that depends on a fixed one to one
1027 * relationship between the execution counts of the C level garbage
1028 * collection hooks and the execution count of the scheme level
1032 #if (SCM_DEBUG_CELL_ACCESSES == 1)
1033 if (scm_debug_cells_gc_interval
== 0)
1034 scm_system_async_mark (gc_async
);
1036 scm_system_async_mark (gc_async
);
1045 scm_gc_init_mark ();
1047 scm_after_gc_hook
= scm_permanent_object (scm_make_hook (SCM_INUM0
));
1048 scm_c_define ("after-gc-hook", scm_after_gc_hook
);
1050 gc_async
= scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0
,
1053 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
1055 #include "libguile/gc.x"
1060 # include <sys/param.h>
1061 # include <sys/pstat.h>
1063 scm_ia64_register_backing_store_base (void)
1065 struct pst_vm_status vm_status
;
1067 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
1068 if (vm_status
.pst_type
== PS_RSESTACK
)
1069 return (void *) vm_status
.pst_vaddr
;
1073 scm_ia64_ar_bsp (const void *ctx
)
1076 __uc_get_ar_bsp (ctx
, &bsp
);
1077 return (void *) bsp
;
1081 # include <ucontext.h>
1083 scm_ia64_register_backing_store_base (void)
1085 extern void *__libc_ia64_register_backing_store_base
;
1086 return __libc_ia64_register_backing_store_base
;
1089 scm_ia64_ar_bsp (const void *opaque
)
1091 const ucontext_t
*ctx
= opaque
;
1092 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
1095 #endif /* __ia64__ */
1099 #define FUNC_NAME "scm_gc_sweep"