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.
201 #define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS)
202 #define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L)
203 #define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS)
204 int scm_default_init_heap_size_1
= (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER
- 1)
205 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
206 int scm_default_min_yield_1
= 40;
208 #define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2))
209 int scm_default_init_heap_size_2
= (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER
- 1)
210 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
211 /* The following value may seem large, but note that if we get to GC at
212 * all, this means that we have a numerically intensive application
214 int scm_default_min_yield_2
= 40;
216 int scm_default_max_segment_size
= 2097000L;/* a little less (adm) than 2 Mb */
218 #define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE)
220 # define SCM_HEAP_SEG_SIZE 32768L
223 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
225 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
228 /* Make heap grow with factor 1.5 */
229 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
230 #define SCM_INIT_MALLOC_LIMIT 100000
231 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
233 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span)
234 aligned inner bounds for allocated storage */
237 /*in 386 protected mode we must only adjust the offset */
238 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
239 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
242 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
243 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
245 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
246 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
250 #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1)
251 #define CLUSTER_SIZE_IN_BYTES(freelist) \
252 (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE)
258 typedef struct scm_freelist_t
{
259 /* collected cells */
261 /* number of cells left to collect before cluster is full */
262 unsigned int left_to_collect
;
263 /* number of clusters which have been allocated */
264 unsigned int clusters_allocated
;
265 /* a list of freelists, each of size cluster_size,
266 * except the last one which may be shorter
270 /* this is the number of objects in each cluster, including the spine cell */
272 /* indicates that we should grow heap instead of GC:ing
275 /* minimum yield on this list in order not to grow the heap
278 /* defines min_yield as percent of total heap size
280 int min_yield_fraction
;
281 /* number of cells per object on this list */
283 /* number of collected cells during last GC */
285 /* number of collected cells during penultimate GC */
287 /* total number of cells in heap segments
288 * belonging to this list.
293 SCM scm_freelist
= SCM_EOL
;
294 scm_freelist_t scm_master_freelist
= {
295 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
297 SCM scm_freelist2
= SCM_EOL
;
298 scm_freelist_t scm_master_freelist2
= {
299 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
303 * is the number of bytes of must_malloc allocation needed to trigger gc.
305 unsigned long scm_mtrigger
;
308 * If set, don't expand the heap. Set only during gc, during which no allocation
309 * is supposed to take place anyway.
311 int scm_gc_heap_lock
= 0;
314 * Don't pause for collection if this is set -- just
317 int scm_block_gc
= 1;
319 /* During collection, this accumulates objects holding
322 SCM scm_weak_vectors
;
324 /* During collection, this accumulates structures which are to be freed.
326 SCM scm_structs_to_free
;
328 /* GC Statistics Keeping
330 unsigned long scm_cells_allocated
= 0;
331 long scm_mallocated
= 0;
332 unsigned long scm_gc_cells_collected
;
333 unsigned long scm_gc_yield
;
334 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
335 unsigned long scm_gc_malloc_collected
;
336 unsigned long scm_gc_ports_collected
;
337 unsigned long scm_gc_time_taken
= 0;
338 static unsigned long t_before_gc
;
339 static unsigned long t_before_sweep
;
340 unsigned long scm_gc_mark_time_taken
= 0;
341 unsigned long scm_gc_sweep_time_taken
= 0;
342 unsigned long scm_gc_times
= 0;
343 unsigned long scm_gc_cells_swept
= 0;
344 double scm_gc_cells_marked_acc
= 0.;
345 double scm_gc_cells_swept_acc
= 0.;
347 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
348 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
349 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
350 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
351 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
352 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
353 SCM_SYMBOL (sym_gc_mark_time_taken
, "gc-mark-time-taken");
354 SCM_SYMBOL (sym_gc_sweep_time_taken
, "gc-sweep-time-taken");
355 SCM_SYMBOL (sym_times
, "gc-times");
356 SCM_SYMBOL (sym_cells_marked
, "cells-marked");
357 SCM_SYMBOL (sym_cells_swept
, "cells-swept");
359 typedef struct scm_heap_seg_data_t
361 /* lower and upper bounds of the segment */
362 SCM_CELLPTR bounds
[2];
364 /* address of the head-of-freelist pointer for this segment's cells.
365 All segments usually point to the same one, scm_freelist. */
366 scm_freelist_t
*freelist
;
368 /* number of cells per object in this segment */
370 } scm_heap_seg_data_t
;
374 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
376 typedef enum { return_on_error
, abort_on_error
} policy_on_error
;
377 static void alloc_some_heap (scm_freelist_t
*, policy_on_error
);
380 #define SCM_HEAP_SIZE \
381 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
382 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
384 #define BVEC_GROW_SIZE 256
385 #define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE)
386 #define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_c_bvec_limb_t))
388 /* mark space allocation */
390 typedef struct scm_mark_space_t
392 scm_c_bvec_limb_t
*bvec_space
;
393 struct scm_mark_space_t
*next
;
396 static scm_mark_space_t
*current_mark_space
;
397 static scm_mark_space_t
**mark_space_ptr
;
398 static int current_mark_space_offset
;
399 static scm_mark_space_t
*mark_space_head
;
401 static scm_c_bvec_limb_t
*
404 scm_c_bvec_limb_t
*res
;
406 if (!current_mark_space
)
408 SCM_SYSCALL (current_mark_space
= (scm_mark_space_t
*) malloc (sizeof (scm_mark_space_t
)));
409 if (!current_mark_space
)
410 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
412 current_mark_space
->bvec_space
= NULL
;
413 current_mark_space
->next
= NULL
;
415 *mark_space_ptr
= current_mark_space
;
416 mark_space_ptr
= &(current_mark_space
->next
);
421 if (!(current_mark_space
->bvec_space
))
423 SCM_SYSCALL (current_mark_space
->bvec_space
=
424 (scm_c_bvec_limb_t
*) calloc (BVEC_GROW_SIZE_IN_BYTES
, 1));
425 if (!(current_mark_space
->bvec_space
))
426 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
428 current_mark_space_offset
= 0;
433 if (current_mark_space_offset
== BVEC_GROW_SIZE_IN_LIMBS
)
435 current_mark_space
= NULL
;
440 res
= current_mark_space
->bvec_space
+ current_mark_space_offset
;
441 current_mark_space_offset
+= SCM_GC_CARD_BVEC_SIZE_IN_LIMBS
;
449 scm_mark_space_t
*ms
;
451 for (ms
= mark_space_head
; ms
; ms
= ms
->next
)
452 memset (ms
->bvec_space
, 0, BVEC_GROW_SIZE_IN_BYTES
);
457 /* Debugging functions. */
459 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
461 /* Return the number of the heap segment containing CELL. */
467 for (i
= 0; i
< scm_n_heap_segs
; i
++)
468 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
469 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
471 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
478 map_free_list (scm_freelist_t
*master
, SCM freelist
)
480 int last_seg
= -1, count
= 0;
483 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
))
485 int this_seg
= which_seg (f
);
487 if (this_seg
!= last_seg
)
490 fprintf (stderr
, " %5d %d-cells in segment %d\n",
491 count
, master
->span
, last_seg
);
498 fprintf (stderr
, " %5d %d-cells in segment %d\n",
499 count
, master
->span
, last_seg
);
502 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
504 "Print debugging information about the free-list.\n"
505 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
506 #define FUNC_NAME s_scm_map_free_list
509 fprintf (stderr
, "%d segments total (%d:%d",
511 scm_heap_table
[0].span
,
512 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
513 for (i
= 1; i
< scm_n_heap_segs
; i
++)
514 fprintf (stderr
, ", %d:%d",
515 scm_heap_table
[i
].span
,
516 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
517 fprintf (stderr
, ")\n");
518 map_free_list (&scm_master_freelist
, scm_freelist
);
519 map_free_list (&scm_master_freelist2
, scm_freelist2
);
522 return SCM_UNSPECIFIED
;
526 static int last_cluster
;
527 static int last_size
;
530 free_list_length (char *title
, int i
, SCM freelist
)
534 for (ls
= freelist
; !SCM_NULLP (ls
); ls
= SCM_FREE_CELL_CDR (ls
))
535 if (SCM_FREE_CELL_P (ls
))
539 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
546 if (last_cluster
== i
- 1)
547 fprintf (stderr
, "\t%d\n", last_size
);
549 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
552 fprintf (stderr
, "%s %d", title
, i
);
554 fprintf (stderr
, "%s\t%d\n", title
, n
);
562 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
565 int i
= 0, len
, n
= 0;
566 fprintf (stderr
, "%s\n\n", title
);
567 n
+= free_list_length ("free list", -1, freelist
);
568 for (clusters
= master
->clusters
;
569 SCM_NNULLP (clusters
);
570 clusters
= SCM_CDR (clusters
))
572 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
575 if (last_cluster
== i
- 1)
576 fprintf (stderr
, "\t%d\n", last_size
);
578 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
579 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
582 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
584 "Print debugging information about the free-list.\n"
585 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
586 #define FUNC_NAME s_scm_free_list_length
588 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
589 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
590 return SCM_UNSPECIFIED
;
596 #ifdef GUILE_DEBUG_FREELIST
598 /* Number of calls to SCM_NEWCELL since startup. */
599 static unsigned long scm_newcell_count
;
600 static unsigned long scm_newcell2_count
;
602 /* Search freelist for anything that isn't marked as a free cell.
603 Abort if we find something. */
605 scm_check_freelist (SCM freelist
)
610 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
), i
++)
611 if (!SCM_FREE_CELL_P (f
))
613 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
614 scm_newcell_count
, i
);
619 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
621 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
622 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
623 "compile-time flag was selected.\n")
624 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
626 /* [cmm] I did a double-take when I read this code the first time.
628 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
629 return SCM_UNSPECIFIED
;
635 scm_debug_newcell (void)
640 if (scm_debug_check_freelist
)
642 scm_check_freelist (scm_freelist
);
646 /* The rest of this is supposed to be identical to the SCM_NEWCELL
648 if (SCM_NULLP (scm_freelist
))
649 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
653 scm_freelist
= SCM_FREE_CELL_CDR (scm_freelist
);
660 scm_debug_newcell2 (void)
664 scm_newcell2_count
++;
665 if (scm_debug_check_freelist
)
667 scm_check_freelist (scm_freelist2
);
671 /* The rest of this is supposed to be identical to the SCM_NEWCELL
673 if (SCM_NULLP (scm_freelist2
))
674 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
678 scm_freelist2
= SCM_FREE_CELL_CDR (scm_freelist2
);
684 #endif /* GUILE_DEBUG_FREELIST */
689 master_cells_allocated (scm_freelist_t
*master
)
691 /* the '- 1' below is to ignore the cluster spine cells. */
692 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
693 if (SCM_NULLP (master
->clusters
))
694 objects
-= master
->left_to_collect
;
695 return master
->span
* objects
;
699 freelist_length (SCM freelist
)
702 for (n
= 0; !SCM_NULLP (freelist
); freelist
= SCM_FREE_CELL_CDR (freelist
))
708 compute_cells_allocated ()
710 return (scm_cells_allocated
711 + master_cells_allocated (&scm_master_freelist
)
712 + master_cells_allocated (&scm_master_freelist2
)
713 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
714 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
717 /* {Scheme Interface to GC}
720 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
722 "Returns an association list of statistics about Guile's current use of storage. ")
723 #define FUNC_NAME s_scm_gc_stats
728 long int local_scm_mtrigger
;
729 long int local_scm_mallocated
;
730 long int local_scm_heap_size
;
731 long int local_scm_cells_allocated
;
732 long int local_scm_gc_time_taken
;
733 long int local_scm_gc_times
;
734 long int local_scm_gc_mark_time_taken
;
735 long int local_scm_gc_sweep_time_taken
;
736 double local_scm_gc_cells_swept
;
737 double local_scm_gc_cells_marked
;
747 for (i
= scm_n_heap_segs
; i
--; )
748 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
749 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
751 if (scm_n_heap_segs
!= n
)
756 /* Below, we cons to produce the resulting list. We want a snapshot of
757 * the heap situation before consing.
759 local_scm_mtrigger
= scm_mtrigger
;
760 local_scm_mallocated
= scm_mallocated
;
761 local_scm_heap_size
= SCM_HEAP_SIZE
;
762 local_scm_cells_allocated
= compute_cells_allocated ();
763 local_scm_gc_time_taken
= scm_gc_time_taken
;
764 local_scm_gc_mark_time_taken
= scm_gc_mark_time_taken
;
765 local_scm_gc_sweep_time_taken
= scm_gc_sweep_time_taken
;
766 local_scm_gc_times
= scm_gc_times
;
767 local_scm_gc_cells_swept
= scm_gc_cells_swept_acc
;
768 local_scm_gc_cells_marked
= scm_gc_cells_marked_acc
;
770 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
771 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
772 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
773 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
774 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
775 scm_cons (sym_times
, scm_ulong2num (local_scm_gc_times
)),
776 scm_cons (sym_gc_mark_time_taken
, scm_ulong2num (local_scm_gc_mark_time_taken
)),
777 scm_cons (sym_gc_sweep_time_taken
, scm_ulong2num (local_scm_gc_sweep_time_taken
)),
778 scm_cons (sym_cells_marked
, scm_dbl2big (local_scm_gc_cells_marked
)),
779 scm_cons (sym_cells_swept
, scm_dbl2big (local_scm_gc_cells_swept
)),
780 scm_cons (sym_heap_segments
, heap_segs
),
789 gc_start_stats (const char *what
)
791 t_before_gc
= scm_c_get_internal_run_time ();
792 scm_gc_cells_swept
= 0;
793 scm_gc_cells_collected
= 0;
794 scm_gc_yield_1
= scm_gc_yield
;
795 scm_gc_yield
= (scm_cells_allocated
796 + master_cells_allocated (&scm_master_freelist
)
797 + master_cells_allocated (&scm_master_freelist2
));
798 scm_gc_malloc_collected
= 0;
799 scm_gc_ports_collected
= 0;
806 unsigned long t
= scm_c_get_internal_run_time ();
807 scm_gc_time_taken
+= (t
- t_before_gc
);
808 scm_gc_sweep_time_taken
+= (t
- t_before_sweep
);
811 scm_gc_cells_marked_acc
+= scm_gc_cells_swept
- scm_gc_cells_collected
;
812 scm_gc_cells_swept_acc
+= scm_gc_cells_swept
;
816 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
818 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
819 "returned by this function for @var{obj}")
820 #define FUNC_NAME s_scm_object_address
822 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
827 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
829 "Scans all of SCM objects and reclaims for further use those that are\n"
830 "no longer accessible.")
831 #define FUNC_NAME s_scm_gc
836 return SCM_UNSPECIFIED
;
842 /* {C Interface For When GC is Triggered}
846 adjust_min_yield (scm_freelist_t
*freelist
)
848 /* min yield is adjusted upwards so that next predicted total yield
849 * (allocated cells actually freed by GC) becomes
850 * `min_yield_fraction' of total heap size. Note, however, that
851 * the absolute value of min_yield will correspond to `collected'
852 * on one master (the one which currently is triggering GC).
854 * The reason why we look at total yield instead of cells collected
855 * on one list is that we want to take other freelists into account.
856 * On this freelist, we know that (local) yield = collected cells,
857 * but that's probably not the case on the other lists.
859 * (We might consider computing a better prediction, for example
860 * by computing an average over multiple GC:s.)
862 if (freelist
->min_yield_fraction
)
864 /* Pick largest of last two yields. */
865 int delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
866 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
868 fprintf (stderr
, " after GC = %d, delta = %d\n",
873 freelist
->min_yield
+= delta
;
878 /* When we get POSIX threads support, the master will be global and
879 * common while the freelist will be individual for each thread.
883 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
889 if (SCM_NULLP (master
->clusters
))
891 if (master
->grow_heap_p
|| scm_block_gc
)
893 /* In order to reduce gc frequency, try to allocate a new heap
894 * segment first, even if gc might find some free cells. If we
895 * can't obtain a new heap segment, we will try gc later.
897 master
->grow_heap_p
= 0;
898 alloc_some_heap (master
, return_on_error
);
900 if (SCM_NULLP (master
->clusters
))
902 /* The heap was not grown, either because it wasn't scheduled to
903 * grow, or because there was not enough memory available. In
904 * both cases we have to try gc to get some free cells.
907 fprintf (stderr
, "allocated = %d, ",
909 + master_cells_allocated (&scm_master_freelist
)
910 + master_cells_allocated (&scm_master_freelist2
));
913 adjust_min_yield (master
);
914 if (SCM_NULLP (master
->clusters
))
916 /* gc could not free any cells. Now, we _must_ allocate a
917 * new heap segment, because there is no other possibility
918 * to provide a new cell for the caller.
920 alloc_some_heap (master
, abort_on_error
);
924 cell
= SCM_CAR (master
->clusters
);
925 master
->clusters
= SCM_CDR (master
->clusters
);
926 ++master
->clusters_allocated
;
928 while (SCM_NULLP (cell
));
930 #ifdef GUILE_DEBUG_FREELIST
931 scm_check_freelist (cell
);
935 *freelist
= SCM_FREE_CELL_CDR (cell
);
941 /* This is a support routine which can be used to reserve a cluster
942 * for some special use, such as debugging. It won't be useful until
943 * free cells are preserved between garbage collections.
947 scm_alloc_cluster (scm_freelist_t
*master
)
950 cell
= scm_gc_for_newcell (master
, &freelist
);
951 SCM_SETCDR (cell
, freelist
);
957 scm_c_hook_t scm_before_gc_c_hook
;
958 scm_c_hook_t scm_before_mark_c_hook
;
959 scm_c_hook_t scm_before_sweep_c_hook
;
960 scm_c_hook_t scm_after_sweep_c_hook
;
961 scm_c_hook_t scm_after_gc_c_hook
;
965 scm_igc (const char *what
)
970 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
973 SCM_NULLP (scm_freelist
)
975 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
978 /* During the critical section, only the current thread may run. */
979 SCM_THREAD_CRITICAL_SECTION_START
;
982 /* fprintf (stderr, "gc: %s\n", what); */
984 if (!scm_stack_base
|| scm_block_gc
)
990 gc_start_stats (what
);
992 if (scm_mallocated
< 0)
993 /* The byte count of allocated objects has underflowed. This is
994 probably because you forgot to report the sizes of objects you
995 have allocated, by calling scm_done_malloc or some such. When
996 the GC freed them, it subtracted their size from
997 scm_mallocated, which underflowed. */
1000 if (scm_gc_heap_lock
)
1001 /* We've invoked the collector while a GC is already in progress.
1002 That should never happen. */
1007 /* flush dead entries from the continuation stack */
1012 elts
= SCM_VELTS (scm_continuation_stack
);
1013 bound
= SCM_LENGTH (scm_continuation_stack
);
1014 x
= SCM_INUM (scm_continuation_stack_ptr
);
1017 elts
[x
] = SCM_BOOL_F
;
1022 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
1024 clear_mark_space ();
1028 /* Protect from the C stack. This must be the first marking
1029 * done because it provides information about what objects
1030 * are "in-use" by the C code. "in-use" objects are those
1031 * for which the values from SCM_LENGTH and SCM_CHARS must remain
1032 * usable. This requirement is stricter than a liveness
1033 * requirement -- in particular, it constrains the implementation
1034 * of scm_vector_set_length_x.
1036 SCM_FLUSH_REGISTER_WINDOWS
;
1037 /* This assumes that all registers are saved into the jmp_buf */
1038 setjmp (scm_save_regs_gc_mark
);
1039 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1040 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
1041 sizeof scm_save_regs_gc_mark
)
1042 / sizeof (SCM_STACKITEM
)));
1045 scm_sizet stack_len
= scm_stack_size (scm_stack_base
);
1046 #ifdef SCM_STACK_GROWS_UP
1047 scm_mark_locations (scm_stack_base
, stack_len
);
1049 scm_mark_locations (scm_stack_base
- stack_len
, stack_len
);
1053 #else /* USE_THREADS */
1055 /* Mark every thread's stack and registers */
1056 scm_threads_mark_stacks ();
1058 #endif /* USE_THREADS */
1060 /* FIXME: insert a phase to un-protect string-data preserved
1061 * in scm_vector_set_length_x.
1064 j
= SCM_NUM_PROTECTS
;
1066 scm_gc_mark (scm_sys_protects
[j
]);
1068 /* FIXME: we should have a means to register C functions to be run
1069 * in different phases of GC
1071 scm_mark_subr_table ();
1074 scm_gc_mark (scm_root
->handle
);
1077 t_before_sweep
= scm_c_get_internal_run_time ();
1078 scm_gc_mark_time_taken
+= (t_before_sweep
- t_before_gc
);
1080 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
1084 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
1090 SCM_THREAD_CRITICAL_SECTION_END
;
1092 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
1103 /* Mark an object precisely.
1107 #define FUNC_NAME "scm_gc_mark"
1119 if (!SCM_CELLP (ptr
))
1120 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1122 #if (defined (GUILE_DEBUG_FREELIST))
1124 if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr
)))
1125 scm_wta (ptr
, "rogue pointer in heap", NULL
);
1129 if (SCM_GCMARKP (ptr
))
1132 SCM_SETGCMARK (ptr
);
1134 switch (SCM_TYP7 (ptr
))
1136 case scm_tcs_cons_nimcar
:
1137 if (SCM_IMP (SCM_CDR (ptr
)))
1139 ptr
= SCM_CAR (ptr
);
1142 scm_gc_mark (SCM_CAR (ptr
));
1143 ptr
= SCM_CDR (ptr
);
1145 case scm_tcs_cons_imcar
:
1146 ptr
= SCM_CDR (ptr
);
1149 scm_gc_mark (SCM_CELL_OBJECT_2 (ptr
));
1150 ptr
= SCM_CDR (ptr
);
1152 case scm_tcs_cons_gloc
:
1154 /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
1155 * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
1156 * to a heap cell. If it is a struct, the cell word #0 of ptr is a
1157 * pointer to a struct vtable data region. The fact that these are
1158 * accessed in the same way restricts the possibilites to change the
1159 * data layout of structs or heap cells.
1161 scm_bits_t word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
1162 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1163 if (vtable_data
[scm_vtable_index_vcell
] != 0)
1166 SCM gloc_car
= SCM_PACK (word0
);
1167 scm_gc_mark (gloc_car
);
1168 ptr
= SCM_CDR (ptr
);
1173 /* ptr is a struct */
1174 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
1175 int len
= SCM_LENGTH (layout
);
1176 char * fields_desc
= SCM_CHARS (layout
);
1177 scm_bits_t
* struct_data
= (scm_bits_t
*) SCM_STRUCT_DATA (ptr
);
1179 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
1181 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
1182 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1188 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1189 if (fields_desc
[x
] == 'p')
1190 scm_gc_mark (SCM_PACK (*struct_data
));
1191 if (fields_desc
[x
] == 'p')
1193 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1194 for (x
= *struct_data
; x
; --x
)
1195 scm_gc_mark (SCM_PACK (*++struct_data
));
1197 scm_gc_mark (SCM_PACK (*struct_data
));
1201 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1206 case scm_tcs_closures
:
1207 if (SCM_IMP (SCM_CDR (ptr
)))
1209 ptr
= SCM_CLOSCAR (ptr
);
1212 scm_gc_mark (SCM_CLOSCAR (ptr
));
1213 ptr
= SCM_CDR (ptr
);
1215 case scm_tc7_vector
:
1216 case scm_tc7_lvector
:
1220 i
= SCM_LENGTH (ptr
);
1224 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1225 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1226 ptr
= SCM_VELTS (ptr
)[0];
1228 case scm_tc7_contin
:
1229 if (SCM_VELTS (ptr
))
1230 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1233 (sizeof (SCM_STACKITEM
) + -1 +
1234 sizeof (scm_contregs
)) /
1235 sizeof (SCM_STACKITEM
)));
1239 case scm_tc7_byvect
:
1246 #ifdef HAVE_LONG_LONGS
1247 case scm_tc7_llvect
:
1250 case scm_tc7_string
:
1253 case scm_tc7_substring
:
1254 ptr
= SCM_CDR (ptr
);
1258 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1259 scm_weak_vectors
= ptr
;
1260 if (SCM_IS_WHVEC_ANY (ptr
))
1267 len
= SCM_LENGTH (ptr
);
1268 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1269 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1271 for (x
= 0; x
< len
; ++x
)
1274 alist
= SCM_VELTS (ptr
)[x
];
1276 /* mark everything on the alist except the keys or
1277 * values, according to weak_values and weak_keys. */
1278 while ( SCM_CONSP (alist
)
1279 && !SCM_GCMARKP (alist
)
1280 && SCM_CONSP (SCM_CAR (alist
)))
1285 kvpair
= SCM_CAR (alist
);
1286 next_alist
= SCM_CDR (alist
);
1289 * SCM_SETGCMARK (alist);
1290 * SCM_SETGCMARK (kvpair);
1292 * It may be that either the key or value is protected by
1293 * an escaped reference to part of the spine of this alist.
1294 * If we mark the spine here, and only mark one or neither of the
1295 * key and value, they may never be properly marked.
1296 * This leads to a horrible situation in which an alist containing
1297 * freelist cells is exported.
1299 * So only mark the spines of these arrays last of all marking.
1300 * If somebody confuses us by constructing a weak vector
1301 * with a circular alist then we are hosed, but at least we
1302 * won't prematurely drop table entries.
1305 scm_gc_mark (SCM_CAR (kvpair
));
1307 scm_gc_mark (SCM_CDR (kvpair
));
1310 if (SCM_NIMP (alist
))
1311 scm_gc_mark (alist
);
1316 case scm_tc7_symbol
:
1317 ptr
= SCM_PROP_SLOTS (ptr
);
1322 i
= SCM_PTOBNUM (ptr
);
1323 if (!(i
< scm_numptob
))
1325 if (SCM_PTAB_ENTRY(ptr
))
1326 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1327 if (scm_ptobs
[i
].mark
)
1329 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1336 switch (SCM_TYP16 (ptr
))
1337 { /* should be faster than going through scm_smobs */
1338 case scm_tc_free_cell
:
1339 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1342 case scm_tc16_complex
:
1345 i
= SCM_SMOBNUM (ptr
);
1346 if (!(i
< scm_numsmob
))
1348 if (scm_smobs
[i
].mark
)
1350 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1359 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1365 /* Mark a Region Conservatively
1369 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1373 for (m
= 0; m
< n
; ++m
)
1375 SCM obj
= * (SCM
*) &x
[m
];
1376 if (SCM_CELLP (obj
))
1378 SCM_CELLPTR ptr
= SCM2PTR (obj
);
1380 int j
= scm_n_heap_segs
- 1;
1381 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1382 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1389 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1391 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1399 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1403 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1408 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1412 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1419 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1422 if (scm_heap_table
[seg_id
].span
== 1
1423 || SCM_DOUBLE_CELLP (obj
))
1434 /* The function scm_cellp determines whether an SCM value can be regarded as a
1435 * pointer to a cell on the heap. Binary search is used in order to determine
1436 * the heap segment that contains the cell.
1439 scm_cellp (SCM value
)
1441 if (SCM_CELLP (value
)) {
1442 scm_cell
* ptr
= SCM2PTR (value
);
1444 unsigned int j
= scm_n_heap_segs
- 1;
1447 int k
= (i
+ j
) / 2;
1448 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
)) {
1450 } else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
)) {
1455 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1456 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
)
1457 && (scm_heap_table
[i
].span
== 1 || SCM_DOUBLE_CELLP (value
))
1458 && !SCM_GC_IN_CARD_HEADERP (ptr
)
1469 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1471 freelist
->cells
= SCM_EOL
;
1472 freelist
->left_to_collect
= freelist
->cluster_size
;
1473 freelist
->clusters_allocated
= 0;
1474 freelist
->clusters
= SCM_EOL
;
1475 freelist
->clustertail
= &freelist
->clusters
;
1476 freelist
->collected_1
= freelist
->collected
;
1477 freelist
->collected
= 0;
1481 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1484 *freelist
->clustertail
= freelist
->cells
;
1485 if (!SCM_NULLP (freelist
->cells
))
1487 SCM c
= freelist
->cells
;
1488 SCM_SETCAR (c
, SCM_CDR (c
));
1489 SCM_SETCDR (c
, SCM_EOL
);
1490 freelist
->collected
+=
1491 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1493 scm_gc_cells_collected
+= freelist
->collected
;
1495 /* Although freelist->min_yield is used to test freelist->collected
1496 * (which is the local GC yield for freelist), it is adjusted so
1497 * that *total* yield is freelist->min_yield_fraction of total heap
1498 * size. This means that a too low yield is compensated by more
1499 * heap on the list which is currently doing most work, which is
1500 * just what we want.
1502 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1503 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1506 #define NEXT_DATA_CELL(ptr, span) \
1508 scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \
1509 (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \
1510 CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \
1516 #define FUNC_NAME "scm_gc_sweep"
1518 register SCM_CELLPTR ptr
;
1519 register SCM nfreelist
;
1520 register scm_freelist_t
*freelist
;
1528 gc_sweep_freelist_start (&scm_master_freelist
);
1529 gc_sweep_freelist_start (&scm_master_freelist2
);
1531 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1533 register unsigned int left_to_collect
;
1534 register scm_sizet j
;
1536 /* Unmarked cells go onto the front of the freelist this heap
1537 segment points to. Rather than updating the real freelist
1538 pointer as we go along, we accumulate the new head in
1539 nfreelist. Then, if it turns out that the entire segment is
1540 free, we free (i.e., malloc's free) the whole segment, and
1541 simply don't assign nfreelist back into the real freelist. */
1542 freelist
= scm_heap_table
[i
].freelist
;
1543 nfreelist
= freelist
->cells
;
1544 left_to_collect
= freelist
->left_to_collect
;
1545 span
= scm_heap_table
[i
].span
;
1547 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1548 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1550 /* use only data cells in seg_size */
1551 seg_size
= (seg_size
/ SCM_GC_CARD_N_CELLS
) * (SCM_GC_CARD_N_DATA_CELLS
/ span
) * span
;
1553 scm_gc_cells_swept
+= seg_size
;
1555 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1559 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1565 NEXT_DATA_CELL (nxt
, span
);
1572 scmptr
= PTR2SCM (ptr
);
1574 if (SCM_GCMARKP (scmptr
))
1577 switch SCM_TYP7 (scmptr
)
1579 case scm_tcs_cons_gloc
:
1581 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1582 * struct or a gloc. See the corresponding comment in
1585 scm_bits_t word0
= (SCM_CELL_WORD_0 (scmptr
)
1586 - scm_tc3_cons_gloc
);
1587 /* access as struct */
1588 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
;
1589 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1591 /* Structs need to be freed in a special order.
1592 * This is handled by GC C hooks in struct.c.
1594 SCM_SET_STRUCT_GC_CHAIN (scmptr
, scm_structs_to_free
);
1595 scm_structs_to_free
= scmptr
;
1598 /* fall through so that scmptr gets collected */
1601 case scm_tcs_cons_imcar
:
1602 case scm_tcs_cons_nimcar
:
1603 case scm_tcs_closures
:
1607 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1608 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1610 case scm_tc7_vector
:
1611 case scm_tc7_lvector
:
1615 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1617 scm_must_free (SCM_CHARS (scmptr
));
1618 /* SCM_SETCHARS(scmptr, 0);*/
1622 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1624 case scm_tc7_byvect
:
1625 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1629 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1632 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1634 #ifdef HAVE_LONG_LONGS
1635 case scm_tc7_llvect
:
1636 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1640 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1643 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1646 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1649 case scm_tc7_substring
:
1651 case scm_tc7_string
:
1652 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1654 case scm_tc7_symbol
:
1655 m
+= SCM_LENGTH (scmptr
) + 1;
1656 scm_must_free (SCM_CHARS (scmptr
));
1658 case scm_tc7_contin
:
1659 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1660 if (SCM_VELTS (scmptr
))
1663 /* the various "subrs" (primitives) are never freed */
1666 if SCM_OPENP (scmptr
)
1668 int k
= SCM_PTOBNUM (scmptr
);
1669 if (!(k
< scm_numptob
))
1671 /* Keep "revealed" ports alive. */
1672 if (scm_revealed_count (scmptr
) > 0)
1674 /* Yes, I really do mean scm_ptobs[k].free */
1675 /* rather than ftobs[k].close. .close */
1676 /* is for explicit CLOSE-PORT by user */
1677 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1678 SCM_SETSTREAM (scmptr
, 0);
1679 scm_remove_from_port_table (scmptr
);
1680 scm_gc_ports_collected
++;
1681 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1685 switch SCM_TYP16 (scmptr
)
1687 case scm_tc_free_cell
:
1692 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1694 #endif /* def SCM_BIGDIG */
1695 case scm_tc16_complex
:
1696 m
+= 2 * sizeof (double);
1701 k
= SCM_SMOBNUM (scmptr
);
1702 if (!(k
< scm_numsmob
))
1704 m
+= (scm_smobs
[k
].free
) (scmptr
);
1711 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1714 if (!--left_to_collect
)
1716 SCM_SETCAR (scmptr
, nfreelist
);
1717 *freelist
->clustertail
= scmptr
;
1718 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1720 nfreelist
= SCM_EOL
;
1721 freelist
->collected
+= span
* freelist
->cluster_size
;
1722 left_to_collect
= freelist
->cluster_size
;
1726 /* Stick the new cell on the front of nfreelist. It's
1727 critical that we mark this cell as freed; otherwise, the
1728 conservative collector might trace it as some other type
1730 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1731 SCM_SET_FREE_CELL_CDR (scmptr
, nfreelist
);
1736 #ifdef GC_FREE_SEGMENTS
1741 freelist
->heap_size
-= seg_size
;
1742 free ((char *) scm_heap_table
[i
].bounds
[0]);
1743 scm_heap_table
[i
].bounds
[0] = 0;
1744 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1745 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1746 scm_n_heap_segs
-= 1;
1747 i
--; /* We need to scan the segment just moved. */
1750 #endif /* ifdef GC_FREE_SEGMENTS */
1752 /* Update the real freelist pointer to point to the head of
1753 the list of free cells we've built for this segment. */
1754 freelist
->cells
= nfreelist
;
1755 freelist
->left_to_collect
= left_to_collect
;
1758 #ifdef GUILE_DEBUG_FREELIST
1759 scm_map_free_list ();
1763 gc_sweep_freelist_finish (&scm_master_freelist
);
1764 gc_sweep_freelist_finish (&scm_master_freelist2
);
1766 /* When we move to POSIX threads private freelists should probably
1767 be GC-protected instead. */
1768 scm_freelist
= SCM_EOL
;
1769 scm_freelist2
= SCM_EOL
;
1771 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1772 scm_gc_yield
-= scm_cells_allocated
;
1773 scm_mallocated
-= m
;
1774 scm_gc_malloc_collected
= m
;
1780 /* {Front end to malloc}
1782 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
1785 * These functions provide services comperable to malloc, realloc, and
1786 * free. They are for allocating malloced parts of scheme objects.
1787 * The primary purpose of the front end is to impose calls to gc. */
1791 * Return newly malloced storage or throw an error.
1793 * The parameter WHAT is a string for error reporting.
1794 * If the threshold scm_mtrigger will be passed by this
1795 * allocation, or if the first call to malloc fails,
1796 * garbage collect -- on the presumption that some objects
1797 * using malloced storage may be collected.
1799 * The limit scm_mtrigger may be raised by this allocation.
1802 scm_must_malloc (scm_sizet size
, const char *what
)
1805 unsigned long nm
= scm_mallocated
+ size
;
1807 if (nm
<= scm_mtrigger
)
1809 SCM_SYSCALL (ptr
= malloc (size
));
1812 scm_mallocated
= nm
;
1813 #ifdef GUILE_DEBUG_MALLOC
1814 scm_malloc_register (ptr
, what
);
1822 nm
= scm_mallocated
+ size
;
1823 SCM_SYSCALL (ptr
= malloc (size
));
1826 scm_mallocated
= nm
;
1827 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1828 if (nm
> scm_mtrigger
)
1829 scm_mtrigger
= nm
+ nm
/ 2;
1831 scm_mtrigger
+= scm_mtrigger
/ 2;
1833 #ifdef GUILE_DEBUG_MALLOC
1834 scm_malloc_register (ptr
, what
);
1840 scm_memory_error (what
);
1845 * is similar to scm_must_malloc.
1848 scm_must_realloc (void *where
,
1854 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1856 if (nm
<= scm_mtrigger
)
1858 SCM_SYSCALL (ptr
= realloc (where
, size
));
1861 scm_mallocated
= nm
;
1862 #ifdef GUILE_DEBUG_MALLOC
1863 scm_malloc_reregister (where
, ptr
, what
);
1871 nm
= scm_mallocated
+ size
- old_size
;
1872 SCM_SYSCALL (ptr
= realloc (where
, size
));
1875 scm_mallocated
= nm
;
1876 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1877 if (nm
> scm_mtrigger
)
1878 scm_mtrigger
= nm
+ nm
/ 2;
1880 scm_mtrigger
+= scm_mtrigger
/ 2;
1882 #ifdef GUILE_DEBUG_MALLOC
1883 scm_malloc_reregister (where
, ptr
, what
);
1888 scm_memory_error (what
);
1893 scm_must_free (void *obj
)
1894 #define FUNC_NAME "scm_must_free"
1896 #ifdef GUILE_DEBUG_MALLOC
1897 scm_malloc_unregister (obj
);
1902 SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL
);
1907 /* Announce that there has been some malloc done that will be freed
1908 * during gc. A typical use is for a smob that uses some malloced
1909 * memory but can not get it from scm_must_malloc (for whatever
1910 * reason). When a new object of this smob is created you call
1911 * scm_done_malloc with the size of the object. When your smob free
1912 * function is called, be sure to include this size in the return
1915 * If you can't actually free the memory in the smob free function,
1916 * for whatever reason (like reference counting), you still can (and
1917 * should) report the amount of memory freed when you actually free it.
1918 * Do it by calling scm_done_malloc with the _negated_ size. Clever,
1919 * eh? Or even better, call scm_done_free. */
1922 scm_done_malloc (long size
)
1924 scm_mallocated
+= size
;
1926 if (scm_mallocated
> scm_mtrigger
)
1928 scm_igc ("foreign mallocs");
1929 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1931 if (scm_mallocated
> scm_mtrigger
)
1932 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1934 scm_mtrigger
+= scm_mtrigger
/ 2;
1940 scm_done_free (long size
)
1942 scm_mallocated
-= size
;
1949 * Each heap segment is an array of objects of a particular size.
1950 * Every segment has an associated (possibly shared) freelist.
1951 * A table of segment records is kept that records the upper and
1952 * lower extents of the segment; this is used during the conservative
1953 * phase of gc to identify probably gc roots (because they point
1954 * into valid segments at reasonable offsets). */
1957 * is true if the first segment was smaller than INIT_HEAP_SEG.
1958 * If scm_expmem is set to one, subsequent segment allocations will
1959 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1963 scm_sizet scm_max_segment_size
;
1966 * is the lowest base address of any heap segment.
1968 SCM_CELLPTR scm_heap_org
;
1970 scm_heap_seg_data_t
* scm_heap_table
= 0;
1971 static unsigned int heap_segment_table_size
= 0;
1972 int scm_n_heap_segs
= 0;
1975 * initializes a new heap segment and returns the number of objects it contains.
1977 * The segment origin and segment size in bytes are input parameters.
1978 * The freelist is both input and output.
1980 * This function presumes that the scm_heap_table has already been expanded
1981 * to accomodate a new segment record and that the markbit space was reserved
1982 * for all the cards in this segment.
1985 #define INIT_CARD(card, span) \
1987 SCM_GC_CARD_BVEC (card) = get_bvec (); \
1989 SCM_GC_SET_CARD_DOUBLECELL (card); \
1993 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
1995 register SCM_CELLPTR ptr
;
1996 SCM_CELLPTR seg_end
;
1999 int span
= freelist
->span
;
2001 if (seg_org
== NULL
)
2004 /* Align the begin ptr up.
2006 ptr
= SCM_GC_CARD_UP (seg_org
);
2008 /* Compute the ceiling on valid object pointers w/in this segment.
2010 seg_end
= SCM_GC_CARD_DOWN ((char *)seg_org
+ size
);
2012 /* Find the right place and insert the segment record.
2015 for (new_seg_index
= 0;
2016 ( (new_seg_index
< scm_n_heap_segs
)
2017 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2023 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2024 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2029 scm_heap_table
[new_seg_index
].span
= span
;
2030 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2031 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
2032 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
2035 n_new_cells
= seg_end
- ptr
;
2037 freelist
->heap_size
+= n_new_cells
;
2039 /* Partition objects in this segment into clusters */
2042 SCM
*clusterp
= &clusters
;
2044 NEXT_DATA_CELL (ptr
, span
);
2045 while (ptr
< seg_end
)
2047 scm_cell
*nxt
= ptr
;
2048 scm_cell
*prv
= NULL
;
2049 scm_cell
*last_card
= NULL
;
2050 int n_data_cells
= (SCM_GC_CARD_N_DATA_CELLS
/ span
) * SCM_CARDS_PER_CLUSTER
- 1;
2051 NEXT_DATA_CELL(nxt
, span
);
2053 /* Allocate cluster spine
2055 *clusterp
= PTR2SCM (ptr
);
2056 SCM_SETCAR (*clusterp
, PTR2SCM (nxt
));
2057 clusterp
= SCM_CDRLOC (*clusterp
);
2060 while (n_data_cells
--)
2062 scm_cell
*card
= SCM_GC_CELL_CARD (ptr
);
2063 SCM scmptr
= PTR2SCM (ptr
);
2065 NEXT_DATA_CELL (nxt
, span
);
2068 if (card
!= last_card
)
2070 INIT_CARD (card
, span
);
2074 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
2075 SCM_SETCDR (scmptr
, PTR2SCM (nxt
));
2080 SCM_SET_FREE_CELL_CDR (PTR2SCM (prv
), SCM_EOL
);
2085 scm_cell
*ref
= seg_end
;
2086 NEXT_DATA_CELL (ref
, span
);
2088 /* [cmm] looks like the segment size doesn't divide cleanly by
2089 cluster size. bad cmm! */
2093 /* Patch up the last cluster pointer in the segment
2094 * to join it to the input freelist.
2096 *clusterp
= freelist
->clusters
;
2097 freelist
->clusters
= clusters
;
2101 fprintf (stderr
, "H");
2107 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
2109 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2112 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2113 + ALIGNMENT_SLACK (freelist
);
2117 alloc_some_heap (scm_freelist_t
*freelist
, policy_on_error error_policy
)
2118 #define FUNC_NAME "alloc_some_heap"
2123 if (scm_gc_heap_lock
)
2125 /* Critical code sections (such as the garbage collector) aren't
2126 * supposed to add heap segments.
2128 fprintf (stderr
, "alloc_some_heap: Can not extend locked heap.\n");
2132 if (scm_n_heap_segs
== heap_segment_table_size
)
2134 /* We have to expand the heap segment table to have room for the new
2135 * segment. Do not yet increment scm_n_heap_segs -- that is done by
2136 * init_heap_seg only if the allocation of the segment itself succeeds.
2138 unsigned int new_table_size
= scm_n_heap_segs
+ 1;
2139 size_t size
= new_table_size
* sizeof (scm_heap_seg_data_t
);
2140 scm_heap_seg_data_t
* new_heap_table
;
2142 SCM_SYSCALL (new_heap_table
= ((scm_heap_seg_data_t
*)
2143 realloc ((char *)scm_heap_table
, size
)));
2144 if (!new_heap_table
)
2146 if (error_policy
== abort_on_error
)
2148 fprintf (stderr
, "alloc_some_heap: Could not grow heap segment table.\n");
2158 scm_heap_table
= new_heap_table
;
2159 heap_segment_table_size
= new_table_size
;
2163 /* Pick a size for the new heap segment.
2164 * The rule for picking the size of a segment is explained in
2168 /* Assure that the new segment is predicted to be large enough.
2170 * New yield should at least equal GC fraction of new heap size, i.e.
2172 * y + dh > f * (h + dh)
2175 * f : min yield fraction
2177 * dh : size of new heap segment
2179 * This gives dh > (f * h - y) / (1 - f)
2181 int f
= freelist
->min_yield_fraction
;
2182 long h
= SCM_HEAP_SIZE
;
2183 long min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2184 len
= SCM_EXPHEAP (freelist
->heap_size
);
2186 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2188 if (len
< min_cells
)
2189 len
= min_cells
+ freelist
->cluster_size
;
2190 len
*= sizeof (scm_cell
);
2191 /* force new sampling */
2192 freelist
->collected
= LONG_MAX
;
2195 if (len
> scm_max_segment_size
)
2196 len
= scm_max_segment_size
;
2201 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2206 /* Allocate with decaying ambition. */
2207 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2208 && (len
>= smallest
))
2210 scm_sizet rounded_len
= round_to_cluster_size (freelist
, len
);
2211 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2214 init_heap_seg (ptr
, rounded_len
, freelist
);
2221 if (error_policy
== abort_on_error
)
2223 fprintf (stderr
, "alloc_some_heap: Could not grow heap.\n");
2230 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2233 #define FUNC_NAME s_scm_unhash_name
2237 SCM_VALIDATE_SYMBOL (1,name
);
2239 bound
= scm_n_heap_segs
;
2240 for (x
= 0; x
< bound
; ++x
)
2244 p
= scm_heap_table
[x
].bounds
[0];
2245 pbound
= scm_heap_table
[x
].bounds
[1];
2248 SCM cell
= PTR2SCM (p
);
2249 if (SCM_TYP3 (cell
) == scm_tc3_cons_gloc
)
2251 /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
2252 * struct cell. See the corresponding comment in scm_gc_mark.
2254 scm_bits_t word0
= SCM_CELL_WORD_0 (cell
) - scm_tc3_cons_gloc
;
2255 SCM gloc_car
= SCM_PACK (word0
); /* access as gloc */
2256 SCM vcell
= SCM_CELL_OBJECT_1 (gloc_car
);
2257 if ((SCM_EQ_P (name
, SCM_BOOL_T
) || SCM_EQ_P (SCM_CAR (gloc_car
), name
))
2258 && (SCM_UNPACK (vcell
) != 0) && (SCM_UNPACK (vcell
) != 1))
2260 SCM_SET_CELL_OBJECT_0 (cell
, name
);
2273 /* {GC Protection Helper Functions}
2278 scm_remember (SCM
*ptr
)
2283 These crazy functions prevent garbage collection
2284 of arguments after the first argument by
2285 ensuring they remain live throughout the
2286 function because they are used in the last
2287 line of the code block.
2288 It'd be better to have a nice compiler hint to
2289 aid the conservative stack-scanning GC. --03/09/00 gjb */
2291 scm_return_first (SCM elt
, ...)
2297 scm_return_first_int (int i
, ...)
2304 scm_permanent_object (SCM obj
)
2307 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2313 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
2314 other references are dropped, until the object is unprotected by calling
2315 scm_unprotect_object (OBJ). Calls to scm_protect/unprotect_object nest,
2316 i. e. it is possible to protect the same object several times, but it is
2317 necessary to unprotect the object the same number of times to actually get
2318 the object unprotected. It is an error to unprotect an object more often
2319 than it has been protected before. The function scm_protect_object returns
2323 /* Implementation note: For every object X, there is a counter which
2324 scm_protect_object(X) increments and scm_unprotect_object(X) decrements.
2328 scm_protect_object (SCM obj
)
2332 /* This critical section barrier will be replaced by a mutex. */
2335 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, SCM_MAKINUM (0));
2336 SCM_SETCDR (handle
, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle
)) + 1));
2344 /* Remove any protection for OBJ established by a prior call to
2345 scm_protect_object. This function returns OBJ.
2347 See scm_protect_object for more information. */
2349 scm_unprotect_object (SCM obj
)
2353 /* This critical section barrier will be replaced by a mutex. */
2356 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2358 if (SCM_IMP (handle
))
2360 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
2365 unsigned long int count
= SCM_INUM (SCM_CDR (handle
)) - 1;
2367 scm_hashq_remove_x (scm_protects
, obj
);
2369 SCM_SETCDR (handle
, SCM_MAKINUM (count
));
2379 /* called on process termination. */
2385 extern int on_exit (void (*procp
) (), int arg
);
2388 cleanup (int status
, void *arg
)
2390 #error Dont know how to setup a cleanup handler on your system.
2395 scm_flush_all_ports ();
2400 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2402 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2404 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2408 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2409 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2417 if (freelist
->min_yield_fraction
)
2418 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2420 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2427 init_freelist (scm_freelist_t
*freelist
,
2432 freelist
->clusters
= SCM_EOL
;
2433 freelist
->cluster_size
= cluster_size
+ 1;
2434 freelist
->left_to_collect
= 0;
2435 freelist
->clusters_allocated
= 0;
2436 freelist
->min_yield
= 0;
2437 freelist
->min_yield_fraction
= min_yield
;
2438 freelist
->span
= span
;
2439 freelist
->collected
= 0;
2440 freelist
->collected_1
= 0;
2441 freelist
->heap_size
= 0;
2445 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2446 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2447 scm_sizet max_segment_size
)
2451 if (!init_heap_size_1
)
2452 init_heap_size_1
= scm_default_init_heap_size_1
;
2453 if (!init_heap_size_2
)
2454 init_heap_size_2
= scm_default_init_heap_size_2
;
2456 j
= SCM_NUM_PROTECTS
;
2458 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2461 scm_freelist
= SCM_EOL
;
2462 scm_freelist2
= SCM_EOL
;
2463 init_freelist (&scm_master_freelist
,
2464 1, SCM_CLUSTER_SIZE_1
,
2465 gc_trigger_1
? gc_trigger_1
: scm_default_min_yield_1
);
2466 init_freelist (&scm_master_freelist2
,
2467 2, SCM_CLUSTER_SIZE_2
,
2468 gc_trigger_2
? gc_trigger_2
: scm_default_min_yield_2
);
2469 scm_max_segment_size
2470 = max_segment_size
? max_segment_size
: scm_default_max_segment_size
;
2474 j
= SCM_HEAP_SEG_SIZE
;
2475 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2476 scm_heap_table
= ((scm_heap_seg_data_t
*)
2477 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2478 heap_segment_table_size
= 2;
2480 mark_space_ptr
= &mark_space_head
;
2482 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2483 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2486 /* scm_hplims[0] can change. do not remove scm_heap_org */
2487 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2489 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2490 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2491 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2492 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2493 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2495 /* Initialise the list of ports. */
2496 scm_port_table
= (scm_port
**)
2497 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2498 if (!scm_port_table
)
2505 on_exit (cleanup
, 0);
2509 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2510 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2512 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2513 scm_nullstr
= scm_makstr (0L, 0);
2514 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2515 scm_symhash
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2516 scm_weak_symhash
= scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim
));
2517 scm_symhash_vars
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2518 scm_stand_in_procs
= SCM_EOL
;
2519 scm_permobjs
= SCM_EOL
;
2520 scm_protects
= scm_make_vector (SCM_MAKINUM (31), SCM_EOL
);
2521 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2522 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2524 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));
2532 SCM scm_after_gc_hook
;
2534 #if (SCM_DEBUG_DEPRECATED == 0)
2535 static SCM scm_gc_vcell
; /* the vcell for gc-thunk. */
2536 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2537 static SCM gc_async
;
2540 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
2541 * is run after the gc, as soon as the asynchronous events are handled by the
2545 gc_async_thunk (void)
2547 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
2549 #if (SCM_DEBUG_DEPRECATED == 0)
2551 /* The following code will be removed in Guile 1.5. */
2552 if (SCM_NFALSEP (scm_gc_vcell
))
2554 SCM proc
= SCM_CDR (scm_gc_vcell
);
2556 if (SCM_NFALSEP (proc
) && !SCM_UNBNDP (proc
))
2557 scm_apply (proc
, SCM_EOL
, SCM_EOL
);
2560 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2562 return SCM_UNSPECIFIED
;
2566 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
2567 * the garbage collection. The only purpose of this function is to mark the
2568 * gc_async (which will eventually lead to the execution of the
2572 mark_gc_async (void * hook_data
, void *func_data
, void *data
)
2574 scm_system_async_mark (gc_async
);
2584 scm_after_gc_hook
= scm_create_hook ("after-gc-hook", 0);
2586 #if (SCM_DEBUG_DEPRECATED == 0)
2587 scm_gc_vcell
= scm_sysintern ("gc-thunk", SCM_BOOL_F
);
2588 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2589 /* Dirk:FIXME:: We don't really want a binding here. */
2590 after_gc_thunk
= scm_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk
);
2591 gc_async
= scm_system_async (after_gc_thunk
);
2593 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
2595 #include "libguile/gc.x"