1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
45 /* #define DEBUGINFO */
49 #include "libguile/_scm.h"
50 #include "libguile/eval.h"
51 #include "libguile/stime.h"
52 #include "libguile/stackchk.h"
53 #include "libguile/struct.h"
54 #include "libguile/smob.h"
55 #include "libguile/unif.h"
56 #include "libguile/async.h"
57 #include "libguile/ports.h"
58 #include "libguile/root.h"
59 #include "libguile/strings.h"
60 #include "libguile/vectors.h"
61 #include "libguile/weaks.h"
62 #include "libguile/hashtab.h"
64 #include "libguile/validate.h"
65 #include "libguile/gc.h"
67 #ifdef GUILE_DEBUG_MALLOC
68 #include "libguile/debug-malloc.h"
81 #define var_start(x, y) va_start(x, y)
84 #define var_start(x, y) va_start(x)
89 unsigned int scm_gc_running_p
= 0;
93 #if (SCM_DEBUG_CELL_ACCESSES == 1)
95 unsigned int scm_debug_cell_accesses_p
= 0;
98 /* Assert that the given object is a valid reference to a valid cell. This
99 * test involves to determine whether the object is a cell pointer, whether
100 * this pointer actually points into a heap segment and whether the cell
101 * pointed to is not a free cell.
104 scm_assert_cell_valid (SCM cell
)
106 if (scm_debug_cell_accesses_p
)
108 scm_debug_cell_accesses_p
= 0; /* disable to avoid recursion */
110 if (!scm_cellp (cell
))
112 fprintf (stderr
, "scm_assert_cell_valid: Not a cell object: %lx\n", SCM_UNPACK (cell
));
115 else if (!scm_gc_running_p
)
117 /* Dirk::FIXME:: During garbage collection there occur references to
118 free cells. This is allright during conservative marking, but
119 should not happen otherwise (I think). The case of free cells
120 accessed during conservative marking is handled in function
121 scm_mark_locations. However, there still occur accesses to free
122 cells during gc. I don't understand why this happens. If it is
123 a bug and gets fixed, the following test should also work while
126 if (SCM_FREE_CELL_P (cell
))
128 fprintf (stderr
, "scm_assert_cell_valid: Accessing free cell: %lx\n", SCM_UNPACK (cell
));
132 scm_debug_cell_accesses_p
= 1; /* re-enable */
137 SCM_DEFINE (scm_set_debug_cell_accesses_x
, "set-debug-cell-accesses!", 1, 0, 0,
139 "If FLAG is #f, cell access checking is disabled.\n"
140 "If FLAG is #t, cell access checking is enabled.\n"
141 "This procedure only exists because the compile-time flag\n"
142 "SCM_DEBUG_CELL_ACCESSES was set to 1.\n")
143 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
145 if (SCM_FALSEP (flag
)) {
146 scm_debug_cell_accesses_p
= 0;
147 } else if (SCM_EQ_P (flag
, SCM_BOOL_T
)) {
148 scm_debug_cell_accesses_p
= 1;
150 SCM_WRONG_TYPE_ARG (1, flag
);
152 return SCM_UNSPECIFIED
;
156 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
160 /* {heap tuning parameters}
162 * These are parameters for controlling memory allocation. The heap
163 * is the area out of which scm_cons, and object headers are allocated.
165 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
166 * 64 bit machine. The units of the _SIZE parameters are bytes.
167 * Cons pairs and object headers occupy one heap cell.
169 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
170 * allocated initially the heap will grow by half its current size
171 * each subsequent time more heap is needed.
173 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
174 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
175 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
176 * is in scm_init_storage() and alloc_some_heap() in sys.c
178 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
179 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
181 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
184 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
187 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
188 * reclaimed by a GC triggered by must_malloc. If less than this is
189 * reclaimed, the trigger threshold is raised. [I don't know what a
190 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
191 * work around a oscillation that caused almost constant GC.]
195 * Heap size 45000 and 40% min yield gives quick startup and no extra
196 * heap allocation. Having higher values on min yield may lead to
197 * large heaps, especially if code behaviour is varying its
198 * maximum consumption between different freelists.
200 int scm_default_init_heap_size_1
= (45000L * sizeof (scm_cell
));
201 int scm_default_min_yield_1
= 40;
202 #define SCM_CLUSTER_SIZE_1 2000L
204 int scm_default_init_heap_size_2
= (2500L * 2 * sizeof (scm_cell
));
205 /* The following value may seem large, but note that if we get to GC at
206 * all, this means that we have a numerically intensive application
208 int scm_default_min_yield_2
= 40;
209 #define SCM_CLUSTER_SIZE_2 1000L
211 int scm_default_max_segment_size
= 2097000L;/* a little less (adm) than 2 Mb */
213 #define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell))
215 # define SCM_HEAP_SEG_SIZE 32768L
218 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
220 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
223 /* Make heap grow with factor 1.5 */
224 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
225 #define SCM_INIT_MALLOC_LIMIT 100000
226 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
228 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
229 bounds for allocated storage */
232 /*in 386 protected mode we must only adjust the offset */
233 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
234 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
237 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
238 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
240 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
241 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
244 #define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell))
245 #define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1)
246 #define SCM_HEAP_SIZE \
247 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
248 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
255 typedef struct scm_freelist_t
{
256 /* collected cells */
258 /* number of cells left to collect before cluster is full */
259 unsigned int left_to_collect
;
260 /* number of clusters which have been allocated */
261 unsigned int clusters_allocated
;
262 /* a list of freelists, each of size cluster_size,
263 * except the last one which may be shorter
267 /* this is the number of objects in each cluster, including the spine cell */
269 /* indicates that we should grow heap instead of GC:ing
272 /* minimum yield on this list in order not to grow the heap
275 /* defines min_yield as percent of total heap size
277 int min_yield_fraction
;
278 /* number of cells per object on this list */
280 /* number of collected cells during last GC */
282 /* number of collected cells during penultimate GC */
284 /* total number of cells in heap segments
285 * belonging to this list.
290 SCM scm_freelist
= SCM_EOL
;
291 scm_freelist_t scm_master_freelist
= {
292 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
294 SCM scm_freelist2
= SCM_EOL
;
295 scm_freelist_t scm_master_freelist2
= {
296 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
300 * is the number of bytes of must_malloc allocation needed to trigger gc.
302 unsigned long scm_mtrigger
;
306 * If set, don't expand the heap. Set only during gc, during which no allocation
307 * is supposed to take place anyway.
309 int scm_gc_heap_lock
= 0;
312 * Don't pause for collection if this is set -- just
315 int scm_block_gc
= 1;
317 /* During collection, this accumulates objects holding
320 SCM scm_weak_vectors
;
322 /* GC Statistics Keeping
324 unsigned long scm_cells_allocated
= 0;
325 long scm_mallocated
= 0;
326 unsigned long scm_gc_cells_collected
;
327 unsigned long scm_gc_yield
;
328 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
329 unsigned long scm_gc_malloc_collected
;
330 unsigned long scm_gc_ports_collected
;
331 unsigned long scm_gc_rt
;
332 unsigned long scm_gc_time_taken
= 0;
334 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
335 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
336 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
337 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
338 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
339 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
341 typedef struct scm_heap_seg_data_t
343 /* lower and upper bounds of the segment */
344 SCM_CELLPTR bounds
[2];
346 /* address of the head-of-freelist pointer for this segment's cells.
347 All segments usually point to the same one, scm_freelist. */
348 scm_freelist_t
*freelist
;
350 /* number of cells per object in this segment */
352 } scm_heap_seg_data_t
;
356 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
358 typedef enum { return_on_error
, abort_on_error
} policy_on_error
;
359 static void alloc_some_heap (scm_freelist_t
*, policy_on_error
);
363 /* Debugging functions. */
365 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
367 /* Return the number of the heap segment containing CELL. */
373 for (i
= 0; i
< scm_n_heap_segs
; i
++)
374 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
375 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
377 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
384 map_free_list (scm_freelist_t
*master
, SCM freelist
)
386 int last_seg
= -1, count
= 0;
389 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
))
391 int this_seg
= which_seg (f
);
393 if (this_seg
!= last_seg
)
396 fprintf (stderr
, " %5d %d-cells in segment %d\n",
397 count
, master
->span
, last_seg
);
404 fprintf (stderr
, " %5d %d-cells in segment %d\n",
405 count
, master
->span
, last_seg
);
408 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
410 "Print debugging information about the free-list.\n"
411 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
412 #define FUNC_NAME s_scm_map_free_list
415 fprintf (stderr
, "%d segments total (%d:%d",
417 scm_heap_table
[0].span
,
418 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
419 for (i
= 1; i
< scm_n_heap_segs
; i
++)
420 fprintf (stderr
, ", %d:%d",
421 scm_heap_table
[i
].span
,
422 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
423 fprintf (stderr
, ")\n");
424 map_free_list (&scm_master_freelist
, scm_freelist
);
425 map_free_list (&scm_master_freelist2
, scm_freelist2
);
428 return SCM_UNSPECIFIED
;
432 static int last_cluster
;
433 static int last_size
;
436 free_list_length (char *title
, int i
, SCM freelist
)
440 for (ls
= freelist
; !SCM_NULLP (ls
); ls
= SCM_FREE_CELL_CDR (ls
))
441 if (SCM_FREE_CELL_P (ls
))
445 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
452 if (last_cluster
== i
- 1)
453 fprintf (stderr
, "\t%d\n", last_size
);
455 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
458 fprintf (stderr
, "%s %d", title
, i
);
460 fprintf (stderr
, "%s\t%d\n", title
, n
);
468 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
471 int i
= 0, len
, n
= 0;
472 fprintf (stderr
, "%s\n\n", title
);
473 n
+= free_list_length ("free list", -1, freelist
);
474 for (clusters
= master
->clusters
;
475 SCM_NNULLP (clusters
);
476 clusters
= SCM_CDR (clusters
))
478 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
481 if (last_cluster
== i
- 1)
482 fprintf (stderr
, "\t%d\n", last_size
);
484 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
485 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
488 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
490 "Print debugging information about the free-list.\n"
491 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
492 #define FUNC_NAME s_scm_free_list_length
494 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
495 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
496 return SCM_UNSPECIFIED
;
502 #ifdef GUILE_DEBUG_FREELIST
504 /* Number of calls to SCM_NEWCELL since startup. */
505 static unsigned long scm_newcell_count
;
506 static unsigned long scm_newcell2_count
;
508 /* Search freelist for anything that isn't marked as a free cell.
509 Abort if we find something. */
511 scm_check_freelist (SCM freelist
)
516 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
), i
++)
517 if (!SCM_FREE_CELL_P (f
))
519 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
520 scm_newcell_count
, i
);
525 static int scm_debug_check_freelist
= 0;
527 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
529 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
530 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
531 "compile-time flag was selected.\n")
532 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
534 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
535 return SCM_UNSPECIFIED
;
541 scm_debug_newcell (void)
546 if (scm_debug_check_freelist
)
548 scm_check_freelist (scm_freelist
);
552 /* The rest of this is supposed to be identical to the SCM_NEWCELL
554 if (SCM_NULLP (scm_freelist
))
555 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
559 scm_freelist
= SCM_FREE_CELL_CDR (scm_freelist
);
560 SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated
);
567 scm_debug_newcell2 (void)
571 scm_newcell2_count
++;
572 if (scm_debug_check_freelist
)
574 scm_check_freelist (scm_freelist2
);
578 /* The rest of this is supposed to be identical to the SCM_NEWCELL
580 if (SCM_NULLP (scm_freelist2
))
581 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
585 scm_freelist2
= SCM_FREE_CELL_CDR (scm_freelist2
);
586 SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated
);
592 #endif /* GUILE_DEBUG_FREELIST */
597 master_cells_allocated (scm_freelist_t
*master
)
599 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
600 if (SCM_NULLP (master
->clusters
))
601 objects
-= master
->left_to_collect
;
602 return master
->span
* objects
;
606 freelist_length (SCM freelist
)
609 for (n
= 0; !SCM_NULLP (freelist
); freelist
= SCM_FREE_CELL_CDR (freelist
))
615 compute_cells_allocated ()
617 return (scm_cells_allocated
618 + master_cells_allocated (&scm_master_freelist
)
619 + master_cells_allocated (&scm_master_freelist2
)
620 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
621 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
624 /* {Scheme Interface to GC}
627 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
629 "Returns an association list of statistics about Guile's current use of storage. ")
630 #define FUNC_NAME s_scm_gc_stats
635 long int local_scm_mtrigger
;
636 long int local_scm_mallocated
;
637 long int local_scm_heap_size
;
638 long int local_scm_cells_allocated
;
639 long int local_scm_gc_time_taken
;
649 for (i
= scm_n_heap_segs
; i
--; )
650 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
651 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
653 if (scm_n_heap_segs
!= n
)
658 /* Below, we cons to produce the resulting list. We want a snapshot of
659 * the heap situation before consing.
661 local_scm_mtrigger
= scm_mtrigger
;
662 local_scm_mallocated
= scm_mallocated
;
663 local_scm_heap_size
= SCM_HEAP_SIZE
;
664 local_scm_cells_allocated
= compute_cells_allocated ();
665 local_scm_gc_time_taken
= scm_gc_time_taken
;
667 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
668 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
669 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
670 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
671 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
672 scm_cons (sym_heap_segments
, heap_segs
),
681 scm_gc_start (const char *what
)
683 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
684 scm_gc_cells_collected
= 0;
685 scm_gc_yield_1
= scm_gc_yield
;
686 scm_gc_yield
= (scm_cells_allocated
687 + master_cells_allocated (&scm_master_freelist
)
688 + master_cells_allocated (&scm_master_freelist2
));
689 scm_gc_malloc_collected
= 0;
690 scm_gc_ports_collected
= 0;
697 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
698 scm_gc_time_taken
+= scm_gc_rt
;
702 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
704 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
705 "returned by this function for @var{obj}")
706 #define FUNC_NAME s_scm_object_address
708 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
713 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
715 "Scans all of SCM objects and reclaims for further use those that are\n"
716 "no longer accessible.")
717 #define FUNC_NAME s_scm_gc
722 return SCM_UNSPECIFIED
;
728 /* {C Interface For When GC is Triggered}
732 adjust_min_yield (scm_freelist_t
*freelist
)
734 /* min yield is adjusted upwards so that next predicted total yield
735 * (allocated cells actually freed by GC) becomes
736 * `min_yield_fraction' of total heap size. Note, however, that
737 * the absolute value of min_yield will correspond to `collected'
738 * on one master (the one which currently is triggering GC).
740 * The reason why we look at total yield instead of cells collected
741 * on one list is that we want to take other freelists into account.
742 * On this freelist, we know that (local) yield = collected cells,
743 * but that's probably not the case on the other lists.
745 * (We might consider computing a better prediction, for example
746 * by computing an average over multiple GC:s.)
748 if (freelist
->min_yield_fraction
)
750 /* Pick largest of last two yields. */
751 int delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
752 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
754 fprintf (stderr
, " after GC = %d, delta = %d\n",
759 freelist
->min_yield
+= delta
;
764 /* When we get POSIX threads support, the master will be global and
765 * common while the freelist will be individual for each thread.
769 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
775 if (SCM_NULLP (master
->clusters
))
777 if (master
->grow_heap_p
|| scm_block_gc
)
779 /* In order to reduce gc frequency, try to allocate a new heap
780 * segment first, even if gc might find some free cells. If we
781 * can't obtain a new heap segment, we will try gc later.
783 master
->grow_heap_p
= 0;
784 alloc_some_heap (master
, return_on_error
);
786 if (SCM_NULLP (master
->clusters
))
788 /* The heap was not grown, either because it wasn't scheduled to
789 * grow, or because there was not enough memory available. In
790 * both cases we have to try gc to get some free cells.
793 fprintf (stderr
, "allocated = %d, ",
795 + master_cells_allocated (&scm_master_freelist
)
796 + master_cells_allocated (&scm_master_freelist2
));
799 adjust_min_yield (master
);
800 if (SCM_NULLP (master
->clusters
))
802 /* gc could not free any cells. Now, we _must_ allocate a
803 * new heap segment, because there is no other possibility
804 * to provide a new cell for the caller.
806 alloc_some_heap (master
, abort_on_error
);
810 cell
= SCM_CAR (master
->clusters
);
811 master
->clusters
= SCM_CDR (master
->clusters
);
812 ++master
->clusters_allocated
;
814 while (SCM_NULLP (cell
));
816 *freelist
= SCM_FREE_CELL_CDR (cell
);
817 SCM_SET_FREE_CELL_TYPE (cell
, scm_tc16_allocated
);
823 /* This is a support routine which can be used to reserve a cluster
824 * for some special use, such as debugging. It won't be useful until
825 * free cells are preserved between garbage collections.
829 scm_alloc_cluster (scm_freelist_t
*master
)
832 cell
= scm_gc_for_newcell (master
, &freelist
);
833 SCM_SETCDR (cell
, freelist
);
839 scm_c_hook_t scm_before_gc_c_hook
;
840 scm_c_hook_t scm_before_mark_c_hook
;
841 scm_c_hook_t scm_before_sweep_c_hook
;
842 scm_c_hook_t scm_after_sweep_c_hook
;
843 scm_c_hook_t scm_after_gc_c_hook
;
847 scm_igc (const char *what
)
852 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
855 SCM_NULLP (scm_freelist
)
857 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
860 /* During the critical section, only the current thread may run. */
861 SCM_THREAD_CRITICAL_SECTION_START
;
864 /* fprintf (stderr, "gc: %s\n", what); */
868 if (!scm_stack_base
|| scm_block_gc
)
875 if (scm_mallocated
< 0)
876 /* The byte count of allocated objects has underflowed. This is
877 probably because you forgot to report the sizes of objects you
878 have allocated, by calling scm_done_malloc or some such. When
879 the GC freed them, it subtracted their size from
880 scm_mallocated, which underflowed. */
883 if (scm_gc_heap_lock
)
884 /* We've invoked the collector while a GC is already in progress.
885 That should never happen. */
890 /* flush dead entries from the continuation stack */
895 elts
= SCM_VELTS (scm_continuation_stack
);
896 bound
= SCM_LENGTH (scm_continuation_stack
);
897 x
= SCM_INUM (scm_continuation_stack_ptr
);
900 elts
[x
] = SCM_BOOL_F
;
905 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
909 /* Protect from the C stack. This must be the first marking
910 * done because it provides information about what objects
911 * are "in-use" by the C code. "in-use" objects are those
912 * for which the values from SCM_LENGTH and SCM_CHARS must remain
913 * usable. This requirement is stricter than a liveness
914 * requirement -- in particular, it constrains the implementation
915 * of scm_vector_set_length_x.
917 SCM_FLUSH_REGISTER_WINDOWS
;
918 /* This assumes that all registers are saved into the jmp_buf */
919 setjmp (scm_save_regs_gc_mark
);
920 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
921 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
922 sizeof scm_save_regs_gc_mark
)
923 / sizeof (SCM_STACKITEM
)));
926 scm_sizet stack_len
= scm_stack_size (scm_stack_base
);
927 #ifdef SCM_STACK_GROWS_UP
928 scm_mark_locations (scm_stack_base
, stack_len
);
930 scm_mark_locations (scm_stack_base
- stack_len
, stack_len
);
934 #else /* USE_THREADS */
936 /* Mark every thread's stack and registers */
937 scm_threads_mark_stacks ();
939 #endif /* USE_THREADS */
941 /* FIXME: insert a phase to un-protect string-data preserved
942 * in scm_vector_set_length_x.
945 j
= SCM_NUM_PROTECTS
;
947 scm_gc_mark (scm_sys_protects
[j
]);
949 /* FIXME: we should have a means to register C functions to be run
950 * in different phases of GC
952 scm_mark_subr_table ();
955 scm_gc_mark (scm_root
->handle
);
958 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
962 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
968 SCM_THREAD_CRITICAL_SECTION_END
;
970 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
981 /* Mark an object precisely.
985 #define FUNC_NAME "scm_gc_mark"
997 if (!SCM_CELLP (ptr
))
998 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1000 switch (SCM_TYP7 (ptr
))
1002 case scm_tcs_cons_nimcar
:
1003 if (SCM_GCMARKP (ptr
))
1005 SCM_SETGCMARK (ptr
);
1006 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
1008 ptr
= SCM_CAR (ptr
);
1011 scm_gc_mark (SCM_CAR (ptr
));
1012 ptr
= SCM_GCCDR (ptr
);
1014 case scm_tcs_cons_imcar
:
1015 if (SCM_GCMARKP (ptr
))
1017 SCM_SETGCMARK (ptr
);
1018 ptr
= SCM_GCCDR (ptr
);
1021 if (SCM_GCMARKP (ptr
))
1023 SCM_SETGCMARK (ptr
);
1024 scm_gc_mark (SCM_CELL_OBJECT_2 (ptr
));
1025 ptr
= SCM_GCCDR (ptr
);
1027 case scm_tcs_cons_gloc
:
1028 if (SCM_GCMARKP (ptr
))
1030 SCM_SETGCMARK (ptr
);
1032 /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
1033 * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
1034 * to a heap cell. If it is a struct, the cell word #0 of ptr is a
1035 * pointer to a struct vtable data region. The fact that these are
1036 * accessed in the same way restricts the possibilites to change the
1037 * data layout of structs or heap cells.
1039 scm_bits_t word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
1040 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1041 switch (vtable_data
[scm_vtable_index_vcell
])
1046 SCM gloc_car
= SCM_PACK (word0
);
1047 scm_gc_mark (gloc_car
);
1048 ptr
= SCM_GCCDR (ptr
);
1054 /* ptr is a struct */
1055 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
1056 int len
= SCM_LENGTH (layout
);
1057 char * fields_desc
= SCM_CHARS (layout
);
1058 /* We're using SCM_GCCDR here like STRUCT_DATA, except
1059 that it removes the mark */
1060 scm_bits_t
* struct_data
= (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (ptr
));
1062 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
1064 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
1065 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1071 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1072 if (fields_desc
[x
] == 'p')
1073 scm_gc_mark (SCM_PACK (*struct_data
));
1074 if (fields_desc
[x
] == 'p')
1076 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1077 for (x
= *struct_data
; x
; --x
)
1078 scm_gc_mark (SCM_PACK (*++struct_data
));
1080 scm_gc_mark (SCM_PACK (*struct_data
));
1083 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1085 vtable_data
[scm_vtable_index_vcell
] = 1;
1086 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1093 case scm_tcs_closures
:
1094 if (SCM_GCMARKP (ptr
))
1096 SCM_SETGCMARK (ptr
);
1097 if (SCM_IMP (SCM_CDR (ptr
)))
1099 ptr
= SCM_CLOSCAR (ptr
);
1102 scm_gc_mark (SCM_CLOSCAR (ptr
));
1103 ptr
= SCM_GCCDR (ptr
);
1105 case scm_tc7_vector
:
1106 case scm_tc7_lvector
:
1110 if (SCM_GC8MARKP (ptr
))
1112 SCM_SETGC8MARK (ptr
);
1113 i
= SCM_LENGTH (ptr
);
1117 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1118 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1119 ptr
= SCM_VELTS (ptr
)[0];
1121 case scm_tc7_contin
:
1124 SCM_SETGC8MARK (ptr
);
1125 if (SCM_VELTS (ptr
))
1126 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1129 (sizeof (SCM_STACKITEM
) + -1 +
1130 sizeof (scm_contregs
)) /
1131 sizeof (SCM_STACKITEM
)));
1135 case scm_tc7_byvect
:
1142 #ifdef HAVE_LONG_LONGS
1143 case scm_tc7_llvect
:
1146 case scm_tc7_string
:
1147 SCM_SETGC8MARK (ptr
);
1150 case scm_tc7_substring
:
1151 if (SCM_GC8MARKP(ptr
))
1153 SCM_SETGC8MARK (ptr
);
1154 ptr
= SCM_CDR (ptr
);
1158 if (SCM_GC8MARKP(ptr
))
1160 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1161 scm_weak_vectors
= ptr
;
1162 SCM_SETGC8MARK (ptr
);
1163 if (SCM_IS_WHVEC_ANY (ptr
))
1170 len
= SCM_LENGTH (ptr
);
1171 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1172 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1174 for (x
= 0; x
< len
; ++x
)
1177 alist
= SCM_VELTS (ptr
)[x
];
1179 /* mark everything on the alist except the keys or
1180 * values, according to weak_values and weak_keys. */
1181 while ( SCM_CONSP (alist
)
1182 && !SCM_GCMARKP (alist
)
1183 && SCM_CONSP (SCM_CAR (alist
)))
1188 kvpair
= SCM_CAR (alist
);
1189 next_alist
= SCM_CDR (alist
);
1192 * SCM_SETGCMARK (alist);
1193 * SCM_SETGCMARK (kvpair);
1195 * It may be that either the key or value is protected by
1196 * an escaped reference to part of the spine of this alist.
1197 * If we mark the spine here, and only mark one or neither of the
1198 * key and value, they may never be properly marked.
1199 * This leads to a horrible situation in which an alist containing
1200 * freelist cells is exported.
1202 * So only mark the spines of these arrays last of all marking.
1203 * If somebody confuses us by constructing a weak vector
1204 * with a circular alist then we are hosed, but at least we
1205 * won't prematurely drop table entries.
1208 scm_gc_mark (SCM_CAR (kvpair
));
1210 scm_gc_mark (SCM_GCCDR (kvpair
));
1213 if (SCM_NIMP (alist
))
1214 scm_gc_mark (alist
);
1219 case scm_tc7_msymbol
:
1220 if (SCM_GC8MARKP(ptr
))
1222 SCM_SETGC8MARK (ptr
);
1223 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1224 ptr
= SCM_SYMBOL_PROPS (ptr
);
1226 case scm_tc7_ssymbol
:
1227 if (SCM_GC8MARKP(ptr
))
1229 SCM_SETGC8MARK (ptr
);
1234 i
= SCM_PTOBNUM (ptr
);
1235 if (!(i
< scm_numptob
))
1237 if (SCM_GC8MARKP (ptr
))
1239 SCM_SETGC8MARK (ptr
);
1240 if (SCM_PTAB_ENTRY(ptr
))
1241 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1242 if (scm_ptobs
[i
].mark
)
1244 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1251 if (SCM_GC8MARKP (ptr
))
1253 SCM_SETGC8MARK (ptr
);
1254 switch (SCM_GCTYP16 (ptr
))
1255 { /* should be faster than going through scm_smobs */
1256 case scm_tc_free_cell
:
1257 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1258 case scm_tc16_allocated
:
1261 case scm_tc16_complex
:
1264 i
= SCM_SMOBNUM (ptr
);
1265 if (!(i
< scm_numsmob
))
1267 if (scm_smobs
[i
].mark
)
1269 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1278 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1284 /* Mark a Region Conservatively
1288 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1292 for (m
= 0; m
< n
; ++m
)
1294 SCM obj
= * (SCM
*) &x
[m
];
1295 if (SCM_CELLP (obj
))
1297 SCM_CELLPTR ptr
= SCM2PTR (obj
);
1299 int j
= scm_n_heap_segs
- 1;
1300 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1301 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1308 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1310 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1318 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1322 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1327 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1331 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1337 if (scm_heap_table
[seg_id
].span
== 1
1338 || SCM_DOUBLE_CELLP (obj
))
1340 if (!SCM_FREE_CELL_P (obj
))
1351 /* The function scm_cellp determines whether an SCM value can be regarded as a
1352 * pointer to a cell on the heap. Binary search is used in order to determine
1353 * the heap segment that contains the cell.
1356 scm_cellp (SCM value
)
1358 if (SCM_CELLP (value
)) {
1359 scm_cell
* ptr
= SCM2PTR (value
);
1361 unsigned int j
= scm_n_heap_segs
- 1;
1364 int k
= (i
+ j
) / 2;
1365 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
)) {
1367 } else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
)) {
1372 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1373 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
)
1374 && (scm_heap_table
[i
].span
== 1 || SCM_DOUBLE_CELLP (value
))) {
1386 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1388 freelist
->cells
= SCM_EOL
;
1389 freelist
->left_to_collect
= freelist
->cluster_size
;
1390 freelist
->clusters_allocated
= 0;
1391 freelist
->clusters
= SCM_EOL
;
1392 freelist
->clustertail
= &freelist
->clusters
;
1393 freelist
->collected_1
= freelist
->collected
;
1394 freelist
->collected
= 0;
1398 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1401 *freelist
->clustertail
= freelist
->cells
;
1402 if (!SCM_NULLP (freelist
->cells
))
1404 SCM c
= freelist
->cells
;
1405 SCM_SETCAR (c
, SCM_CDR (c
));
1406 SCM_SETCDR (c
, SCM_EOL
);
1407 freelist
->collected
+=
1408 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1410 scm_gc_cells_collected
+= freelist
->collected
;
1412 /* Although freelist->min_yield is used to test freelist->collected
1413 * (which is the local GC yield for freelist), it is adjusted so
1414 * that *total* yield is freelist->min_yield_fraction of total heap
1415 * size. This means that a too low yield is compensated by more
1416 * heap on the list which is currently doing most work, which is
1417 * just what we want.
1419 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1420 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1425 #define FUNC_NAME "scm_gc_sweep"
1427 register SCM_CELLPTR ptr
;
1428 register SCM nfreelist
;
1429 register scm_freelist_t
*freelist
;
1437 gc_sweep_freelist_start (&scm_master_freelist
);
1438 gc_sweep_freelist_start (&scm_master_freelist2
);
1440 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1442 register unsigned int left_to_collect
;
1443 register scm_sizet j
;
1445 /* Unmarked cells go onto the front of the freelist this heap
1446 segment points to. Rather than updating the real freelist
1447 pointer as we go along, we accumulate the new head in
1448 nfreelist. Then, if it turns out that the entire segment is
1449 free, we free (i.e., malloc's free) the whole segment, and
1450 simply don't assign nfreelist back into the real freelist. */
1451 freelist
= scm_heap_table
[i
].freelist
;
1452 nfreelist
= freelist
->cells
;
1453 left_to_collect
= freelist
->left_to_collect
;
1454 span
= scm_heap_table
[i
].span
;
1456 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1457 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1458 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1460 SCM scmptr
= PTR2SCM (ptr
);
1462 switch SCM_TYP7 (scmptr
)
1464 case scm_tcs_cons_gloc
:
1466 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1467 * struct or a gloc. See the corresponding comment in
1470 scm_bits_t word0
= SCM_CELL_WORD_0 (scmptr
) - scm_tc3_cons_gloc
;
1471 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1472 if (SCM_GCMARKP (scmptr
))
1474 if (vtable_data
[scm_vtable_index_vcell
] == 1)
1475 vtable_data
[scm_vtable_index_vcell
] = 0;
1480 if (vtable_data
[scm_vtable_index_vcell
] == 0
1481 || vtable_data
[scm_vtable_index_vcell
] == 1)
1483 scm_struct_free_t free_struct_data
1484 = (scm_struct_free_t
) vtable_data
[scm_struct_i_free
];
1485 m
+= free_struct_data (vtable_data
, (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (scmptr
)));
1490 case scm_tcs_cons_imcar
:
1491 case scm_tcs_cons_nimcar
:
1492 case scm_tcs_closures
:
1494 if (SCM_GCMARKP (scmptr
))
1498 if (SCM_GC8MARKP (scmptr
))
1504 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1505 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1509 case scm_tc7_vector
:
1510 case scm_tc7_lvector
:
1514 if (SCM_GC8MARKP (scmptr
))
1517 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1519 scm_must_free (SCM_CHARS (scmptr
));
1520 /* SCM_SETCHARS(scmptr, 0);*/
1524 if SCM_GC8MARKP (scmptr
)
1526 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1528 case scm_tc7_byvect
:
1529 if SCM_GC8MARKP (scmptr
)
1531 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1535 if SCM_GC8MARKP (scmptr
)
1537 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1540 if SCM_GC8MARKP (scmptr
)
1542 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1544 #ifdef HAVE_LONG_LONGS
1545 case scm_tc7_llvect
:
1546 if SCM_GC8MARKP (scmptr
)
1548 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1552 if SCM_GC8MARKP (scmptr
)
1554 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1557 if SCM_GC8MARKP (scmptr
)
1559 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1562 if SCM_GC8MARKP (scmptr
)
1564 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1567 case scm_tc7_substring
:
1568 if (SCM_GC8MARKP (scmptr
))
1571 case scm_tc7_string
:
1572 if (SCM_GC8MARKP (scmptr
))
1574 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1576 case scm_tc7_msymbol
:
1577 if (SCM_GC8MARKP (scmptr
))
1579 m
+= (SCM_LENGTH (scmptr
) + 1
1580 + (SCM_CHARS (scmptr
) - (char *) SCM_SLOTS (scmptr
)));
1581 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1583 case scm_tc7_contin
:
1584 if SCM_GC8MARKP (scmptr
)
1586 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1587 if (SCM_VELTS (scmptr
))
1589 case scm_tc7_ssymbol
:
1590 if SCM_GC8MARKP(scmptr
)
1596 if SCM_GC8MARKP (scmptr
)
1598 if SCM_OPENP (scmptr
)
1600 int k
= SCM_PTOBNUM (scmptr
);
1601 if (!(k
< scm_numptob
))
1603 /* Keep "revealed" ports alive. */
1604 if (scm_revealed_count (scmptr
) > 0)
1606 /* Yes, I really do mean scm_ptobs[k].free */
1607 /* rather than ftobs[k].close. .close */
1608 /* is for explicit CLOSE-PORT by user */
1609 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1610 SCM_SETSTREAM (scmptr
, 0);
1611 scm_remove_from_port_table (scmptr
);
1612 scm_gc_ports_collected
++;
1613 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1617 switch SCM_GCTYP16 (scmptr
)
1619 case scm_tc_free_cell
:
1621 if SCM_GC8MARKP (scmptr
)
1626 if SCM_GC8MARKP (scmptr
)
1628 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1630 #endif /* def SCM_BIGDIG */
1631 case scm_tc16_complex
:
1632 if SCM_GC8MARKP (scmptr
)
1634 m
+= 2 * sizeof (double);
1637 if SCM_GC8MARKP (scmptr
)
1642 k
= SCM_SMOBNUM (scmptr
);
1643 if (!(k
< scm_numsmob
))
1645 m
+= (scm_smobs
[k
].free
) (scmptr
);
1652 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1655 if (SCM_FREE_CELL_P (scmptr
))
1658 if (!--left_to_collect
)
1660 SCM_SETCAR (scmptr
, nfreelist
);
1661 *freelist
->clustertail
= scmptr
;
1662 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1664 nfreelist
= SCM_EOL
;
1665 freelist
->collected
+= span
* freelist
->cluster_size
;
1666 left_to_collect
= freelist
->cluster_size
;
1670 /* Stick the new cell on the front of nfreelist. It's
1671 critical that we mark this cell as freed; otherwise, the
1672 conservative collector might trace it as some other type
1674 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1675 SCM_SET_FREE_CELL_CDR (scmptr
, nfreelist
);
1681 SCM_CLRGC8MARK (scmptr
);
1684 SCM_CLRGCMARK (scmptr
);
1686 #ifdef GC_FREE_SEGMENTS
1691 freelist
->heap_size
-= seg_size
;
1692 free ((char *) scm_heap_table
[i
].bounds
[0]);
1693 scm_heap_table
[i
].bounds
[0] = 0;
1694 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1695 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1696 scm_n_heap_segs
-= 1;
1697 i
--; /* We need to scan the segment just moved. */
1700 #endif /* ifdef GC_FREE_SEGMENTS */
1702 /* Update the real freelist pointer to point to the head of
1703 the list of free cells we've built for this segment. */
1704 freelist
->cells
= nfreelist
;
1705 freelist
->left_to_collect
= left_to_collect
;
1708 #ifdef GUILE_DEBUG_FREELIST
1709 scm_check_freelist (freelist
== &scm_master_freelist
1712 scm_map_free_list ();
1716 gc_sweep_freelist_finish (&scm_master_freelist
);
1717 gc_sweep_freelist_finish (&scm_master_freelist2
);
1719 /* When we move to POSIX threads private freelists should probably
1720 be GC-protected instead. */
1721 scm_freelist
= SCM_EOL
;
1722 scm_freelist2
= SCM_EOL
;
1724 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1725 scm_gc_yield
-= scm_cells_allocated
;
1726 scm_mallocated
-= m
;
1727 scm_gc_malloc_collected
= m
;
1734 /* {Front end to malloc}
1736 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
1739 * These functions provide services comperable to malloc, realloc, and
1740 * free. They are for allocating malloced parts of scheme objects.
1741 * The primary purpose of the front end is to impose calls to gc. */
1745 * Return newly malloced storage or throw an error.
1747 * The parameter WHAT is a string for error reporting.
1748 * If the threshold scm_mtrigger will be passed by this
1749 * allocation, or if the first call to malloc fails,
1750 * garbage collect -- on the presumption that some objects
1751 * using malloced storage may be collected.
1753 * The limit scm_mtrigger may be raised by this allocation.
1756 scm_must_malloc (scm_sizet size
, const char *what
)
1759 unsigned long nm
= scm_mallocated
+ size
;
1761 if (nm
<= scm_mtrigger
)
1763 SCM_SYSCALL (ptr
= malloc (size
));
1766 scm_mallocated
= nm
;
1767 #ifdef GUILE_DEBUG_MALLOC
1768 scm_malloc_register (ptr
, what
);
1776 nm
= scm_mallocated
+ size
;
1777 SCM_SYSCALL (ptr
= malloc (size
));
1780 scm_mallocated
= nm
;
1781 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1782 if (nm
> scm_mtrigger
)
1783 scm_mtrigger
= nm
+ nm
/ 2;
1785 scm_mtrigger
+= scm_mtrigger
/ 2;
1787 #ifdef GUILE_DEBUG_MALLOC
1788 scm_malloc_register (ptr
, what
);
1794 scm_memory_error (what
);
1799 * is similar to scm_must_malloc.
1802 scm_must_realloc (void *where
,
1808 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1810 if (nm
<= scm_mtrigger
)
1812 SCM_SYSCALL (ptr
= realloc (where
, size
));
1815 scm_mallocated
= nm
;
1816 #ifdef GUILE_DEBUG_MALLOC
1817 scm_malloc_reregister (where
, ptr
, what
);
1825 nm
= scm_mallocated
+ size
- old_size
;
1826 SCM_SYSCALL (ptr
= realloc (where
, size
));
1829 scm_mallocated
= nm
;
1830 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1831 if (nm
> scm_mtrigger
)
1832 scm_mtrigger
= nm
+ nm
/ 2;
1834 scm_mtrigger
+= scm_mtrigger
/ 2;
1836 #ifdef GUILE_DEBUG_MALLOC
1837 scm_malloc_reregister (where
, ptr
, what
);
1842 scm_memory_error (what
);
1847 scm_must_free (void *obj
)
1848 #define FUNC_NAME "scm_must_free"
1850 #ifdef GUILE_DEBUG_MALLOC
1851 scm_malloc_unregister (obj
);
1856 SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL
);
1861 /* Announce that there has been some malloc done that will be freed
1862 * during gc. A typical use is for a smob that uses some malloced
1863 * memory but can not get it from scm_must_malloc (for whatever
1864 * reason). When a new object of this smob is created you call
1865 * scm_done_malloc with the size of the object. When your smob free
1866 * function is called, be sure to include this size in the return
1869 * If you can't actually free the memory in the smob free function,
1870 * for whatever reason (like reference counting), you still can (and
1871 * should) report the amount of memory freed when you actually free it.
1872 * Do it by calling scm_done_malloc with the _negated_ size. Clever,
1873 * eh? Or even better, call scm_done_free. */
1876 scm_done_malloc (long size
)
1878 scm_mallocated
+= size
;
1880 if (scm_mallocated
> scm_mtrigger
)
1882 scm_igc ("foreign mallocs");
1883 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1885 if (scm_mallocated
> scm_mtrigger
)
1886 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1888 scm_mtrigger
+= scm_mtrigger
/ 2;
1894 scm_done_free (long size
)
1896 scm_mallocated
-= size
;
1904 * Each heap segment is an array of objects of a particular size.
1905 * Every segment has an associated (possibly shared) freelist.
1906 * A table of segment records is kept that records the upper and
1907 * lower extents of the segment; this is used during the conservative
1908 * phase of gc to identify probably gc roots (because they point
1909 * into valid segments at reasonable offsets). */
1912 * is true if the first segment was smaller than INIT_HEAP_SEG.
1913 * If scm_expmem is set to one, subsequent segment allocations will
1914 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1918 scm_sizet scm_max_segment_size
;
1921 * is the lowest base address of any heap segment.
1923 SCM_CELLPTR scm_heap_org
;
1925 scm_heap_seg_data_t
* scm_heap_table
= 0;
1926 static unsigned int heap_segment_table_size
= 0;
1927 int scm_n_heap_segs
= 0;
1930 * initializes a new heap segment and return the number of objects it contains.
1932 * The segment origin, segment size in bytes, and the span of objects
1933 * in cells are input parameters. The freelist is both input and output.
1935 * This function presume that the scm_heap_table has already been expanded
1936 * to accomodate a new segment record.
1941 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
1943 register SCM_CELLPTR ptr
;
1944 SCM_CELLPTR seg_end
;
1947 int span
= freelist
->span
;
1949 if (seg_org
== NULL
)
1952 ptr
= CELL_UP (seg_org
, span
);
1954 /* Compute the ceiling on valid object pointers w/in this segment.
1956 seg_end
= CELL_DN ((char *) seg_org
+ size
, span
);
1958 /* Find the right place and insert the segment record.
1961 for (new_seg_index
= 0;
1962 ( (new_seg_index
< scm_n_heap_segs
)
1963 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1969 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1970 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1975 scm_heap_table
[new_seg_index
].span
= span
;
1976 scm_heap_table
[new_seg_index
].freelist
= freelist
;
1977 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
1978 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
1981 /* Compute the least valid object pointer w/in this segment
1983 ptr
= CELL_UP (ptr
, span
);
1987 n_new_cells
= seg_end
- ptr
;
1989 freelist
->heap_size
+= n_new_cells
;
1991 /* Partition objects in this segment into clusters */
1994 SCM
*clusterp
= &clusters
;
1995 int n_cluster_cells
= span
* freelist
->cluster_size
;
1997 while (n_new_cells
> span
) /* at least one spine + one freecell */
1999 /* Determine end of cluster
2001 if (n_new_cells
>= n_cluster_cells
)
2003 seg_end
= ptr
+ n_cluster_cells
;
2004 n_new_cells
-= n_cluster_cells
;
2007 /* [cmm] looks like the segment size doesn't divide cleanly by
2008 cluster size. bad cmm! */
2011 /* Allocate cluster spine
2013 *clusterp
= PTR2SCM (ptr
);
2014 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
2015 clusterp
= SCM_CDRLOC (*clusterp
);
2018 while (ptr
< seg_end
)
2020 SCM scmptr
= PTR2SCM (ptr
);
2022 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
2023 SCM_SET_FREE_CELL_CDR (scmptr
, PTR2SCM (ptr
+ span
));
2027 SCM_SET_FREE_CELL_CDR (PTR2SCM (ptr
- span
), SCM_EOL
);
2030 /* Patch up the last cluster pointer in the segment
2031 * to join it to the input freelist.
2033 *clusterp
= freelist
->clusters
;
2034 freelist
->clusters
= clusters
;
2038 fprintf (stderr
, "H");
2044 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
2046 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2049 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2050 + ALIGNMENT_SLACK (freelist
);
2054 alloc_some_heap (scm_freelist_t
*freelist
, policy_on_error error_policy
)
2055 #define FUNC_NAME "alloc_some_heap"
2060 if (scm_gc_heap_lock
)
2062 /* Critical code sections (such as the garbage collector) aren't
2063 * supposed to add heap segments.
2065 fprintf (stderr
, "alloc_some_heap: Can not extend locked heap.\n");
2069 if (scm_n_heap_segs
== heap_segment_table_size
)
2071 /* We have to expand the heap segment table to have room for the new
2072 * segment. Do not yet increment scm_n_heap_segs -- that is done by
2073 * init_heap_seg only if the allocation of the segment itself succeeds.
2075 unsigned int new_table_size
= scm_n_heap_segs
+ 1;
2076 size_t size
= new_table_size
* sizeof (scm_heap_seg_data_t
);
2077 scm_heap_seg_data_t
* new_heap_table
;
2079 SCM_SYSCALL (new_heap_table
= ((scm_heap_seg_data_t
*)
2080 realloc ((char *)scm_heap_table
, size
)));
2081 if (!new_heap_table
)
2083 if (error_policy
== abort_on_error
)
2085 fprintf (stderr
, "alloc_some_heap: Could not grow heap segment table.\n");
2095 scm_heap_table
= new_heap_table
;
2096 heap_segment_table_size
= new_table_size
;
2101 /* Pick a size for the new heap segment.
2102 * The rule for picking the size of a segment is explained in
2106 /* Assure that the new segment is predicted to be large enough.
2108 * New yield should at least equal GC fraction of new heap size, i.e.
2110 * y + dh > f * (h + dh)
2113 * f : min yield fraction
2115 * dh : size of new heap segment
2117 * This gives dh > (f * h - y) / (1 - f)
2119 int f
= freelist
->min_yield_fraction
;
2120 long h
= SCM_HEAP_SIZE
;
2121 long min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2122 len
= SCM_EXPHEAP (freelist
->heap_size
);
2124 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2126 if (len
< min_cells
)
2127 len
= min_cells
+ freelist
->cluster_size
;
2128 len
*= sizeof (scm_cell
);
2129 /* force new sampling */
2130 freelist
->collected
= LONG_MAX
;
2133 if (len
> scm_max_segment_size
)
2134 len
= scm_max_segment_size
;
2139 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2144 /* Allocate with decaying ambition. */
2145 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2146 && (len
>= smallest
))
2148 scm_sizet rounded_len
= round_to_cluster_size (freelist
, len
);
2149 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2152 init_heap_seg (ptr
, rounded_len
, freelist
);
2159 if (error_policy
== abort_on_error
)
2161 fprintf (stderr
, "alloc_some_heap: Could not grow heap.\n");
2168 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2171 #define FUNC_NAME s_scm_unhash_name
2175 SCM_VALIDATE_SYMBOL (1,name
);
2177 bound
= scm_n_heap_segs
;
2178 for (x
= 0; x
< bound
; ++x
)
2182 p
= scm_heap_table
[x
].bounds
[0];
2183 pbound
= scm_heap_table
[x
].bounds
[1];
2186 SCM cell
= PTR2SCM (p
);
2187 if (SCM_TYP3 (cell
) == scm_tc3_cons_gloc
)
2189 /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
2190 * struct cell. See the corresponding comment in scm_gc_mark.
2192 scm_bits_t word0
= SCM_CELL_WORD_0 (cell
) - scm_tc3_cons_gloc
;
2193 SCM gloc_car
= SCM_PACK (word0
); /* access as gloc */
2194 SCM vcell
= SCM_CELL_OBJECT_1 (gloc_car
);
2195 if ((SCM_EQ_P (name
, SCM_BOOL_T
) || SCM_EQ_P (SCM_CAR (gloc_car
), name
))
2196 && (SCM_UNPACK (vcell
) != 0) && (SCM_UNPACK (vcell
) != 1))
2198 SCM_SET_CELL_OBJECT_0 (cell
, name
);
2211 /* {GC Protection Helper Functions}
2216 scm_remember (SCM
*ptr
)
2221 These crazy functions prevent garbage collection
2222 of arguments after the first argument by
2223 ensuring they remain live throughout the
2224 function because they are used in the last
2225 line of the code block.
2226 It'd be better to have a nice compiler hint to
2227 aid the conservative stack-scanning GC. --03/09/00 gjb */
2229 scm_return_first (SCM elt
, ...)
2235 scm_return_first_int (int i
, ...)
2242 scm_permanent_object (SCM obj
)
2245 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2251 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
2252 other references are dropped, until the object is unprotected by calling
2253 scm_unprotect_object (OBJ). Calls to scm_protect/unprotect_object nest,
2254 i. e. it is possible to protect the same object several times, but it is
2255 necessary to unprotect the object the same number of times to actually get
2256 the object unprotected. It is an error to unprotect an object more often
2257 than it has been protected before. The function scm_protect_object returns
2261 /* Implementation note: For every object X, there is a counter which
2262 scm_protect_object(X) increments and scm_unprotect_object(X) decrements.
2266 scm_protect_object (SCM obj
)
2270 /* This critical section barrier will be replaced by a mutex. */
2273 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, SCM_MAKINUM (0));
2274 SCM_SETCDR (handle
, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle
)) + 1));
2282 /* Remove any protection for OBJ established by a prior call to
2283 scm_protect_object. This function returns OBJ.
2285 See scm_protect_object for more information. */
2287 scm_unprotect_object (SCM obj
)
2291 /* This critical section barrier will be replaced by a mutex. */
2294 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2296 if (SCM_IMP (handle
))
2298 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
2303 unsigned long int count
= SCM_INUM (SCM_CDR (handle
)) - 1;
2305 scm_hashq_remove_x (scm_protects
, obj
);
2307 SCM_SETCDR (handle
, SCM_MAKINUM (count
));
2317 /* called on process termination. */
2323 extern int on_exit (void (*procp
) (), int arg
);
2326 cleanup (int status
, void *arg
)
2328 #error Dont know how to setup a cleanup handler on your system.
2333 scm_flush_all_ports ();
2338 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2340 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2341 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2345 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2346 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2354 if (freelist
->min_yield_fraction
)
2355 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2357 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2364 init_freelist (scm_freelist_t
*freelist
,
2369 freelist
->clusters
= SCM_EOL
;
2370 freelist
->cluster_size
= cluster_size
+ 1;
2371 freelist
->left_to_collect
= 0;
2372 freelist
->clusters_allocated
= 0;
2373 freelist
->min_yield
= 0;
2374 freelist
->min_yield_fraction
= min_yield
;
2375 freelist
->span
= span
;
2376 freelist
->collected
= 0;
2377 freelist
->collected_1
= 0;
2378 freelist
->heap_size
= 0;
2382 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2383 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2384 scm_sizet max_segment_size
)
2388 if (!init_heap_size_1
)
2389 init_heap_size_1
= scm_default_init_heap_size_1
;
2390 if (!init_heap_size_2
)
2391 init_heap_size_2
= scm_default_init_heap_size_2
;
2393 j
= SCM_NUM_PROTECTS
;
2395 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2398 scm_freelist
= SCM_EOL
;
2399 scm_freelist2
= SCM_EOL
;
2400 init_freelist (&scm_master_freelist
,
2401 1, SCM_CLUSTER_SIZE_1
,
2402 gc_trigger_1
? gc_trigger_1
: scm_default_min_yield_1
);
2403 init_freelist (&scm_master_freelist2
,
2404 2, SCM_CLUSTER_SIZE_2
,
2405 gc_trigger_2
? gc_trigger_2
: scm_default_min_yield_2
);
2406 scm_max_segment_size
2407 = max_segment_size
? max_segment_size
: scm_default_max_segment_size
;
2411 j
= SCM_HEAP_SEG_SIZE
;
2412 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2413 scm_heap_table
= ((scm_heap_seg_data_t
*)
2414 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2415 heap_segment_table_size
= 2;
2417 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2418 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2421 /* scm_hplims[0] can change. do not remove scm_heap_org */
2422 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2424 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2425 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2426 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2427 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2428 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2430 /* Initialise the list of ports. */
2431 scm_port_table
= (scm_port
**)
2432 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2433 if (!scm_port_table
)
2440 on_exit (cleanup
, 0);
2444 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2445 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2447 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2448 scm_nullstr
= scm_makstr (0L, 0);
2449 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2450 scm_symhash
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2451 scm_weak_symhash
= scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim
));
2452 scm_symhash_vars
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2453 scm_stand_in_procs
= SCM_EOL
;
2454 scm_permobjs
= SCM_EOL
;
2455 scm_protects
= scm_make_vector (SCM_MAKINUM (31), SCM_EOL
);
2456 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2457 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2459 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));
2466 SCM scm_after_gc_hook
;
2468 #if (SCM_DEBUG_DEPRECATED == 0)
2469 static SCM scm_gc_vcell
; /* the vcell for gc-thunk. */
2470 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2471 static SCM gc_async
;
2474 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
2475 * is run after the gc, as soon as the asynchronous events are handled by the
2479 gc_async_thunk (void)
2481 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
2483 #if (SCM_DEBUG_DEPRECATED == 0)
2485 /* The following code will be removed in Guile 1.5. */
2486 if (SCM_NFALSEP (scm_gc_vcell
))
2488 SCM proc
= SCM_CDR (scm_gc_vcell
);
2490 if (SCM_NFALSEP (proc
) && !SCM_UNBNDP (proc
))
2491 scm_apply (proc
, SCM_EOL
, SCM_EOL
);
2494 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2496 return SCM_UNSPECIFIED
;
2500 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
2501 * the garbage collection. The only purpose of this function is to mark the
2502 * gc_async (which will eventually lead to the execution of the
2506 mark_gc_async (void * hook_data
, void *func_data
, void *data
)
2508 scm_system_async_mark (gc_async
);
2518 scm_after_gc_hook
= scm_create_hook ("after-gc-hook", 0);
2520 #if (SCM_DEBUG_DEPRECATED == 0)
2521 scm_gc_vcell
= scm_sysintern ("gc-thunk", SCM_BOOL_F
);
2522 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2523 /* Dirk:FIXME:: We don't really want a binding here. */
2524 after_gc_thunk
= scm_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk
);
2525 gc_async
= scm_system_async (after_gc_thunk
);
2527 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
2529 #include "libguile/gc.x"