1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 */
47 /* SECTION: This code is compiled once.
50 #ifndef MARK_DEPENDENCIES
57 #include "libguile/_scm.h"
58 #include "libguile/eval.h"
59 #include "libguile/stime.h"
60 #include "libguile/stackchk.h"
61 #include "libguile/struct.h"
62 #include "libguile/smob.h"
63 #include "libguile/unif.h"
64 #include "libguile/async.h"
65 #include "libguile/ports.h"
66 #include "libguile/root.h"
67 #include "libguile/strings.h"
68 #include "libguile/vectors.h"
69 #include "libguile/weaks.h"
70 #include "libguile/hashtab.h"
71 #include "libguile/tags.h"
73 #include "libguile/validate.h"
74 #include "libguile/deprecation.h"
75 #include "libguile/gc.h"
77 #ifdef GUILE_DEBUG_MALLOC
78 #include "libguile/debug-malloc.h"
91 #define var_start(x, y) va_start(x, y)
94 #define var_start(x, y) va_start(x)
99 unsigned int scm_gc_running_p
= 0;
103 #if (SCM_DEBUG_CELL_ACCESSES == 1)
105 scm_t_bits scm_tc16_allocated
;
107 /* Set this to != 0 if every cell that is accessed shall be checked:
109 unsigned int scm_debug_cell_accesses_p
= 1;
111 /* Set this to 0 if no additional gc's shall be performed, otherwise set it to
112 * the number of cell accesses after which a gc shall be called.
114 static unsigned int debug_cells_gc_interval
= 0;
117 /* Assert that the given object is a valid reference to a valid cell. This
118 * test involves to determine whether the object is a cell pointer, whether
119 * this pointer actually points into a heap segment and whether the cell
120 * pointed to is not a free cell. Further, additional garbage collections may
121 * get executed after a user defined number of cell accesses. This helps to
122 * find places in the C code where references are dropped for extremely short
126 scm_assert_cell_valid (SCM cell
)
128 static unsigned int already_running
= 0;
130 if (scm_debug_cell_accesses_p
&& !already_running
)
132 already_running
= 1; /* set to avoid recursion */
134 if (!scm_cellp (cell
))
136 fprintf (stderr
, "scm_assert_cell_valid: Not a cell object: %lux\n",
137 (unsigned long) SCM_UNPACK (cell
));
140 else if (!scm_gc_running_p
)
142 /* Dirk::FIXME:: During garbage collection there occur references to
143 free cells. This is allright during conservative marking, but
144 should not happen otherwise (I think). The case of free cells
145 accessed during conservative marking is handled in function
146 scm_mark_locations. However, there still occur accesses to free
147 cells during gc. I don't understand why this happens. If it is
148 a bug and gets fixed, the following test should also work while
151 if (SCM_FREE_CELL_P (cell
))
153 fprintf (stderr
, "scm_assert_cell_valid: Accessing free cell: %lux\n",
154 (unsigned long) SCM_UNPACK (cell
));
158 /* If desired, perform additional garbage collections after a user
159 * defined number of cell accesses.
161 if (debug_cells_gc_interval
)
163 static unsigned int counter
= 0;
171 counter
= debug_cells_gc_interval
;
172 scm_igc ("scm_assert_cell_valid");
176 already_running
= 0; /* re-enable */
181 SCM_DEFINE (scm_set_debug_cell_accesses_x
, "set-debug-cell-accesses!", 1, 0, 0,
183 "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
184 "If @var{flag} is @code{#t}, cell access checking is enabled,\n"
185 "but no additional calls to garbage collection are issued.\n"
186 "If @var{flag} is a number, cell access checking is enabled,\n"
187 "with an additional garbage collection after the given\n"
188 "number of cell accesses.\n"
189 "This procedure only exists when the compile-time flag\n"
190 "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
191 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
193 if (SCM_FALSEP (flag
)) {
194 scm_debug_cell_accesses_p
= 0;
195 } else if (SCM_EQ_P (flag
, SCM_BOOL_T
)) {
196 debug_cells_gc_interval
= 0;
197 scm_debug_cell_accesses_p
= 1;
198 } else if (SCM_INUMP (flag
)) {
199 long int f
= SCM_INUM (flag
);
200 if (f
<= 0) SCM_OUT_OF_RANGE (1, flag
);
201 debug_cells_gc_interval
= f
;
202 scm_debug_cell_accesses_p
= 1;
204 SCM_WRONG_TYPE_ARG (1, flag
);
206 return SCM_UNSPECIFIED
;
210 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
214 /* {heap tuning parameters}
216 * These are parameters for controlling memory allocation. The heap
217 * is the area out of which scm_cons, and object headers are allocated.
219 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
220 * 64 bit machine. The units of the _SIZE parameters are bytes.
221 * Cons pairs and object headers occupy one heap cell.
223 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
224 * allocated initially the heap will grow by half its current size
225 * each subsequent time more heap is needed.
227 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
228 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
229 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code
230 * is in scm_init_storage() and alloc_some_heap() in sys.c
232 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
233 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
235 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
238 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
241 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
242 * reclaimed by a GC triggered by must_malloc. If less than this is
243 * reclaimed, the trigger threshold is raised. [I don't know what a
244 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
245 * work around a oscillation that caused almost constant GC.]
249 * Heap size 45000 and 40% min yield gives quick startup and no extra
250 * heap allocation. Having higher values on min yield may lead to
251 * large heaps, especially if code behaviour is varying its
252 * maximum consumption between different freelists.
255 #define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS)
256 #define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L)
257 #define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS)
258 size_t scm_default_init_heap_size_1
= (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER
- 1)
259 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
260 int scm_default_min_yield_1
= 40;
262 #define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2))
263 size_t scm_default_init_heap_size_2
= (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER
- 1)
264 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
265 /* The following value may seem large, but note that if we get to GC at
266 * all, this means that we have a numerically intensive application
268 int scm_default_min_yield_2
= 40;
270 size_t scm_default_max_segment_size
= 2097000L;/* a little less (adm) than 2 Mb */
272 #define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE)
274 # define SCM_HEAP_SEG_SIZE 32768L
277 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
279 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
282 /* Make heap grow with factor 1.5 */
283 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
284 #define SCM_INIT_MALLOC_LIMIT 100000
285 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
287 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span)
288 aligned inner bounds for allocated storage */
291 /*in 386 protected mode we must only adjust the offset */
292 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
293 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
296 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
297 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
299 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
300 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
304 #define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
306 #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1)
307 #define CLUSTER_SIZE_IN_BYTES(freelist) \
308 (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE)
314 typedef struct scm_t_freelist
{
315 /* collected cells */
317 /* number of cells left to collect before cluster is full */
318 unsigned int left_to_collect
;
319 /* number of clusters which have been allocated */
320 unsigned int clusters_allocated
;
321 /* a list of freelists, each of size cluster_size,
322 * except the last one which may be shorter
326 /* this is the number of objects in each cluster, including the spine cell */
327 unsigned int cluster_size
;
328 /* indicates that we should grow heap instead of GC:ing
331 /* minimum yield on this list in order not to grow the heap
334 /* defines min_yield as percent of total heap size
336 int min_yield_fraction
;
337 /* number of cells per object on this list */
339 /* number of collected cells during last GC */
340 unsigned long collected
;
341 /* number of collected cells during penultimate GC */
342 unsigned long collected_1
;
343 /* total number of cells in heap segments
344 * belonging to this list.
346 unsigned long heap_size
;
349 SCM scm_freelist
= SCM_EOL
;
350 scm_t_freelist scm_master_freelist
= {
351 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0, 0
353 SCM scm_freelist2
= SCM_EOL
;
354 scm_t_freelist scm_master_freelist2
= {
355 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0, 0
359 * is the number of bytes of must_malloc allocation needed to trigger gc.
361 unsigned long scm_mtrigger
;
364 * If set, don't expand the heap. Set only during gc, during which no allocation
365 * is supposed to take place anyway.
367 int scm_gc_heap_lock
= 0;
370 * Don't pause for collection if this is set -- just
373 int scm_block_gc
= 1;
375 /* During collection, this accumulates objects holding
378 SCM scm_weak_vectors
;
380 /* During collection, this accumulates structures which are to be freed.
382 SCM scm_structs_to_free
;
384 /* GC Statistics Keeping
386 unsigned long scm_cells_allocated
= 0;
387 unsigned long scm_mallocated
= 0;
388 unsigned long scm_gc_cells_collected
;
389 unsigned long scm_gc_yield
;
390 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
391 unsigned long scm_gc_malloc_collected
;
392 unsigned long scm_gc_ports_collected
;
393 unsigned long scm_gc_time_taken
= 0;
394 static unsigned long t_before_gc
;
395 static unsigned long t_before_sweep
;
396 unsigned long scm_gc_mark_time_taken
= 0;
397 unsigned long scm_gc_sweep_time_taken
= 0;
398 unsigned long scm_gc_times
= 0;
399 unsigned long scm_gc_cells_swept
= 0;
400 double scm_gc_cells_marked_acc
= 0.;
401 double scm_gc_cells_swept_acc
= 0.;
403 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
404 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
405 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
406 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
407 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
408 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
409 SCM_SYMBOL (sym_gc_mark_time_taken
, "gc-mark-time-taken");
410 SCM_SYMBOL (sym_gc_sweep_time_taken
, "gc-sweep-time-taken");
411 SCM_SYMBOL (sym_times
, "gc-times");
412 SCM_SYMBOL (sym_cells_marked
, "cells-marked");
413 SCM_SYMBOL (sym_cells_swept
, "cells-swept");
415 typedef struct scm_t_heap_seg_data
417 /* lower and upper bounds of the segment */
418 SCM_CELLPTR bounds
[2];
420 /* address of the head-of-freelist pointer for this segment's cells.
421 All segments usually point to the same one, scm_freelist. */
422 scm_t_freelist
*freelist
;
424 /* number of cells per object in this segment */
426 } scm_t_heap_seg_data
;
430 static size_t init_heap_seg (SCM_CELLPTR
, size_t, scm_t_freelist
*);
432 typedef enum { return_on_error
, abort_on_error
} policy_on_error
;
433 static void alloc_some_heap (scm_t_freelist
*, policy_on_error
);
436 #define SCM_HEAP_SIZE \
437 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
438 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
440 #define BVEC_GROW_SIZE 256
441 #define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE)
442 #define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_t_c_bvec_limb))
444 /* mark space allocation */
446 typedef struct scm_t_mark_space
448 scm_t_c_bvec_limb
*bvec_space
;
449 struct scm_t_mark_space
*next
;
452 static scm_t_mark_space
*current_mark_space
;
453 static scm_t_mark_space
**mark_space_ptr
;
454 static ptrdiff_t current_mark_space_offset
;
455 static scm_t_mark_space
*mark_space_head
;
457 static scm_t_c_bvec_limb
*
459 #define FUNC_NAME "get_bvec"
461 scm_t_c_bvec_limb
*res
;
463 if (!current_mark_space
)
465 SCM_SYSCALL (current_mark_space
= (scm_t_mark_space
*) malloc (sizeof (scm_t_mark_space
)));
466 if (!current_mark_space
)
467 SCM_MISC_ERROR ("could not grow heap", SCM_EOL
);
469 current_mark_space
->bvec_space
= NULL
;
470 current_mark_space
->next
= NULL
;
472 *mark_space_ptr
= current_mark_space
;
473 mark_space_ptr
= &(current_mark_space
->next
);
478 if (!(current_mark_space
->bvec_space
))
480 SCM_SYSCALL (current_mark_space
->bvec_space
=
481 (scm_t_c_bvec_limb
*) calloc (BVEC_GROW_SIZE_IN_BYTES
, 1));
482 if (!(current_mark_space
->bvec_space
))
483 SCM_MISC_ERROR ("could not grow heap", SCM_EOL
);
485 current_mark_space_offset
= 0;
490 if (current_mark_space_offset
== BVEC_GROW_SIZE_IN_LIMBS
)
492 current_mark_space
= NULL
;
497 res
= current_mark_space
->bvec_space
+ current_mark_space_offset
;
498 current_mark_space_offset
+= SCM_GC_CARD_BVEC_SIZE_IN_LIMBS
;
508 scm_t_mark_space
*ms
;
510 for (ms
= mark_space_head
; ms
; ms
= ms
->next
)
511 memset (ms
->bvec_space
, 0, BVEC_GROW_SIZE_IN_BYTES
);
516 /* Debugging functions. */
518 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
520 /* Return the number of the heap segment containing CELL. */
526 for (i
= 0; i
< scm_n_heap_segs
; i
++)
527 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
528 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
530 fprintf (stderr
, "which_seg: can't find segment containing cell %lux\n",
531 (unsigned long) SCM_UNPACK (cell
));
537 map_free_list (scm_t_freelist
*master
, SCM freelist
)
539 long last_seg
= -1, count
= 0;
542 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
))
544 long this_seg
= which_seg (f
);
546 if (this_seg
!= last_seg
)
549 fprintf (stderr
, " %5ld %d-cells in segment %ld\n",
550 (long) count
, master
->span
, (long) last_seg
);
557 fprintf (stderr
, " %5ld %d-cells in segment %ld\n",
558 (long) count
, master
->span
, (long) last_seg
);
561 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
563 "Print debugging information about the free-list.\n"
564 "@code{map-free-list} is only included in\n"
565 "@code{--enable-guile-debug} builds of Guile.")
566 #define FUNC_NAME s_scm_map_free_list
569 fprintf (stderr
, "%ld segments total (%d:%ld",
570 (long) scm_n_heap_segs
,
571 scm_heap_table
[0].span
,
572 (long) (scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]));
573 for (i
= 1; i
< scm_n_heap_segs
; i
++)
574 fprintf (stderr
, ", %d:%ld",
575 scm_heap_table
[i
].span
,
576 (long) (scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]));
577 fprintf (stderr
, ")\n");
578 map_free_list (&scm_master_freelist
, scm_freelist
);
579 map_free_list (&scm_master_freelist2
, scm_freelist2
);
582 return SCM_UNSPECIFIED
;
586 static long last_cluster
;
587 static long last_size
;
590 free_list_length (char *title
, long i
, SCM freelist
)
594 for (ls
= freelist
; !SCM_NULLP (ls
); ls
= SCM_FREE_CELL_CDR (ls
))
595 if (SCM_FREE_CELL_P (ls
))
599 fprintf (stderr
, "bad cell in %s at position %ld\n", title
, (long) n
);
606 if (last_cluster
== i
- 1)
607 fprintf (stderr
, "\t%ld\n", (long) last_size
);
609 fprintf (stderr
, "-%ld\t%ld\n", (long) (i
- 1), (long) last_size
);
612 fprintf (stderr
, "%s %ld", title
, (long) i
);
614 fprintf (stderr
, "%s\t%ld\n", title
, (long) n
);
622 free_list_lengths (char *title
, scm_t_freelist
*master
, SCM freelist
)
625 long i
= 0, len
, n
= 0;
626 fprintf (stderr
, "%s\n\n", title
);
627 n
+= free_list_length ("free list", -1, freelist
);
628 for (clusters
= master
->clusters
;
629 SCM_NNULLP (clusters
);
630 clusters
= SCM_CDR (clusters
))
632 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
635 if (last_cluster
== i
- 1)
636 fprintf (stderr
, "\t%ld\n", (long) last_size
);
638 fprintf (stderr
, "-%ld\t%ld\n", (long) (i
- 1), (long) last_size
);
639 fprintf (stderr
, "\ntotal %ld objects\n\n", (long) n
);
642 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
644 "Print debugging information about the free-list.\n"
645 "@code{free-list-length} is only included in\n"
646 "@code{--enable-guile-debug} builds of Guile.")
647 #define FUNC_NAME s_scm_free_list_length
649 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
650 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
651 return SCM_UNSPECIFIED
;
657 #ifdef GUILE_DEBUG_FREELIST
659 /* Non-zero if freelist debugging is in effect. Set this via
660 `gc-set-debug-check-freelist!'. */
661 static int scm_debug_check_freelist
= 0;
663 /* Number of calls to SCM_NEWCELL since startup. */
664 static unsigned long scm_newcell_count
;
665 static unsigned long scm_newcell2_count
;
667 /* Search freelist for anything that isn't marked as a free cell.
668 Abort if we find something. */
670 scm_check_freelist (SCM freelist
)
675 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
), i
++)
676 if (!SCM_FREE_CELL_P (f
))
678 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %lu'th elt\n",
679 (long) scm_newcell_count
, (long) i
);
684 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
686 "If @var{flag} is @code{#t}, check the freelist for consistency\n"
687 "on each cell allocation. This procedure only exists when the\n"
688 "@code{GUILE_DEBUG_FREELIST} compile-time flag was selected.")
689 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
691 /* [cmm] I did a double-take when I read this code the first time.
693 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
694 return SCM_UNSPECIFIED
;
700 scm_debug_newcell (void)
705 if (scm_debug_check_freelist
)
707 scm_check_freelist (scm_freelist
);
711 /* The rest of this is supposed to be identical to the SCM_NEWCELL
713 if (SCM_NULLP (scm_freelist
))
715 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
716 SCM_GC_SET_ALLOCATED (new);
721 scm_freelist
= SCM_FREE_CELL_CDR (scm_freelist
);
722 SCM_GC_SET_ALLOCATED (new);
729 scm_debug_newcell2 (void)
733 scm_newcell2_count
++;
734 if (scm_debug_check_freelist
)
736 scm_check_freelist (scm_freelist2
);
740 /* The rest of this is supposed to be identical to the SCM_NEWCELL
742 if (SCM_NULLP (scm_freelist2
))
744 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
745 SCM_GC_SET_ALLOCATED (new);
750 scm_freelist2
= SCM_FREE_CELL_CDR (scm_freelist2
);
751 SCM_GC_SET_ALLOCATED (new);
757 #endif /* GUILE_DEBUG_FREELIST */
762 master_cells_allocated (scm_t_freelist
*master
)
764 /* the '- 1' below is to ignore the cluster spine cells. */
765 long objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
766 if (SCM_NULLP (master
->clusters
))
767 objects
-= master
->left_to_collect
;
768 return master
->span
* objects
;
772 freelist_length (SCM freelist
)
775 for (n
= 0; !SCM_NULLP (freelist
); freelist
= SCM_FREE_CELL_CDR (freelist
))
781 compute_cells_allocated ()
783 return (scm_cells_allocated
784 + master_cells_allocated (&scm_master_freelist
)
785 + master_cells_allocated (&scm_master_freelist2
)
786 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
787 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
790 /* {Scheme Interface to GC}
793 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
795 "Return an association list of statistics about Guile's current\n"
797 #define FUNC_NAME s_scm_gc_stats
802 unsigned long int local_scm_mtrigger
;
803 unsigned long int local_scm_mallocated
;
804 unsigned long int local_scm_heap_size
;
805 unsigned long int local_scm_cells_allocated
;
806 unsigned long int local_scm_gc_time_taken
;
807 unsigned long int local_scm_gc_times
;
808 unsigned long int local_scm_gc_mark_time_taken
;
809 unsigned long int local_scm_gc_sweep_time_taken
;
810 double local_scm_gc_cells_swept
;
811 double local_scm_gc_cells_marked
;
821 for (i
= scm_n_heap_segs
; i
--; )
822 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
823 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
825 if (scm_n_heap_segs
!= n
)
830 /* Below, we cons to produce the resulting list. We want a snapshot of
831 * the heap situation before consing.
833 local_scm_mtrigger
= scm_mtrigger
;
834 local_scm_mallocated
= scm_mallocated
;
835 local_scm_heap_size
= SCM_HEAP_SIZE
;
836 local_scm_cells_allocated
= compute_cells_allocated ();
837 local_scm_gc_time_taken
= scm_gc_time_taken
;
838 local_scm_gc_mark_time_taken
= scm_gc_mark_time_taken
;
839 local_scm_gc_sweep_time_taken
= scm_gc_sweep_time_taken
;
840 local_scm_gc_times
= scm_gc_times
;
841 local_scm_gc_cells_swept
= scm_gc_cells_swept_acc
;
842 local_scm_gc_cells_marked
= scm_gc_cells_marked_acc
;
844 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
845 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
846 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
847 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
848 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
849 scm_cons (sym_times
, scm_ulong2num (local_scm_gc_times
)),
850 scm_cons (sym_gc_mark_time_taken
, scm_ulong2num (local_scm_gc_mark_time_taken
)),
851 scm_cons (sym_gc_sweep_time_taken
, scm_ulong2num (local_scm_gc_sweep_time_taken
)),
852 scm_cons (sym_cells_marked
, scm_i_dbl2big (local_scm_gc_cells_marked
)),
853 scm_cons (sym_cells_swept
, scm_i_dbl2big (local_scm_gc_cells_swept
)),
854 scm_cons (sym_heap_segments
, heap_segs
),
863 gc_start_stats (const char *what SCM_UNUSED
)
865 t_before_gc
= scm_c_get_internal_run_time ();
866 scm_gc_cells_swept
= 0;
867 scm_gc_cells_collected
= 0;
868 scm_gc_yield_1
= scm_gc_yield
;
869 scm_gc_yield
= (scm_cells_allocated
870 + master_cells_allocated (&scm_master_freelist
)
871 + master_cells_allocated (&scm_master_freelist2
));
872 scm_gc_malloc_collected
= 0;
873 scm_gc_ports_collected
= 0;
880 unsigned long t
= scm_c_get_internal_run_time ();
881 scm_gc_time_taken
+= (t
- t_before_gc
);
882 scm_gc_sweep_time_taken
+= (t
- t_before_sweep
);
885 scm_gc_cells_marked_acc
+= scm_gc_cells_swept
- scm_gc_cells_collected
;
886 scm_gc_cells_swept_acc
+= scm_gc_cells_swept
;
890 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
892 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
893 "returned by this function for @var{obj}")
894 #define FUNC_NAME s_scm_object_address
896 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
901 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
903 "Scans all of SCM objects and reclaims for further use those that are\n"
904 "no longer accessible.")
905 #define FUNC_NAME s_scm_gc
910 return SCM_UNSPECIFIED
;
916 /* {C Interface For When GC is Triggered}
920 adjust_min_yield (scm_t_freelist
*freelist
)
922 /* min yield is adjusted upwards so that next predicted total yield
923 * (allocated cells actually freed by GC) becomes
924 * `min_yield_fraction' of total heap size. Note, however, that
925 * the absolute value of min_yield will correspond to `collected'
926 * on one master (the one which currently is triggering GC).
928 * The reason why we look at total yield instead of cells collected
929 * on one list is that we want to take other freelists into account.
930 * On this freelist, we know that (local) yield = collected cells,
931 * but that's probably not the case on the other lists.
933 * (We might consider computing a better prediction, for example
934 * by computing an average over multiple GC:s.)
936 if (freelist
->min_yield_fraction
)
938 /* Pick largest of last two yields. */
939 long delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
940 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
942 fprintf (stderr
, " after GC = %lu, delta = %ld\n",
943 (long) scm_cells_allocated
,
947 freelist
->min_yield
+= delta
;
952 /* When we get POSIX threads support, the master will be global and
953 * common while the freelist will be individual for each thread.
957 scm_gc_for_newcell (scm_t_freelist
*master
, SCM
*freelist
)
963 if (SCM_NULLP (master
->clusters
))
965 if (master
->grow_heap_p
|| scm_block_gc
)
967 /* In order to reduce gc frequency, try to allocate a new heap
968 * segment first, even if gc might find some free cells. If we
969 * can't obtain a new heap segment, we will try gc later.
971 master
->grow_heap_p
= 0;
972 alloc_some_heap (master
, return_on_error
);
974 if (SCM_NULLP (master
->clusters
))
976 /* The heap was not grown, either because it wasn't scheduled to
977 * grow, or because there was not enough memory available. In
978 * both cases we have to try gc to get some free cells.
981 fprintf (stderr
, "allocated = %lu, ",
982 (long) (scm_cells_allocated
983 + master_cells_allocated (&scm_master_freelist
)
984 + master_cells_allocated (&scm_master_freelist2
)));
987 adjust_min_yield (master
);
988 if (SCM_NULLP (master
->clusters
))
990 /* gc could not free any cells. Now, we _must_ allocate a
991 * new heap segment, because there is no other possibility
992 * to provide a new cell for the caller.
994 alloc_some_heap (master
, abort_on_error
);
998 cell
= SCM_CAR (master
->clusters
);
999 master
->clusters
= SCM_CDR (master
->clusters
);
1000 ++master
->clusters_allocated
;
1002 while (SCM_NULLP (cell
));
1004 #ifdef GUILE_DEBUG_FREELIST
1005 scm_check_freelist (cell
);
1008 --scm_ints_disabled
;
1009 *freelist
= SCM_FREE_CELL_CDR (cell
);
1015 /* This is a support routine which can be used to reserve a cluster
1016 * for some special use, such as debugging. It won't be useful until
1017 * free cells are preserved between garbage collections.
1021 scm_alloc_cluster (scm_t_freelist
*master
)
1024 cell
= scm_gc_for_newcell (master
, &freelist
);
1025 SCM_SETCDR (cell
, freelist
);
1031 scm_t_c_hook scm_before_gc_c_hook
;
1032 scm_t_c_hook scm_before_mark_c_hook
;
1033 scm_t_c_hook scm_before_sweep_c_hook
;
1034 scm_t_c_hook scm_after_sweep_c_hook
;
1035 scm_t_c_hook scm_after_gc_c_hook
;
1039 scm_igc (const char *what
)
1044 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
1047 SCM_NULLP (scm_freelist
)
1049 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
1051 /* During the critical section, only the current thread may run. */
1052 SCM_CRITICAL_SECTION_START
;
1054 /* fprintf (stderr, "gc: %s\n", what); */
1056 if (!scm_stack_base
|| scm_block_gc
)
1062 gc_start_stats (what
);
1064 if (scm_gc_heap_lock
)
1065 /* We've invoked the collector while a GC is already in progress.
1066 That should never happen. */
1071 /* flush dead entries from the continuation stack */
1076 elts
= SCM_VELTS (scm_continuation_stack
);
1077 bound
= SCM_VECTOR_LENGTH (scm_continuation_stack
);
1078 x
= SCM_INUM (scm_continuation_stack_ptr
);
1081 elts
[x
] = SCM_BOOL_F
;
1086 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
1088 clear_mark_space ();
1092 /* Mark objects on the C stack. */
1093 SCM_FLUSH_REGISTER_WINDOWS
;
1094 /* This assumes that all registers are saved into the jmp_buf */
1095 setjmp (scm_save_regs_gc_mark
);
1096 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1097 ( (size_t) (sizeof (SCM_STACKITEM
) - 1 +
1098 sizeof scm_save_regs_gc_mark
)
1099 / sizeof (SCM_STACKITEM
)));
1102 unsigned long stack_len
= scm_stack_size (scm_stack_base
);
1103 #ifdef SCM_STACK_GROWS_UP
1104 scm_mark_locations (scm_stack_base
, stack_len
);
1106 scm_mark_locations (scm_stack_base
- stack_len
, stack_len
);
1110 #else /* USE_THREADS */
1112 /* Mark every thread's stack and registers */
1113 scm_threads_mark_stacks ();
1115 #endif /* USE_THREADS */
1117 j
= SCM_NUM_PROTECTS
;
1119 scm_gc_mark (scm_sys_protects
[j
]);
1121 /* mark the registered roots */
1124 for (i
= 0; i
< SCM_VECTOR_LENGTH (scm_gc_registered_roots
); ++i
) {
1125 SCM l
= SCM_VELTS (scm_gc_registered_roots
)[i
];
1126 for (; ! SCM_NULLP (l
); l
= SCM_CDR (l
)) {
1127 SCM
*p
= (SCM
*) (scm_num2long (SCM_CAAR (l
), 0, NULL
));
1133 /* FIXME: we should have a means to register C functions to be run
1134 * in different phases of GC
1136 scm_mark_subr_table ();
1139 scm_gc_mark (scm_root
->handle
);
1142 t_before_sweep
= scm_c_get_internal_run_time ();
1143 scm_gc_mark_time_taken
+= (t_before_sweep
- t_before_gc
);
1145 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
1149 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
1154 SCM_CRITICAL_SECTION_END
;
1155 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
1164 #define MARK scm_gc_mark
1165 #define FNAME "scm_gc_mark"
1167 #endif /*!MARK_DEPENDENCIES*/
1169 /* Mark an object precisely.
1173 #define FUNC_NAME FNAME
1177 scm_t_bits cell_type
;
1179 #ifndef MARK_DEPENDENCIES
1180 # define RECURSE scm_gc_mark
1182 /* go through the usual marking, but not for self-cycles. */
1183 # define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0)
1187 #ifdef MARK_DEPENDENCIES
1188 goto gc_mark_loop_first_time
;
1191 /* A simple hack for debugging. Chose the second branch to get a
1192 meaningful backtrace for crashes inside the GC.
1195 #define goto_gc_mark_loop goto gc_mark_loop
1196 #define goto_gc_mark_nimp goto gc_mark_nimp
1198 #define goto_gc_mark_loop RECURSE(ptr); return
1199 #define goto_gc_mark_nimp RECURSE(ptr); return
1208 #ifdef MARK_DEPENDENCIES
1209 if (SCM_EQ_P (ptr
, p
))
1215 gc_mark_loop_first_time
:
1218 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1219 /* We are in debug mode. Check the ptr exhaustively. */
1220 if (!scm_cellp (ptr
))
1221 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1223 /* In non-debug mode, do at least some cheap testing. */
1224 if (!SCM_CELLP (ptr
))
1225 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1228 #ifndef MARK_DEPENDENCIES
1230 if (SCM_GCMARKP (ptr
))
1233 SCM_SETGCMARK (ptr
);
1237 cell_type
= SCM_GC_CELL_TYPE (ptr
);
1238 switch (SCM_ITAG7 (cell_type
))
1240 case scm_tcs_cons_nimcar
:
1241 if (SCM_IMP (SCM_CDR (ptr
)))
1243 ptr
= SCM_CAR (ptr
);
1246 RECURSE (SCM_CAR (ptr
));
1247 ptr
= SCM_CDR (ptr
);
1249 case scm_tcs_cons_imcar
:
1250 ptr
= SCM_CDR (ptr
);
1253 RECURSE (SCM_SETTER (ptr
));
1254 ptr
= SCM_PROCEDURE (ptr
);
1256 case scm_tcs_cons_gloc
:
1258 /* Dirk:FIXME:: The following code is super ugly: ptr may be a
1259 * struct or a gloc. If it is a gloc, the cell word #0 of ptr
1260 * is the address of a scm_tc16_variable smob. If it is a
1261 * struct, the cell word #0 of ptr is a pointer to a struct
1262 * vtable data region. (The fact that these are accessed in
1263 * the same way restricts the possibilites to change the data
1264 * layout of structs or heap cells.) To discriminate between
1265 * the two, it is guaranteed that the scm_vtable_index_vcell
1266 * element of the prospective vtable is always zero. For a
1267 * gloc, this location has the CDR of the variable smob, which
1268 * is guaranteed to be non-zero.
1270 scm_t_bits word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
1271 scm_t_bits
* vtable_data
= (scm_t_bits
*) word0
; /* access as struct */
1272 if (vtable_data
[scm_vtable_index_vcell
] != 0)
1275 SCM gloc_car
= SCM_PACK (word0
);
1277 ptr
= SCM_CDR (ptr
);
1282 /* ptr is a struct */
1283 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
1284 long len
= SCM_SYMBOL_LENGTH (layout
);
1285 char * fields_desc
= SCM_SYMBOL_CHARS (layout
);
1286 scm_t_bits
* struct_data
= (scm_t_bits
*) SCM_STRUCT_DATA (ptr
);
1288 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
1290 RECURSE (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
1291 RECURSE (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1297 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1298 if (fields_desc
[x
] == 'p')
1299 RECURSE (SCM_PACK (*struct_data
));
1300 if (fields_desc
[x
] == 'p')
1302 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1303 for (x
= *struct_data
++; x
; --x
, ++struct_data
)
1304 RECURSE (SCM_PACK (*struct_data
));
1306 RECURSE (SCM_PACK (*struct_data
));
1310 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1315 case scm_tcs_closures
:
1316 if (SCM_IMP (SCM_ENV (ptr
)))
1318 ptr
= SCM_CLOSCAR (ptr
);
1321 RECURSE (SCM_CLOSCAR (ptr
));
1322 ptr
= SCM_ENV (ptr
);
1324 case scm_tc7_vector
:
1325 i
= SCM_VECTOR_LENGTH (ptr
);
1329 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1330 RECURSE (SCM_VELTS (ptr
)[i
]);
1331 ptr
= SCM_VELTS (ptr
)[0];
1336 size_t i
= SCM_CCLO_LENGTH (ptr
);
1338 for (j
= 1; j
!= i
; ++j
)
1340 SCM obj
= SCM_CCLO_REF (ptr
, j
);
1344 ptr
= SCM_CCLO_REF (ptr
, 0);
1350 case scm_tc7_byvect
:
1357 #ifdef HAVE_LONG_LONGS
1358 case scm_tc7_llvect
:
1361 case scm_tc7_string
:
1364 case scm_tc7_substring
:
1365 ptr
= SCM_CDR (ptr
);
1369 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1370 scm_weak_vectors
= ptr
;
1371 if (SCM_IS_WHVEC_ANY (ptr
))
1378 len
= SCM_VECTOR_LENGTH (ptr
);
1379 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1380 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1382 for (x
= 0; x
< len
; ++x
)
1385 alist
= SCM_VELTS (ptr
)[x
];
1387 /* mark everything on the alist except the keys or
1388 * values, according to weak_values and weak_keys. */
1389 while ( SCM_CONSP (alist
)
1390 && !SCM_GCMARKP (alist
)
1391 && SCM_CONSP (SCM_CAR (alist
)))
1396 kvpair
= SCM_CAR (alist
);
1397 next_alist
= SCM_CDR (alist
);
1400 * SCM_SETGCMARK (alist);
1401 * SCM_SETGCMARK (kvpair);
1403 * It may be that either the key or value is protected by
1404 * an escaped reference to part of the spine of this alist.
1405 * If we mark the spine here, and only mark one or neither of the
1406 * key and value, they may never be properly marked.
1407 * This leads to a horrible situation in which an alist containing
1408 * freelist cells is exported.
1410 * So only mark the spines of these arrays last of all marking.
1411 * If somebody confuses us by constructing a weak vector
1412 * with a circular alist then we are hosed, but at least we
1413 * won't prematurely drop table entries.
1416 RECURSE (SCM_CAR (kvpair
));
1418 RECURSE (SCM_CDR (kvpair
));
1421 if (SCM_NIMP (alist
))
1427 case scm_tc7_symbol
:
1428 ptr
= SCM_PROP_SLOTS (ptr
);
1433 i
= SCM_PTOBNUM (ptr
);
1434 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1435 if (!(i
< scm_numptob
))
1436 SCM_MISC_ERROR ("undefined port type", SCM_EOL
);
1438 if (SCM_PTAB_ENTRY(ptr
))
1439 RECURSE (SCM_FILENAME (ptr
));
1440 if (scm_ptobs
[i
].mark
)
1442 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1449 switch (SCM_TYP16 (ptr
))
1450 { /* should be faster than going through scm_smobs */
1451 case scm_tc_free_cell
:
1452 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1455 case scm_tc16_complex
:
1458 i
= SCM_SMOBNUM (ptr
);
1459 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1460 if (!(i
< scm_numsmob
))
1461 SCM_MISC_ERROR ("undefined smob type", SCM_EOL
);
1463 if (scm_smobs
[i
].mark
)
1465 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1473 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1479 #ifndef MARK_DEPENDENCIES
1484 /* And here we define `scm_gc_mark_dependencies', by including this
1485 * same file in itself.
1487 #define MARK scm_gc_mark_dependencies
1488 #define FNAME "scm_gc_mark_dependencies"
1489 #define MARK_DEPENDENCIES
1491 #undef MARK_DEPENDENCIES
1496 /* Mark a Region Conservatively
1500 scm_mark_locations (SCM_STACKITEM x
[], unsigned long n
)
1504 for (m
= 0; m
< n
; ++m
)
1506 SCM obj
= * (SCM
*) &x
[m
];
1507 if (SCM_CELLP (obj
))
1509 SCM_CELLPTR ptr
= SCM2PTR (obj
);
1511 long j
= scm_n_heap_segs
- 1;
1512 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1513 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1520 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1522 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1530 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1534 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1539 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1543 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1550 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1553 if (scm_heap_table
[seg_id
].span
== 1
1554 || DOUBLECELL_ALIGNED_P (obj
))
1565 /* The function scm_cellp determines whether an SCM value can be regarded as a
1566 * pointer to a cell on the heap. Binary search is used in order to determine
1567 * the heap segment that contains the cell.
1570 scm_cellp (SCM value
)
1572 if (SCM_CELLP (value
)) {
1573 scm_cell
* ptr
= SCM2PTR (value
);
1574 unsigned long i
= 0;
1575 unsigned long j
= scm_n_heap_segs
- 1;
1577 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1581 long k
= (i
+ j
) / 2;
1582 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
)) {
1584 } else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
)) {
1589 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1590 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
)
1591 && (scm_heap_table
[i
].span
== 1 || DOUBLECELL_ALIGNED_P (value
))
1592 && !SCM_GC_IN_CARD_HEADERP (ptr
)
1603 gc_sweep_freelist_start (scm_t_freelist
*freelist
)
1605 freelist
->cells
= SCM_EOL
;
1606 freelist
->left_to_collect
= freelist
->cluster_size
;
1607 freelist
->clusters_allocated
= 0;
1608 freelist
->clusters
= SCM_EOL
;
1609 freelist
->clustertail
= &freelist
->clusters
;
1610 freelist
->collected_1
= freelist
->collected
;
1611 freelist
->collected
= 0;
1615 gc_sweep_freelist_finish (scm_t_freelist
*freelist
)
1618 *freelist
->clustertail
= freelist
->cells
;
1619 if (!SCM_NULLP (freelist
->cells
))
1621 SCM c
= freelist
->cells
;
1622 SCM_SET_CELL_WORD_0 (c
, SCM_FREE_CELL_CDR (c
));
1623 SCM_SET_CELL_WORD_1 (c
, SCM_EOL
);
1624 freelist
->collected
+=
1625 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1627 scm_gc_cells_collected
+= freelist
->collected
;
1629 /* Although freelist->min_yield is used to test freelist->collected
1630 * (which is the local GC yield for freelist), it is adjusted so
1631 * that *total* yield is freelist->min_yield_fraction of total heap
1632 * size. This means that a too low yield is compensated by more
1633 * heap on the list which is currently doing most work, which is
1634 * just what we want.
1636 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1637 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1640 #define NEXT_DATA_CELL(ptr, span) \
1642 scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \
1643 (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \
1644 CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \
1650 #define FUNC_NAME "scm_gc_sweep"
1652 register SCM_CELLPTR ptr
;
1653 register SCM nfreelist
;
1654 register scm_t_freelist
*freelist
;
1655 register unsigned long m
;
1662 gc_sweep_freelist_start (&scm_master_freelist
);
1663 gc_sweep_freelist_start (&scm_master_freelist2
);
1665 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1667 register long left_to_collect
;
1670 /* Unmarked cells go onto the front of the freelist this heap
1671 segment points to. Rather than updating the real freelist
1672 pointer as we go along, we accumulate the new head in
1673 nfreelist. Then, if it turns out that the entire segment is
1674 free, we free (i.e., malloc's free) the whole segment, and
1675 simply don't assign nfreelist back into the real freelist. */
1676 freelist
= scm_heap_table
[i
].freelist
;
1677 nfreelist
= freelist
->cells
;
1678 left_to_collect
= freelist
->left_to_collect
;
1679 span
= scm_heap_table
[i
].span
;
1681 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1682 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1684 /* use only data cells in seg_size */
1685 seg_size
= (seg_size
/ SCM_GC_CARD_N_CELLS
) * (SCM_GC_CARD_N_DATA_CELLS
/ span
) * span
;
1687 scm_gc_cells_swept
+= seg_size
;
1689 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1693 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1699 NEXT_DATA_CELL (nxt
, span
);
1706 scmptr
= PTR2SCM (ptr
);
1708 if (SCM_GCMARKP (scmptr
))
1711 switch SCM_TYP7 (scmptr
)
1713 case scm_tcs_cons_gloc
:
1715 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1716 * struct or a gloc. See the corresponding comment in
1719 scm_t_bits word0
= (SCM_CELL_WORD_0 (scmptr
)
1720 - scm_tc3_cons_gloc
);
1721 /* access as struct */
1722 scm_t_bits
* vtable_data
= (scm_t_bits
*) word0
;
1723 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1725 /* Structs need to be freed in a special order.
1726 * This is handled by GC C hooks in struct.c.
1728 SCM_SET_STRUCT_GC_CHAIN (scmptr
, scm_structs_to_free
);
1729 scm_structs_to_free
= scmptr
;
1732 /* fall through so that scmptr gets collected */
1735 case scm_tcs_cons_imcar
:
1736 case scm_tcs_cons_nimcar
:
1737 case scm_tcs_closures
:
1741 m
+= (2 + SCM_VECTOR_LENGTH (scmptr
)) * sizeof (SCM
);
1742 scm_must_free (SCM_VECTOR_BASE (scmptr
) - 2);
1744 case scm_tc7_vector
:
1746 unsigned long int length
= SCM_VECTOR_LENGTH (scmptr
);
1749 m
+= length
* sizeof (scm_t_bits
);
1750 scm_must_free (SCM_VECTOR_BASE (scmptr
));
1756 m
+= (SCM_CCLO_LENGTH (scmptr
) * sizeof (SCM
));
1757 scm_must_free (SCM_CCLO_BASE (scmptr
));
1763 unsigned long int length
= SCM_BITVECTOR_LENGTH (scmptr
);
1766 m
+= sizeof (long) * ((length
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1767 scm_must_free (SCM_BITVECTOR_BASE (scmptr
));
1771 case scm_tc7_byvect
:
1775 #ifdef HAVE_LONG_LONGS
1776 case scm_tc7_llvect
:
1781 m
+= SCM_UVECTOR_LENGTH (scmptr
) * scm_uniform_element_size (scmptr
);
1782 scm_must_free (SCM_UVECTOR_BASE (scmptr
));
1785 case scm_tc7_substring
:
1787 case scm_tc7_string
:
1788 m
+= SCM_STRING_LENGTH (scmptr
) + 1;
1789 scm_must_free (SCM_STRING_CHARS (scmptr
));
1791 case scm_tc7_symbol
:
1792 m
+= SCM_SYMBOL_LENGTH (scmptr
) + 1;
1793 scm_must_free (SCM_SYMBOL_CHARS (scmptr
));
1796 /* the various "subrs" (primitives) are never freed */
1799 if SCM_OPENP (scmptr
)
1801 int k
= SCM_PTOBNUM (scmptr
);
1802 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1803 if (!(k
< scm_numptob
))
1804 SCM_MISC_ERROR ("undefined port type", SCM_EOL
);
1806 /* Keep "revealed" ports alive. */
1807 if (scm_revealed_count (scmptr
) > 0)
1809 /* Yes, I really do mean scm_ptobs[k].free */
1810 /* rather than ftobs[k].close. .close */
1811 /* is for explicit CLOSE-PORT by user */
1812 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1813 SCM_SETSTREAM (scmptr
, 0);
1814 scm_remove_from_port_table (scmptr
);
1815 scm_gc_ports_collected
++;
1816 SCM_CLR_PORT_OPEN_FLAG (scmptr
);
1820 switch SCM_TYP16 (scmptr
)
1822 case scm_tc_free_cell
:
1827 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1828 scm_must_free (SCM_BDIGITS (scmptr
));
1830 #endif /* def SCM_BIGDIG */
1831 case scm_tc16_complex
:
1832 m
+= sizeof (scm_t_complex
);
1833 scm_must_free (SCM_COMPLEX_MEM (scmptr
));
1838 k
= SCM_SMOBNUM (scmptr
);
1839 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1840 if (!(k
< scm_numsmob
))
1841 SCM_MISC_ERROR ("undefined smob type", SCM_EOL
);
1843 if (scm_smobs
[k
].free
)
1844 m
+= (scm_smobs
[k
].free
) (scmptr
);
1850 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1853 if (!--left_to_collect
)
1855 SCM_SET_CELL_WORD_0 (scmptr
, nfreelist
);
1856 *freelist
->clustertail
= scmptr
;
1857 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1859 nfreelist
= SCM_EOL
;
1860 freelist
->collected
+= span
* freelist
->cluster_size
;
1861 left_to_collect
= freelist
->cluster_size
;
1865 /* Stick the new cell on the front of nfreelist. It's
1866 critical that we mark this cell as freed; otherwise, the
1867 conservative collector might trace it as some other type
1869 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1870 SCM_SET_FREE_CELL_CDR (scmptr
, nfreelist
);
1875 #ifdef GC_FREE_SEGMENTS
1880 freelist
->heap_size
-= seg_size
;
1881 free ((char *) scm_heap_table
[i
].bounds
[0]);
1882 scm_heap_table
[i
].bounds
[0] = 0;
1883 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1884 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1885 scm_n_heap_segs
-= 1;
1886 i
--; /* We need to scan the segment just moved. */
1889 #endif /* ifdef GC_FREE_SEGMENTS */
1891 /* Update the real freelist pointer to point to the head of
1892 the list of free cells we've built for this segment. */
1893 freelist
->cells
= nfreelist
;
1894 freelist
->left_to_collect
= left_to_collect
;
1897 #ifdef GUILE_DEBUG_FREELIST
1898 scm_map_free_list ();
1902 gc_sweep_freelist_finish (&scm_master_freelist
);
1903 gc_sweep_freelist_finish (&scm_master_freelist2
);
1905 /* When we move to POSIX threads private freelists should probably
1906 be GC-protected instead. */
1907 scm_freelist
= SCM_EOL
;
1908 scm_freelist2
= SCM_EOL
;
1910 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1911 scm_gc_yield
-= scm_cells_allocated
;
1913 if (scm_mallocated
< m
)
1914 /* The byte count of allocated objects has underflowed. This is
1915 probably because you forgot to report the sizes of objects you
1916 have allocated, by calling scm_done_malloc or some such. When
1917 the GC freed them, it subtracted their size from
1918 scm_mallocated, which underflowed. */
1921 scm_mallocated
-= m
;
1922 scm_gc_malloc_collected
= m
;
1928 /* {Front end to malloc}
1930 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
1933 * These functions provide services comparable to malloc, realloc, and
1934 * free. They should be used when allocating memory that will be under
1935 * control of the garbage collector, i.e., if the memory may be freed
1936 * during garbage collection.
1940 * Return newly malloced storage or throw an error.
1942 * The parameter WHAT is a string for error reporting.
1943 * If the threshold scm_mtrigger will be passed by this
1944 * allocation, or if the first call to malloc fails,
1945 * garbage collect -- on the presumption that some objects
1946 * using malloced storage may be collected.
1948 * The limit scm_mtrigger may be raised by this allocation.
1951 scm_must_malloc (size_t size
, const char *what
)
1954 unsigned long nm
= scm_mallocated
+ size
;
1957 /* The byte count of allocated objects has overflowed. This is
1958 probably because you forgot to report the correct size of freed
1959 memory in some of your smob free methods. */
1962 if (nm
<= scm_mtrigger
)
1964 SCM_SYSCALL (ptr
= malloc (size
));
1967 scm_mallocated
= nm
;
1968 #ifdef GUILE_DEBUG_MALLOC
1969 scm_malloc_register (ptr
, what
);
1977 nm
= scm_mallocated
+ size
;
1980 /* The byte count of allocated objects has overflowed. This is
1981 probably because you forgot to report the correct size of freed
1982 memory in some of your smob free methods. */
1985 SCM_SYSCALL (ptr
= malloc (size
));
1988 scm_mallocated
= nm
;
1989 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1990 if (nm
> scm_mtrigger
)
1991 scm_mtrigger
= nm
+ nm
/ 2;
1993 scm_mtrigger
+= scm_mtrigger
/ 2;
1995 #ifdef GUILE_DEBUG_MALLOC
1996 scm_malloc_register (ptr
, what
);
2002 scm_memory_error (what
);
2007 * is similar to scm_must_malloc.
2010 scm_must_realloc (void *where
,
2018 if (size
<= old_size
)
2021 nm
= scm_mallocated
+ size
- old_size
;
2023 if (nm
< (size
- old_size
))
2024 /* The byte count of allocated objects has overflowed. This is
2025 probably because you forgot to report the correct size of freed
2026 memory in some of your smob free methods. */
2029 if (nm
<= scm_mtrigger
)
2031 SCM_SYSCALL (ptr
= realloc (where
, size
));
2034 scm_mallocated
= nm
;
2035 #ifdef GUILE_DEBUG_MALLOC
2036 scm_malloc_reregister (where
, ptr
, what
);
2044 nm
= scm_mallocated
+ size
- old_size
;
2046 if (nm
< (size
- old_size
))
2047 /* The byte count of allocated objects has overflowed. This is
2048 probably because you forgot to report the correct size of freed
2049 memory in some of your smob free methods. */
2052 SCM_SYSCALL (ptr
= realloc (where
, size
));
2055 scm_mallocated
= nm
;
2056 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2057 if (nm
> scm_mtrigger
)
2058 scm_mtrigger
= nm
+ nm
/ 2;
2060 scm_mtrigger
+= scm_mtrigger
/ 2;
2062 #ifdef GUILE_DEBUG_MALLOC
2063 scm_malloc_reregister (where
, ptr
, what
);
2068 scm_memory_error (what
);
2072 scm_must_strndup (const char *str
, size_t length
)
2074 char * dst
= scm_must_malloc (length
+ 1, "scm_must_strndup");
2075 memcpy (dst
, str
, length
);
2081 scm_must_strdup (const char *str
)
2083 return scm_must_strndup (str
, strlen (str
));
2087 scm_must_free (void *obj
)
2088 #define FUNC_NAME "scm_must_free"
2090 #ifdef GUILE_DEBUG_MALLOC
2091 scm_malloc_unregister (obj
);
2096 SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL
);
2101 /* Announce that there has been some malloc done that will be freed
2102 * during gc. A typical use is for a smob that uses some malloced
2103 * memory but can not get it from scm_must_malloc (for whatever
2104 * reason). When a new object of this smob is created you call
2105 * scm_done_malloc with the size of the object. When your smob free
2106 * function is called, be sure to include this size in the return
2109 * If you can't actually free the memory in the smob free function,
2110 * for whatever reason (like reference counting), you still can (and
2111 * should) report the amount of memory freed when you actually free it.
2112 * Do it by calling scm_done_malloc with the _negated_ size. Clever,
2113 * eh? Or even better, call scm_done_free. */
2116 scm_done_malloc (long size
)
2119 if (scm_mallocated
< size
)
2120 /* The byte count of allocated objects has underflowed. This is
2121 probably because you forgot to report the sizes of objects you
2122 have allocated, by calling scm_done_malloc or some such. When
2123 the GC freed them, it subtracted their size from
2124 scm_mallocated, which underflowed. */
2127 unsigned long nm
= scm_mallocated
+ size
;
2129 /* The byte count of allocated objects has overflowed. This is
2130 probably because you forgot to report the correct size of freed
2131 memory in some of your smob free methods. */
2135 scm_mallocated
+= size
;
2137 if (scm_mallocated
> scm_mtrigger
)
2139 scm_igc ("foreign mallocs");
2140 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
2142 if (scm_mallocated
> scm_mtrigger
)
2143 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
2145 scm_mtrigger
+= scm_mtrigger
/ 2;
2151 scm_done_free (long size
)
2154 if (scm_mallocated
< size
)
2155 /* The byte count of allocated objects has underflowed. This is
2156 probably because you forgot to report the sizes of objects you
2157 have allocated, by calling scm_done_malloc or some such. When
2158 the GC freed them, it subtracted their size from
2159 scm_mallocated, which underflowed. */
2162 unsigned long nm
= scm_mallocated
+ size
;
2164 /* The byte count of allocated objects has overflowed. This is
2165 probably because you forgot to report the correct size of freed
2166 memory in some of your smob free methods. */
2170 scm_mallocated
-= size
;
2177 * Each heap segment is an array of objects of a particular size.
2178 * Every segment has an associated (possibly shared) freelist.
2179 * A table of segment records is kept that records the upper and
2180 * lower extents of the segment; this is used during the conservative
2181 * phase of gc to identify probably gc roots (because they point
2182 * into valid segments at reasonable offsets). */
2185 * is true if the first segment was smaller than INIT_HEAP_SEG.
2186 * If scm_expmem is set to one, subsequent segment allocations will
2187 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
2191 size_t scm_max_segment_size
;
2194 * is the lowest base address of any heap segment.
2196 SCM_CELLPTR scm_heap_org
;
2198 scm_t_heap_seg_data
* scm_heap_table
= 0;
2199 static size_t heap_segment_table_size
= 0;
2200 size_t scm_n_heap_segs
= 0;
2203 * initializes a new heap segment and returns the number of objects it contains.
2205 * The segment origin and segment size in bytes are input parameters.
2206 * The freelist is both input and output.
2208 * This function presumes that the scm_heap_table has already been expanded
2209 * to accomodate a new segment record and that the markbit space was reserved
2210 * for all the cards in this segment.
2213 #define INIT_CARD(card, span) \
2215 SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \
2217 SCM_GC_SET_CARD_DOUBLECELL (card); \
2221 init_heap_seg (SCM_CELLPTR seg_org
, size_t size
, scm_t_freelist
*freelist
)
2223 register SCM_CELLPTR ptr
;
2224 SCM_CELLPTR seg_end
;
2226 ptrdiff_t n_new_cells
;
2227 int span
= freelist
->span
;
2229 if (seg_org
== NULL
)
2232 /* Align the begin ptr up.
2234 ptr
= SCM_GC_CARD_UP (seg_org
);
2236 /* Compute the ceiling on valid object pointers w/in this segment.
2238 seg_end
= SCM_GC_CARD_DOWN ((char *)seg_org
+ size
);
2240 /* Find the right place and insert the segment record.
2243 for (new_seg_index
= 0;
2244 ( (new_seg_index
< scm_n_heap_segs
)
2245 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2251 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2252 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2257 scm_heap_table
[new_seg_index
].span
= span
;
2258 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2259 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
2260 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
2263 n_new_cells
= seg_end
- ptr
;
2265 freelist
->heap_size
+= n_new_cells
;
2267 /* Partition objects in this segment into clusters */
2270 SCM
*clusterp
= &clusters
;
2272 NEXT_DATA_CELL (ptr
, span
);
2273 while (ptr
< seg_end
)
2275 scm_cell
*nxt
= ptr
;
2276 scm_cell
*prv
= NULL
;
2277 scm_cell
*last_card
= NULL
;
2278 int n_data_cells
= (SCM_GC_CARD_N_DATA_CELLS
/ span
) * SCM_CARDS_PER_CLUSTER
- 1;
2279 NEXT_DATA_CELL(nxt
, span
);
2281 /* Allocate cluster spine
2283 *clusterp
= PTR2SCM (ptr
);
2284 SCM_SETCAR (*clusterp
, PTR2SCM (nxt
));
2285 clusterp
= SCM_CDRLOC (*clusterp
);
2288 while (n_data_cells
--)
2290 scm_cell
*card
= SCM_GC_CELL_CARD (ptr
);
2291 SCM scmptr
= PTR2SCM (ptr
);
2293 NEXT_DATA_CELL (nxt
, span
);
2296 if (card
!= last_card
)
2298 INIT_CARD (card
, span
);
2302 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
2303 SCM_SET_FREE_CELL_CDR (scmptr
, PTR2SCM (nxt
));
2308 SCM_SET_FREE_CELL_CDR (PTR2SCM (prv
), SCM_EOL
);
2313 scm_cell
*ref
= seg_end
;
2314 NEXT_DATA_CELL (ref
, span
);
2316 /* [cmm] looks like the segment size doesn't divide cleanly by
2317 cluster size. bad cmm! */
2321 /* Patch up the last cluster pointer in the segment
2322 * to join it to the input freelist.
2324 *clusterp
= freelist
->clusters
;
2325 freelist
->clusters
= clusters
;
2329 fprintf (stderr
, "H");
2335 round_to_cluster_size (scm_t_freelist
*freelist
, size_t len
)
2337 size_t cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2340 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2341 + ALIGNMENT_SLACK (freelist
);
2345 alloc_some_heap (scm_t_freelist
*freelist
, policy_on_error error_policy
)
2346 #define FUNC_NAME "alloc_some_heap"
2351 if (scm_gc_heap_lock
)
2353 /* Critical code sections (such as the garbage collector) aren't
2354 * supposed to add heap segments.
2356 fprintf (stderr
, "alloc_some_heap: Can not extend locked heap.\n");
2360 if (scm_n_heap_segs
== heap_segment_table_size
)
2362 /* We have to expand the heap segment table to have room for the new
2363 * segment. Do not yet increment scm_n_heap_segs -- that is done by
2364 * init_heap_seg only if the allocation of the segment itself succeeds.
2366 size_t new_table_size
= scm_n_heap_segs
+ 1;
2367 size_t size
= new_table_size
* sizeof (scm_t_heap_seg_data
);
2368 scm_t_heap_seg_data
*new_heap_table
;
2370 SCM_SYSCALL (new_heap_table
= ((scm_t_heap_seg_data
*)
2371 realloc ((char *)scm_heap_table
, size
)));
2372 if (!new_heap_table
)
2374 if (error_policy
== abort_on_error
)
2376 fprintf (stderr
, "alloc_some_heap: Could not grow heap segment table.\n");
2386 scm_heap_table
= new_heap_table
;
2387 heap_segment_table_size
= new_table_size
;
2391 /* Pick a size for the new heap segment.
2392 * The rule for picking the size of a segment is explained in
2396 /* Assure that the new segment is predicted to be large enough.
2398 * New yield should at least equal GC fraction of new heap size, i.e.
2400 * y + dh > f * (h + dh)
2403 * f : min yield fraction
2405 * dh : size of new heap segment
2407 * This gives dh > (f * h - y) / (1 - f)
2409 int f
= freelist
->min_yield_fraction
;
2410 unsigned long h
= SCM_HEAP_SIZE
;
2411 size_t min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2412 len
= SCM_EXPHEAP (freelist
->heap_size
);
2414 fprintf (stderr
, "(%ld < %ld)", (long) len
, (long) min_cells
);
2416 if (len
< min_cells
)
2417 len
= min_cells
+ freelist
->cluster_size
;
2418 len
*= sizeof (scm_cell
);
2419 /* force new sampling */
2420 freelist
->collected
= LONG_MAX
;
2423 if (len
> scm_max_segment_size
)
2424 len
= scm_max_segment_size
;
2429 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2434 /* Allocate with decaying ambition. */
2435 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2436 && (len
>= smallest
))
2438 size_t rounded_len
= round_to_cluster_size (freelist
, len
);
2439 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2442 init_heap_seg (ptr
, rounded_len
, freelist
);
2449 if (error_policy
== abort_on_error
)
2451 fprintf (stderr
, "alloc_some_heap: Could not grow heap.\n");
2458 /* {GC Protection Helper Functions}
2463 * If within a function you need to protect one or more scheme objects from
2464 * garbage collection, pass them as parameters to one of the
2465 * scm_remember_upto_here* functions below. These functions don't do
2466 * anything, but since the compiler does not know that they are actually
2467 * no-ops, it will generate code that calls these functions with the given
2468 * parameters. Therefore, you can be sure that the compiler will keep those
2469 * scheme values alive (on the stack or in a register) up to the point where
2470 * scm_remember_upto_here* is called. In other words, place the call to
2471 * scm_remember_upt_here* _behind_ the last code in your function, that
2472 * depends on the scheme object to exist.
2474 * Example: We want to make sure, that the string object str does not get
2475 * garbage collected during the execution of 'some_function', because
2476 * otherwise the characters belonging to str would be freed and
2477 * 'some_function' might access freed memory. To make sure that the compiler
2478 * keeps str alive on the stack or in a register such that it is visible to
2479 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
2480 * call to 'some_function'. Note that this would not be necessary if str was
2481 * used anyway after the call to 'some_function'.
2482 * char *chars = SCM_STRING_CHARS (str);
2483 * some_function (chars);
2484 * scm_remember_upto_here_1 (str); // str will be alive up to this point.
2488 scm_remember_upto_here_1 (SCM obj SCM_UNUSED
)
2490 /* Empty. Protects a single object from garbage collection. */
2494 scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED
, SCM obj2 SCM_UNUSED
)
2496 /* Empty. Protects two objects from garbage collection. */
2500 scm_remember_upto_here (SCM obj SCM_UNUSED
, ...)
2502 /* Empty. Protects any number of objects from garbage collection. */
2506 #if (SCM_DEBUG_DEPRECATED == 0)
2509 scm_remember (SCM
*ptr
)
2511 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
2512 "Use the `scm_remember_upto_here*' family of functions instead.");
2516 scm_protect_object (SCM obj
)
2518 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
2519 "Use `scm_gc_protect_object' instead.");
2520 return scm_gc_protect_object (obj
);
2524 scm_unprotect_object (SCM obj
)
2526 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
2527 "Use `scm_gc_unprotect_object' instead.");
2528 return scm_gc_unprotect_object (obj
);
2531 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2534 These crazy functions prevent garbage collection
2535 of arguments after the first argument by
2536 ensuring they remain live throughout the
2537 function because they are used in the last
2538 line of the code block.
2539 It'd be better to have a nice compiler hint to
2540 aid the conservative stack-scanning GC. --03/09/00 gjb */
2542 scm_return_first (SCM elt
, ...)
2548 scm_return_first_int (int i
, ...)
2555 scm_permanent_object (SCM obj
)
2558 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2564 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
2565 other references are dropped, until the object is unprotected by calling
2566 scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
2567 i. e. it is possible to protect the same object several times, but it is
2568 necessary to unprotect the object the same number of times to actually get
2569 the object unprotected. It is an error to unprotect an object more often
2570 than it has been protected before. The function scm_protect_object returns
2574 /* Implementation note: For every object X, there is a counter which
2575 scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
2579 scm_gc_protect_object (SCM obj
)
2583 /* This critical section barrier will be replaced by a mutex. */
2586 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, SCM_MAKINUM (0));
2587 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), SCM_MAKINUM (1)));
2595 /* Remove any protection for OBJ established by a prior call to
2596 scm_protect_object. This function returns OBJ.
2598 See scm_protect_object for more information. */
2600 scm_gc_unprotect_object (SCM obj
)
2604 /* This critical section barrier will be replaced by a mutex. */
2607 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2609 if (SCM_FALSEP (handle
))
2611 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
2616 SCM count
= scm_difference (SCM_CDR (handle
), SCM_MAKINUM (1));
2617 if (SCM_EQ_P (count
, SCM_MAKINUM (0)))
2618 scm_hashq_remove_x (scm_protects
, obj
);
2620 SCM_SETCDR (handle
, count
);
2629 scm_gc_register_root (SCM
*p
)
2632 SCM key
= scm_long2num ((long) p
);
2634 /* This critical section barrier will be replaced by a mutex. */
2637 handle
= scm_hashv_create_handle_x (scm_gc_registered_roots
, key
, SCM_MAKINUM (0));
2638 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), SCM_MAKINUM (1)));
2644 scm_gc_unregister_root (SCM
*p
)
2647 SCM key
= scm_long2num ((long) p
);
2649 /* This critical section barrier will be replaced by a mutex. */
2652 handle
= scm_hashv_get_handle (scm_gc_registered_roots
, key
);
2654 if (SCM_FALSEP (handle
))
2656 fprintf (stderr
, "scm_gc_unregister_root called on unregistered root\n");
2661 SCM count
= scm_difference (SCM_CDR (handle
), SCM_MAKINUM (1));
2662 if (SCM_EQ_P (count
, SCM_MAKINUM (0)))
2663 scm_hashv_remove_x (scm_gc_registered_roots
, key
);
2665 SCM_SETCDR (handle
, count
);
2672 scm_gc_register_roots (SCM
*b
, unsigned long n
)
2675 for (; p
< b
+ n
; ++p
)
2676 scm_gc_register_root (p
);
2680 scm_gc_unregister_roots (SCM
*b
, unsigned long n
)
2683 for (; p
< b
+ n
; ++p
)
2684 scm_gc_unregister_root (p
);
2689 /* called on process termination. */
2695 extern int on_exit (void (*procp
) (), int arg
);
2698 cleanup (int status
, void *arg
)
2700 #error Dont know how to setup a cleanup handler on your system.
2705 scm_flush_all_ports ();
2710 make_initial_segment (size_t init_heap_size
, scm_t_freelist
*freelist
)
2712 size_t rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2714 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2718 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2719 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2727 if (freelist
->min_yield_fraction
)
2728 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2730 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2737 init_freelist (scm_t_freelist
*freelist
,
2742 freelist
->clusters
= SCM_EOL
;
2743 freelist
->cluster_size
= cluster_size
+ 1;
2744 freelist
->left_to_collect
= 0;
2745 freelist
->clusters_allocated
= 0;
2746 freelist
->min_yield
= 0;
2747 freelist
->min_yield_fraction
= min_yield
;
2748 freelist
->span
= span
;
2749 freelist
->collected
= 0;
2750 freelist
->collected_1
= 0;
2751 freelist
->heap_size
= 0;
2755 /* Get an integer from an environment variable. */
2757 scm_i_getenv_int (const char *var
, int def
)
2759 char *end
, *val
= getenv (var
);
2763 res
= strtol (val
, &end
, 10);
2773 unsigned long gc_trigger_1
;
2774 unsigned long gc_trigger_2
;
2775 size_t init_heap_size_1
;
2776 size_t init_heap_size_2
;
2779 #if (SCM_DEBUG_CELL_ACCESSES == 1)
2780 scm_tc16_allocated
= scm_make_smob_type ("allocated cell", 0);
2781 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
2783 j
= SCM_NUM_PROTECTS
;
2785 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2788 scm_freelist
= SCM_EOL
;
2789 scm_freelist2
= SCM_EOL
;
2790 gc_trigger_1
= scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1
);
2791 init_freelist (&scm_master_freelist
, 1, SCM_CLUSTER_SIZE_1
, gc_trigger_1
);
2792 gc_trigger_2
= scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2
);
2793 init_freelist (&scm_master_freelist2
, 2, SCM_CLUSTER_SIZE_2
, gc_trigger_2
);
2794 scm_max_segment_size
= scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size
);
2798 j
= SCM_HEAP_SEG_SIZE
;
2799 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2800 scm_heap_table
= ((scm_t_heap_seg_data
*)
2801 scm_must_malloc (sizeof (scm_t_heap_seg_data
) * 2, "hplims"));
2802 heap_segment_table_size
= 2;
2804 mark_space_ptr
= &mark_space_head
;
2806 init_heap_size_1
= scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1
);
2807 init_heap_size_2
= scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2
);
2808 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2809 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2812 /* scm_hplims[0] can change. do not remove scm_heap_org */
2813 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2815 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2816 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2817 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2818 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2819 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2821 /* Initialise the list of ports. */
2822 scm_t_portable
= (scm_t_port
**)
2823 malloc (sizeof (scm_t_port
*) * scm_t_portable_room
);
2824 if (!scm_t_portable
)
2831 on_exit (cleanup
, 0);
2835 scm_stand_in_procs
= SCM_EOL
;
2836 scm_permobjs
= SCM_EOL
;
2837 scm_protects
= scm_c_make_hash_table (31);
2838 scm_gc_registered_roots
= scm_c_make_hash_table (31);
2845 SCM scm_after_gc_hook
;
2847 static SCM gc_async
;
2849 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
2850 * is run after the gc, as soon as the asynchronous events are handled by the
2854 gc_async_thunk (void)
2856 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
2857 return SCM_UNSPECIFIED
;
2861 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
2862 * the garbage collection. The only purpose of this function is to mark the
2863 * gc_async (which will eventually lead to the execution of the
2867 mark_gc_async (void * hook_data SCM_UNUSED
,
2868 void *func_data SCM_UNUSED
,
2869 void *data SCM_UNUSED
)
2871 /* If cell access debugging is enabled, the user may choose to perform
2872 * additional garbage collections after an arbitrary number of cell
2873 * accesses. We don't want the scheme level after-gc-hook to be performed
2874 * for each of these garbage collections for the following reason: The
2875 * execution of the after-gc-hook causes cell accesses itself. Thus, if the
2876 * after-gc-hook was performed with every gc, and if the gc was performed
2877 * after a very small number of cell accesses, then the number of cell
2878 * accesses during the execution of the after-gc-hook will suffice to cause
2879 * the execution of the next gc. Then, guile would keep executing the
2880 * after-gc-hook over and over again, and would never come to do other
2883 * To overcome this problem, if cell access debugging with additional
2884 * garbage collections is enabled, the after-gc-hook is never run by the
2885 * garbage collecter. When running guile with cell access debugging and the
2886 * execution of the after-gc-hook is desired, then it is necessary to run
2887 * the hook explicitly from the user code. This has the effect, that from
2888 * the scheme level point of view it seems that garbage collection is
2889 * performed with a much lower frequency than it actually is. Obviously,
2890 * this will not work for code that depends on a fixed one to one
2891 * relationship between the execution counts of the C level garbage
2892 * collection hooks and the execution count of the scheme level
2895 #if (SCM_DEBUG_CELL_ACCESSES == 1)
2896 if (debug_cells_gc_interval
== 0)
2897 scm_system_async_mark (gc_async
);
2899 scm_system_async_mark (gc_async
);
2911 scm_after_gc_hook
= scm_permanent_object (scm_make_hook (SCM_INUM0
));
2912 scm_c_define ("after-gc-hook", scm_after_gc_hook
);
2914 after_gc_thunk
= scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0
,
2916 gc_async
= scm_system_async (after_gc_thunk
); /* protected via scm_asyncs */
2918 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
2920 #ifndef SCM_MAGIC_SNARFER
2921 #include "libguile/gc.x"
2925 #endif /*MARK_DEPENDENCIES*/