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/stime.h"
51 #include "libguile/stackchk.h"
52 #include "libguile/struct.h"
53 #include "libguile/weaks.h"
54 #include "libguile/guardians.h"
55 #include "libguile/smob.h"
56 #include "libguile/unif.h"
57 #include "libguile/async.h"
58 #include "libguile/ports.h"
59 #include "libguile/root.h"
60 #include "libguile/strings.h"
61 #include "libguile/vectors.h"
63 #include "libguile/validate.h"
64 #include "libguile/gc.h"
66 #ifdef GUILE_DEBUG_MALLOC
67 #include "libguile/debug-malloc.h"
80 #define var_start(x, y) va_start(x, y)
83 #define var_start(x, y) va_start(x)
87 /* {heap tuning parameters}
89 * These are parameters for controlling memory allocation. The heap
90 * is the area out of which scm_cons, and object headers are allocated.
92 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
93 * 64 bit machine. The units of the _SIZE parameters are bytes.
94 * Cons pairs and object headers occupy one heap cell.
96 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
97 * allocated initially the heap will grow by half its current size
98 * each subsequent time more heap is needed.
100 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
101 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
102 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
103 * is in scm_init_storage() and alloc_some_heap() in sys.c
105 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
106 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
108 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
111 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
114 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
115 * reclaimed by a GC triggered by must_malloc. If less than this is
116 * reclaimed, the trigger threshold is raised. [I don't know what a
117 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
118 * work around a oscillation that caused almost constant GC.]
122 * Heap size 45000 and 40% min yield gives quick startup and no extra
123 * heap allocation. Having higher values on min yield may lead to
124 * large heaps, especially if code behaviour is varying its
125 * maximum consumption between different freelists.
127 #define SCM_INIT_HEAP_SIZE_1 (45000L * sizeof (scm_cell))
128 #define SCM_CLUSTER_SIZE_1 2000L
129 #define SCM_MIN_YIELD_1 40
131 #define SCM_INIT_HEAP_SIZE_2 (2500L * 2 * sizeof (scm_cell))
132 #define SCM_CLUSTER_SIZE_2 1000L
133 /* The following value may seem large, but note that if we get to GC at
134 * all, this means that we have a numerically intensive application
136 #define SCM_MIN_YIELD_2 40
138 #define SCM_MAX_SEGMENT_SIZE 2097000L /* a little less (adm) than 2 Mb */
140 #define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell))
142 # define SCM_HEAP_SEG_SIZE 32768L
145 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
147 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
150 /* Make heap grow with factor 1.5 */
151 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
152 #define SCM_INIT_MALLOC_LIMIT 100000
153 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
155 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
156 bounds for allocated storage */
159 /*in 386 protected mode we must only adjust the offset */
160 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
161 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
164 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
165 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
167 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
168 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
171 #define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell))
172 #define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1)
173 #ifdef GUILE_NEW_GC_SCHEME
174 #define SCM_HEAP_SIZE \
175 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
177 #define SCM_HEAP_SIZE (scm_freelist.heap_size + scm_freelist2.heap_size)
179 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
186 typedef struct scm_freelist_t
{
187 /* collected cells */
189 #ifdef GUILE_NEW_GC_SCHEME
190 /* number of cells left to collect before cluster is full */
191 unsigned int left_to_collect
;
192 /* number of clusters which have been allocated */
193 unsigned int clusters_allocated
;
194 /* a list of freelists, each of size cluster_size,
195 * except the last one which may be shorter
199 /* this is the number of objects in each cluster, including the spine cell */
201 /* indicates that we should grow heap instead of GC:ing
204 /* minimum yield on this list in order not to grow the heap
207 /* defines min_yield as percent of total heap size
209 int min_yield_fraction
;
211 /* number of cells per object on this list */
213 /* number of collected cells during last GC */
215 /* number of collected cells during penultimate GC */
217 /* total number of cells in heap segments
218 * belonging to this list.
223 #ifdef GUILE_NEW_GC_SCHEME
224 SCM scm_freelist
= SCM_EOL
;
225 scm_freelist_t scm_master_freelist
= {
226 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
228 SCM scm_freelist2
= SCM_EOL
;
229 scm_freelist_t scm_master_freelist2
= {
230 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
233 scm_freelist_t scm_freelist
= { SCM_EOL
, 1, 0, 0 };
234 scm_freelist_t scm_freelist2
= { SCM_EOL
, 2, 0, 0 };
238 * is the number of bytes of must_malloc allocation needed to trigger gc.
240 unsigned long scm_mtrigger
;
244 * If set, don't expand the heap. Set only during gc, during which no allocation
245 * is supposed to take place anyway.
247 int scm_gc_heap_lock
= 0;
250 * Don't pause for collection if this is set -- just
254 int scm_block_gc
= 1;
256 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
257 * collection (GC) more space is allocated for the heap.
259 #define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
261 /* During collection, this accumulates objects holding
264 SCM scm_weak_vectors
;
266 /* GC Statistics Keeping
268 unsigned long scm_cells_allocated
= 0;
269 long scm_mallocated
= 0;
270 unsigned long scm_gc_cells_collected
;
271 #ifdef GUILE_NEW_GC_SCHEME
272 unsigned long scm_gc_yield
;
273 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
275 unsigned long scm_gc_malloc_collected
;
276 unsigned long scm_gc_ports_collected
;
277 unsigned long scm_gc_rt
;
278 unsigned long scm_gc_time_taken
= 0;
280 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
281 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
282 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
283 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
284 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
285 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
287 typedef struct scm_heap_seg_data_t
289 /* lower and upper bounds of the segment */
290 SCM_CELLPTR bounds
[2];
292 /* address of the head-of-freelist pointer for this segment's cells.
293 All segments usually point to the same one, scm_freelist. */
294 scm_freelist_t
*freelist
;
296 /* number of SCM words per object in this segment */
299 /* If SEG_DATA->valid is non-zero, the conservative marking
300 functions will apply SEG_DATA->valid to the purported pointer and
301 SEG_DATA, and mark the object iff the function returns non-zero.
302 At the moment, I don't think anyone uses this. */
304 } scm_heap_seg_data_t
;
309 static void scm_mark_weak_vector_spines (void);
310 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
311 static void alloc_some_heap (scm_freelist_t
*);
315 /* Debugging functions. */
317 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
319 /* Return the number of the heap segment containing CELL. */
325 for (i
= 0; i
< scm_n_heap_segs
; i
++)
326 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
327 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
329 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
335 #ifdef GUILE_NEW_GC_SCHEME
337 map_free_list (scm_freelist_t
*master
, SCM freelist
)
339 int last_seg
= -1, count
= 0;
342 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
344 int this_seg
= which_seg (f
);
346 if (this_seg
!= last_seg
)
349 fprintf (stderr
, " %5d %d-cells in segment %d\n",
350 count
, master
->span
, last_seg
);
357 fprintf (stderr
, " %5d %d-cells in segment %d\n",
358 count
, master
->span
, last_seg
);
362 map_free_list (scm_freelist_t
*freelist
)
364 int last_seg
= -1, count
= 0;
367 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
))
369 int this_seg
= which_seg (f
);
371 if (this_seg
!= last_seg
)
374 fprintf (stderr
, " %5d %d-cells in segment %d\n",
375 count
, freelist
->span
, last_seg
);
382 fprintf (stderr
, " %5d %d-cells in segment %d\n",
383 count
, freelist
->span
, last_seg
);
387 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
389 "Print debugging information about the free-list.\n"
390 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
391 #define FUNC_NAME s_scm_map_free_list
394 fprintf (stderr
, "%d segments total (%d:%d",
396 scm_heap_table
[0].span
,
397 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
398 for (i
= 1; i
< scm_n_heap_segs
; i
++)
399 fprintf (stderr
, ", %d:%d",
400 scm_heap_table
[i
].span
,
401 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
402 fprintf (stderr
, ")\n");
403 #ifdef GUILE_NEW_GC_SCHEME
404 map_free_list (&scm_master_freelist
, scm_freelist
);
405 map_free_list (&scm_master_freelist2
, scm_freelist2
);
407 map_free_list (&scm_freelist
);
408 map_free_list (&scm_freelist2
);
412 return SCM_UNSPECIFIED
;
416 #ifdef GUILE_NEW_GC_SCHEME
417 static int last_cluster
;
418 static int last_size
;
421 free_list_length (char *title
, int i
, SCM freelist
)
425 for (ls
= freelist
; SCM_NNULLP (ls
); ls
= SCM_CDR (ls
))
426 if (SCM_UNPACK_CAR (ls
) == scm_tc_free_cell
)
430 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
437 if (last_cluster
== i
- 1)
438 fprintf (stderr
, "\t%d\n", last_size
);
440 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
443 fprintf (stderr
, "%s %d", title
, i
);
445 fprintf (stderr
, "%s\t%d\n", title
, n
);
453 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
456 int i
= 0, len
, n
= 0;
457 fprintf (stderr
, "%s\n\n", title
);
458 n
+= free_list_length ("free list", -1, freelist
);
459 for (clusters
= master
->clusters
;
460 SCM_NNULLP (clusters
);
461 clusters
= SCM_CDR (clusters
))
463 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
466 if (last_cluster
== i
- 1)
467 fprintf (stderr
, "\t%d\n", last_size
);
469 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
470 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
473 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
475 "Print debugging information about the free-list.\n"
476 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
477 #define FUNC_NAME s_scm_free_list_length
479 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
480 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
481 return SCM_UNSPECIFIED
;
488 #ifdef GUILE_DEBUG_FREELIST
490 /* Number of calls to SCM_NEWCELL since startup. */
491 static unsigned long scm_newcell_count
;
492 static unsigned long scm_newcell2_count
;
494 /* Search freelist for anything that isn't marked as a free cell.
495 Abort if we find something. */
496 #ifdef GUILE_NEW_GC_SCHEME
498 scm_check_freelist (SCM freelist
)
503 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
504 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
506 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
507 scm_newcell_count
, i
);
514 scm_check_freelist (scm_freelist_t
*freelist
)
519 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
520 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
522 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
523 scm_newcell_count
, i
);
530 static int scm_debug_check_freelist
= 0;
532 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
534 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
535 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
536 "compile-time flag was selected.\n")
537 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
539 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
540 return SCM_UNSPECIFIED
;
545 #ifdef GUILE_NEW_GC_SCHEME
548 scm_debug_newcell (void)
553 if (scm_debug_check_freelist
)
555 scm_check_freelist (scm_freelist
);
559 /* The rest of this is supposed to be identical to the SCM_NEWCELL
561 if (SCM_IMP (scm_freelist
))
562 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
566 scm_freelist
= SCM_CDR (scm_freelist
);
567 SCM_SETCAR (new, scm_tc16_allocated
);
574 scm_debug_newcell2 (void)
578 scm_newcell2_count
++;
579 if (scm_debug_check_freelist
)
581 scm_check_freelist (scm_freelist2
);
585 /* The rest of this is supposed to be identical to the SCM_NEWCELL
587 if (SCM_IMP (scm_freelist2
))
588 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
592 scm_freelist2
= SCM_CDR (scm_freelist2
);
593 SCM_SETCAR (new, scm_tc16_allocated
);
599 #else /* GUILE_NEW_GC_SCHEME */
602 scm_debug_newcell (void)
607 if (scm_debug_check_freelist
)
609 scm_check_freelist (&scm_freelist
);
613 /* The rest of this is supposed to be identical to the SCM_NEWCELL
615 if (SCM_IMP (scm_freelist
.cells
))
616 new = scm_gc_for_newcell (&scm_freelist
);
619 new = scm_freelist
.cells
;
620 scm_freelist
.cells
= SCM_CDR (scm_freelist
.cells
);
621 SCM_SETCAR (new, scm_tc16_allocated
);
622 ++scm_cells_allocated
;
629 scm_debug_newcell2 (void)
633 scm_newcell2_count
++;
634 if (scm_debug_check_freelist
) {
635 scm_check_freelist (&scm_freelist2
);
639 /* The rest of this is supposed to be identical to the SCM_NEWCELL2
641 if (SCM_IMP (scm_freelist2
.cells
))
642 new = scm_gc_for_newcell (&scm_freelist2
);
645 new = scm_freelist2
.cells
;
646 scm_freelist2
.cells
= SCM_CDR (scm_freelist2
.cells
);
647 SCM_SETCAR (new, scm_tc16_allocated
);
648 scm_cells_allocated
+= 2;
654 #endif /* GUILE_NEW_GC_SCHEME */
655 #endif /* GUILE_DEBUG_FREELIST */
659 #ifdef GUILE_NEW_GC_SCHEME
661 master_cells_allocated (scm_freelist_t
*master
)
663 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
664 if (SCM_NULLP (master
->clusters
))
665 objects
-= master
->left_to_collect
;
666 return master
->span
* objects
;
670 freelist_length (SCM freelist
)
673 for (n
= 0; SCM_NNULLP (freelist
); freelist
= SCM_CDR (freelist
))
679 compute_cells_allocated ()
681 return (scm_cells_allocated
682 + master_cells_allocated (&scm_master_freelist
)
683 + master_cells_allocated (&scm_master_freelist2
)
684 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
685 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
689 /* {Scheme Interface to GC}
692 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
694 "Returns an association list of statistics about Guile's current use of storage. ")
695 #define FUNC_NAME s_scm_gc_stats
700 long int local_scm_mtrigger
;
701 long int local_scm_mallocated
;
702 long int local_scm_heap_size
;
703 long int local_scm_cells_allocated
;
704 long int local_scm_gc_time_taken
;
712 for (i
= scm_n_heap_segs
; i
--; )
713 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
714 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
716 if (scm_n_heap_segs
!= n
)
720 /* Below, we cons to produce the resulting list. We want a snapshot of
721 * the heap situation before consing.
723 local_scm_mtrigger
= scm_mtrigger
;
724 local_scm_mallocated
= scm_mallocated
;
725 local_scm_heap_size
= SCM_HEAP_SIZE
;
726 #ifdef GUILE_NEW_GC_SCHEME
727 local_scm_cells_allocated
= compute_cells_allocated ();
729 local_scm_cells_allocated
= scm_cells_allocated
;
731 local_scm_gc_time_taken
= scm_gc_time_taken
;
733 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
734 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
735 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
736 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
737 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
738 scm_cons (sym_heap_segments
, heap_segs
),
747 scm_gc_start (const char *what
)
749 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
750 scm_gc_cells_collected
= 0;
751 #ifdef GUILE_NEW_GC_SCHEME
752 scm_gc_yield_1
= scm_gc_yield
;
753 scm_gc_yield
= (scm_cells_allocated
754 + master_cells_allocated (&scm_master_freelist
)
755 + master_cells_allocated (&scm_master_freelist2
));
757 scm_gc_malloc_collected
= 0;
758 scm_gc_ports_collected
= 0;
764 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
765 scm_gc_time_taken
+= scm_gc_rt
;
766 scm_system_async_mark (scm_gc_async
);
770 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
772 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
773 "returned by this function for @var{obj}")
774 #define FUNC_NAME s_scm_object_address
776 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
781 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
783 "Scans all of SCM objects and reclaims for further use those that are\n"
784 "no longer accessible.")
785 #define FUNC_NAME s_scm_gc
790 return SCM_UNSPECIFIED
;
796 /* {C Interface For When GC is Triggered}
799 #ifdef GUILE_NEW_GC_SCHEME
802 adjust_min_yield (scm_freelist_t
*freelist
)
804 /* min yield is adjusted upwards so that next predicted total yield
805 * (allocated cells actually freed by GC) becomes
806 * `min_yield_fraction' of total heap size. Note, however, that
807 * the absolute value of min_yield will correspond to `collected'
808 * on one master (the one which currently is triggering GC).
810 * The reason why we look at total yield instead of cells collected
811 * on one list is that we want to take other freelists into account.
812 * On this freelist, we know that (local) yield = collected cells,
813 * but that's probably not the case on the other lists.
815 * (We might consider computing a better prediction, for example
816 * by computing an average over multiple GC:s.)
818 if (freelist
->min_yield_fraction
)
820 /* Pick largest of last two yields. */
821 int delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
822 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
824 fprintf (stderr
, " after GC = %d, delta = %d\n",
829 freelist
->min_yield
+= delta
;
833 /* When we get POSIX threads support, the master will be global and
834 * common while the freelist will be individual for each thread.
838 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
844 if (SCM_NULLP (master
->clusters
))
846 if (master
->grow_heap_p
)
848 master
->grow_heap_p
= 0;
849 alloc_some_heap (master
);
854 fprintf (stderr
, "allocated = %d, ",
856 + master_cells_allocated (&scm_master_freelist
)
857 + master_cells_allocated (&scm_master_freelist2
));
860 adjust_min_yield (master
);
863 cell
= SCM_CAR (master
->clusters
);
864 master
->clusters
= SCM_CDR (master
->clusters
);
865 ++master
->clusters_allocated
;
867 while (SCM_NULLP (cell
));
869 *freelist
= SCM_CDR (cell
);
870 SCM_SET_CELL_TYPE (cell
, scm_tc16_allocated
);
875 /* This is a support routine which can be used to reserve a cluster
876 * for some special use, such as debugging. It won't be useful until
877 * free cells are preserved between garbage collections.
881 scm_alloc_cluster (scm_freelist_t
*master
)
884 cell
= scm_gc_for_newcell (master
, &freelist
);
885 SCM_SETCDR (cell
, freelist
);
890 #else /* GUILE_NEW_GC_SCHEME */
893 scm_gc_for_alloc (scm_freelist_t
*freelist
)
897 #ifdef GUILE_DEBUG_FREELIST
898 fprintf (stderr
, "Collected: %d, min_yield: %d\n",
899 freelist
->collected
, MIN_GC_YIELD (freelist
));
901 if ((freelist
->collected
< MIN_GC_YIELD (freelist
))
902 || SCM_IMP (freelist
->cells
))
903 alloc_some_heap (freelist
);
909 scm_gc_for_newcell (scm_freelist_t
*freelist
)
912 scm_gc_for_alloc (freelist
);
913 fl
= freelist
->cells
;
914 freelist
->cells
= SCM_CDR (fl
);
915 SCM_SETCAR (fl
, scm_tc16_allocated
);
919 #endif /* GUILE_NEW_GC_SCHEME */
922 scm_igc (const char *what
)
928 SCM_NULLP (scm_freelist
)
930 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
933 /* During the critical section, only the current thread may run. */
934 SCM_THREAD_CRITICAL_SECTION_START
;
937 /* fprintf (stderr, "gc: %s\n", what); */
941 if (!scm_stack_base
|| scm_block_gc
)
947 if (scm_mallocated
< 0)
948 /* The byte count of allocated objects has underflowed. This is
949 probably because you forgot to report the sizes of objects you
950 have allocated, by calling scm_done_malloc or some such. When
951 the GC freed them, it subtracted their size from
952 scm_mallocated, which underflowed. */
955 if (scm_gc_heap_lock
)
956 /* We've invoked the collector while a GC is already in progress.
957 That should never happen. */
962 scm_weak_vectors
= SCM_EOL
;
964 scm_guardian_gc_init ();
966 /* unprotect any struct types with no instances */
972 pos
= &scm_type_obj_list
;
973 type_list
= scm_type_obj_list
;
974 while (type_list
!= SCM_EOL
)
975 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
977 pos
= SCM_CDRLOC (type_list
);
978 type_list
= SCM_CDR (type_list
);
982 *pos
= SCM_CDR (type_list
);
983 type_list
= SCM_CDR (type_list
);
988 /* flush dead entries from the continuation stack */
993 elts
= SCM_VELTS (scm_continuation_stack
);
994 bound
= SCM_LENGTH (scm_continuation_stack
);
995 x
= SCM_INUM (scm_continuation_stack_ptr
);
998 elts
[x
] = SCM_BOOL_F
;
1005 /* Protect from the C stack. This must be the first marking
1006 * done because it provides information about what objects
1007 * are "in-use" by the C code. "in-use" objects are those
1008 * for which the values from SCM_LENGTH and SCM_CHARS must remain
1009 * usable. This requirement is stricter than a liveness
1010 * requirement -- in particular, it constrains the implementation
1011 * of scm_vector_set_length_x.
1013 SCM_FLUSH_REGISTER_WINDOWS
;
1014 /* This assumes that all registers are saved into the jmp_buf */
1015 setjmp (scm_save_regs_gc_mark
);
1016 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1017 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
1018 sizeof scm_save_regs_gc_mark
)
1019 / sizeof (SCM_STACKITEM
)));
1022 /* stack_len is long rather than scm_sizet in order to guarantee that
1023 &stack_len is long aligned */
1024 #ifdef SCM_STACK_GROWS_UP
1026 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
1028 long stack_len
= scm_stack_size (scm_stack_base
);
1030 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
1033 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
1035 long stack_len
= scm_stack_size (scm_stack_base
);
1037 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
1041 #else /* USE_THREADS */
1043 /* Mark every thread's stack and registers */
1044 scm_threads_mark_stacks ();
1046 #endif /* USE_THREADS */
1048 /* FIXME: insert a phase to un-protect string-data preserved
1049 * in scm_vector_set_length_x.
1052 j
= SCM_NUM_PROTECTS
;
1054 scm_gc_mark (scm_sys_protects
[j
]);
1056 /* FIXME: we should have a means to register C functions to be run
1057 * in different phases of GC
1059 scm_mark_subr_table ();
1062 scm_gc_mark (scm_root
->handle
);
1065 scm_mark_weak_vector_spines ();
1067 scm_guardian_zombify ();
1075 SCM_THREAD_CRITICAL_SECTION_END
;
1085 /* Mark an object precisely.
1100 if (SCM_NCELLP (ptr
))
1101 scm_wta (ptr
, "rogue pointer in heap", NULL
);
1103 switch (SCM_TYP7 (ptr
))
1105 case scm_tcs_cons_nimcar
:
1106 if (SCM_GCMARKP (ptr
))
1108 SCM_SETGCMARK (ptr
);
1109 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
1111 ptr
= SCM_CAR (ptr
);
1114 scm_gc_mark (SCM_CAR (ptr
));
1115 ptr
= SCM_GCCDR (ptr
);
1117 case scm_tcs_cons_imcar
:
1118 if (SCM_GCMARKP (ptr
))
1120 SCM_SETGCMARK (ptr
);
1121 ptr
= SCM_GCCDR (ptr
);
1124 if (SCM_GCMARKP (ptr
))
1126 SCM_SETGCMARK (ptr
);
1127 scm_gc_mark (SCM_CELL_OBJECT_2 (ptr
));
1128 ptr
= SCM_GCCDR (ptr
);
1130 case scm_tcs_cons_gloc
:
1131 if (SCM_GCMARKP (ptr
))
1133 SCM_SETGCMARK (ptr
);
1135 /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
1136 * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
1137 * to a heap cell. If it is a struct, the cell word #0 of ptr is a
1138 * pointer to a struct vtable data region. The fact that these are
1139 * accessed in the same way restricts the possibilites to change the
1140 * data layout of structs or heap cells.
1142 scm_bits_t word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
1143 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1144 switch (vtable_data
[scm_vtable_index_vcell
])
1149 SCM gloc_car
= SCM_PACK (word0
);
1150 scm_gc_mark (gloc_car
);
1151 ptr
= SCM_GCCDR (ptr
);
1157 /* ptr is a struct */
1158 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
1159 int len
= SCM_LENGTH (layout
);
1160 char * fields_desc
= SCM_CHARS (layout
);
1161 /* We're using SCM_GCCDR here like STRUCT_DATA, except
1162 that it removes the mark */
1163 scm_bits_t
* struct_data
= (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (ptr
));
1165 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
1167 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
1168 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1174 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1175 if (fields_desc
[x
] == 'p')
1176 scm_gc_mark (SCM_PACK (*struct_data
));
1177 if (fields_desc
[x
] == 'p')
1179 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1180 for (x
= *struct_data
; x
; --x
)
1181 scm_gc_mark (SCM_PACK (*++struct_data
));
1183 scm_gc_mark (SCM_PACK (*struct_data
));
1186 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1188 vtable_data
[scm_vtable_index_vcell
] = 1;
1189 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1196 case scm_tcs_closures
:
1197 if (SCM_GCMARKP (ptr
))
1199 SCM_SETGCMARK (ptr
);
1200 if (SCM_IMP (SCM_CDR (ptr
)))
1202 ptr
= SCM_CLOSCAR (ptr
);
1205 scm_gc_mark (SCM_CLOSCAR (ptr
));
1206 ptr
= SCM_GCCDR (ptr
);
1208 case scm_tc7_vector
:
1209 case scm_tc7_lvector
:
1213 if (SCM_GC8MARKP (ptr
))
1215 SCM_SETGC8MARK (ptr
);
1216 i
= SCM_LENGTH (ptr
);
1220 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1221 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1222 ptr
= SCM_VELTS (ptr
)[0];
1224 case scm_tc7_contin
:
1227 SCM_SETGC8MARK (ptr
);
1228 if (SCM_VELTS (ptr
))
1229 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1232 (sizeof (SCM_STACKITEM
) + -1 +
1233 sizeof (scm_contregs
)) /
1234 sizeof (SCM_STACKITEM
)));
1238 case scm_tc7_byvect
:
1245 #ifdef HAVE_LONG_LONGS
1246 case scm_tc7_llvect
:
1249 case scm_tc7_string
:
1250 SCM_SETGC8MARK (ptr
);
1253 case scm_tc7_substring
:
1254 if (SCM_GC8MARKP(ptr
))
1256 SCM_SETGC8MARK (ptr
);
1257 ptr
= SCM_CDR (ptr
);
1261 if (SCM_GC8MARKP(ptr
))
1263 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1264 scm_weak_vectors
= ptr
;
1265 SCM_SETGC8MARK (ptr
);
1266 if (SCM_IS_WHVEC_ANY (ptr
))
1273 len
= SCM_LENGTH (ptr
);
1274 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1275 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1277 for (x
= 0; x
< len
; ++x
)
1280 alist
= SCM_VELTS (ptr
)[x
];
1282 /* mark everything on the alist except the keys or
1283 * values, according to weak_values and weak_keys. */
1284 while ( SCM_CONSP (alist
)
1285 && !SCM_GCMARKP (alist
)
1286 && SCM_CONSP (SCM_CAR (alist
)))
1291 kvpair
= SCM_CAR (alist
);
1292 next_alist
= SCM_CDR (alist
);
1295 * SCM_SETGCMARK (alist);
1296 * SCM_SETGCMARK (kvpair);
1298 * It may be that either the key or value is protected by
1299 * an escaped reference to part of the spine of this alist.
1300 * If we mark the spine here, and only mark one or neither of the
1301 * key and value, they may never be properly marked.
1302 * This leads to a horrible situation in which an alist containing
1303 * freelist cells is exported.
1305 * So only mark the spines of these arrays last of all marking.
1306 * If somebody confuses us by constructing a weak vector
1307 * with a circular alist then we are hosed, but at least we
1308 * won't prematurely drop table entries.
1311 scm_gc_mark (SCM_CAR (kvpair
));
1313 scm_gc_mark (SCM_GCCDR (kvpair
));
1316 if (SCM_NIMP (alist
))
1317 scm_gc_mark (alist
);
1322 case scm_tc7_msymbol
:
1323 if (SCM_GC8MARKP(ptr
))
1325 SCM_SETGC8MARK (ptr
);
1326 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1327 ptr
= SCM_SYMBOL_PROPS (ptr
);
1329 case scm_tc7_ssymbol
:
1330 if (SCM_GC8MARKP(ptr
))
1332 SCM_SETGC8MARK (ptr
);
1337 i
= SCM_PTOBNUM (ptr
);
1338 if (!(i
< scm_numptob
))
1340 if (SCM_GC8MARKP (ptr
))
1342 SCM_SETGC8MARK (ptr
);
1343 if (SCM_PTAB_ENTRY(ptr
))
1344 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1345 if (scm_ptobs
[i
].mark
)
1347 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1354 if (SCM_GC8MARKP (ptr
))
1356 SCM_SETGC8MARK (ptr
);
1357 switch (SCM_GCTYP16 (ptr
))
1358 { /* should be faster than going through scm_smobs */
1359 case scm_tc_free_cell
:
1360 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1361 case scm_tc16_allocated
:
1364 case scm_tc16_complex
:
1367 i
= SCM_SMOBNUM (ptr
);
1368 if (!(i
< scm_numsmob
))
1370 if (scm_smobs
[i
].mark
)
1372 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1380 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1385 /* Mark a Region Conservatively
1389 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1391 register long m
= n
;
1393 register SCM_CELLPTR ptr
;
1396 if (SCM_CELLP (* (SCM
*) &x
[m
]))
1398 ptr
= SCM2PTR (* (SCM
*) &x
[m
]);
1400 j
= scm_n_heap_segs
- 1;
1401 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1402 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1409 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1411 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1419 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1423 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1428 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1432 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1438 if (!scm_heap_table
[seg_id
].valid
1439 || scm_heap_table
[seg_id
].valid (ptr
,
1440 &scm_heap_table
[seg_id
]))
1441 if (scm_heap_table
[seg_id
].span
== 1
1442 || SCM_DOUBLE_CELLP (* (SCM
*) &x
[m
]))
1443 scm_gc_mark (* (SCM
*) &x
[m
]);
1452 /* The following is a C predicate which determines if an SCM value can be
1453 regarded as a pointer to a cell on the heap. The code is duplicated
1454 from scm_mark_locations. */
1458 scm_cellp (SCM value
)
1461 register SCM_CELLPTR ptr
;
1463 if (SCM_CELLP (value
))
1465 ptr
= SCM2PTR (value
);
1467 j
= scm_n_heap_segs
- 1;
1468 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1469 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1476 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1478 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1486 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1490 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1495 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1499 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1505 if (!scm_heap_table
[seg_id
].valid
1506 || scm_heap_table
[seg_id
].valid (ptr
,
1507 &scm_heap_table
[seg_id
]))
1508 if (scm_heap_table
[seg_id
].span
== 1
1509 || SCM_DOUBLE_CELLP (value
))
1510 scm_gc_mark (value
);
1521 scm_mark_weak_vector_spines ()
1525 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
1527 if (SCM_IS_WHVEC_ANY (w
))
1535 ptr
= SCM_VELTS (w
);
1537 for (j
= 0; j
< n
; ++j
)
1542 while ( SCM_CONSP (alist
)
1543 && !SCM_GCMARKP (alist
)
1544 && SCM_CONSP (SCM_CAR (alist
)))
1546 SCM_SETGCMARK (alist
);
1547 SCM_SETGCMARK (SCM_CAR (alist
));
1548 alist
= SCM_GCCDR (alist
);
1556 #ifdef GUILE_NEW_GC_SCHEME
1558 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1560 freelist
->cells
= SCM_EOL
;
1561 freelist
->left_to_collect
= freelist
->cluster_size
;
1562 freelist
->clusters_allocated
= 0;
1563 freelist
->clusters
= SCM_EOL
;
1564 freelist
->clustertail
= &freelist
->clusters
;
1565 freelist
->collected_1
= freelist
->collected
;
1566 freelist
->collected
= 0;
1570 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1573 *freelist
->clustertail
= freelist
->cells
;
1574 if (SCM_NNULLP (freelist
->cells
))
1576 SCM c
= freelist
->cells
;
1577 SCM_SETCAR (c
, SCM_CDR (c
));
1578 SCM_SETCDR (c
, SCM_EOL
);
1579 freelist
->collected
+=
1580 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1582 scm_gc_cells_collected
+= freelist
->collected
;
1584 /* Although freelist->min_yield is used to test freelist->collected
1585 * (which is the local GC yield for freelist), it is adjusted so
1586 * that *total* yield is freelist->min_yield_fraction of total heap
1587 * size. This means that a too low yield is compensated by more
1588 * heap on the list which is currently doing most work, which is
1589 * just what we want.
1591 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1592 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1599 register SCM_CELLPTR ptr
;
1600 register SCM nfreelist
;
1601 register scm_freelist_t
*freelist
;
1609 #ifdef GUILE_NEW_GC_SCHEME
1610 gc_sweep_freelist_start (&scm_master_freelist
);
1611 gc_sweep_freelist_start (&scm_master_freelist2
);
1613 /* Reset all free list pointers. We'll reconstruct them completely
1615 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1616 scm_heap_table
[i
].freelist
->cells
= SCM_EOL
;
1619 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1621 #ifdef GUILE_NEW_GC_SCHEME
1622 register unsigned int left_to_collect
;
1624 register scm_sizet n
= 0;
1626 register scm_sizet j
;
1628 /* Unmarked cells go onto the front of the freelist this heap
1629 segment points to. Rather than updating the real freelist
1630 pointer as we go along, we accumulate the new head in
1631 nfreelist. Then, if it turns out that the entire segment is
1632 free, we free (i.e., malloc's free) the whole segment, and
1633 simply don't assign nfreelist back into the real freelist. */
1634 freelist
= scm_heap_table
[i
].freelist
;
1635 nfreelist
= freelist
->cells
;
1636 #ifdef GUILE_NEW_GC_SCHEME
1637 left_to_collect
= freelist
->left_to_collect
;
1639 span
= scm_heap_table
[i
].span
;
1641 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1642 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1643 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1645 SCM scmptr
= PTR2SCM (ptr
);
1647 switch SCM_TYP7 (scmptr
)
1649 case scm_tcs_cons_gloc
:
1651 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1652 * struct or a gloc. See the corresponding comment in
1655 scm_bits_t word0
= SCM_CELL_WORD_0 (scmptr
) - scm_tc3_cons_gloc
;
1656 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1657 if (SCM_GCMARKP (scmptr
))
1659 if (vtable_data
[scm_vtable_index_vcell
] == 1)
1660 vtable_data
[scm_vtable_index_vcell
] = 0;
1665 if (vtable_data
[scm_vtable_index_vcell
] == 0
1666 || vtable_data
[scm_vtable_index_vcell
] == 1)
1668 scm_struct_free_t free
1669 = (scm_struct_free_t
) vtable_data
[scm_struct_i_free
];
1670 m
+= free (vtable_data
, (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (scmptr
)));
1675 case scm_tcs_cons_imcar
:
1676 case scm_tcs_cons_nimcar
:
1677 case scm_tcs_closures
:
1679 if (SCM_GCMARKP (scmptr
))
1683 if (SCM_GC8MARKP (scmptr
))
1689 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1690 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1694 case scm_tc7_vector
:
1695 case scm_tc7_lvector
:
1699 if (SCM_GC8MARKP (scmptr
))
1702 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1704 scm_must_free (SCM_CHARS (scmptr
));
1705 /* SCM_SETCHARS(scmptr, 0);*/
1709 if SCM_GC8MARKP (scmptr
)
1711 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1713 case scm_tc7_byvect
:
1714 if SCM_GC8MARKP (scmptr
)
1716 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1720 if SCM_GC8MARKP (scmptr
)
1722 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1725 if SCM_GC8MARKP (scmptr
)
1727 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1729 #ifdef HAVE_LONG_LONGS
1730 case scm_tc7_llvect
:
1731 if SCM_GC8MARKP (scmptr
)
1733 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1737 if SCM_GC8MARKP (scmptr
)
1739 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1742 if SCM_GC8MARKP (scmptr
)
1744 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1747 if SCM_GC8MARKP (scmptr
)
1749 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1752 case scm_tc7_substring
:
1753 if (SCM_GC8MARKP (scmptr
))
1756 case scm_tc7_string
:
1757 if (SCM_GC8MARKP (scmptr
))
1759 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1761 case scm_tc7_msymbol
:
1762 if (SCM_GC8MARKP (scmptr
))
1764 m
+= (SCM_LENGTH (scmptr
) + 1
1765 + (SCM_CHARS (scmptr
) - (char *) SCM_SLOTS (scmptr
)));
1766 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1768 case scm_tc7_contin
:
1769 if SCM_GC8MARKP (scmptr
)
1771 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1772 if (SCM_VELTS (scmptr
))
1774 case scm_tc7_ssymbol
:
1775 if SCM_GC8MARKP(scmptr
)
1781 if SCM_GC8MARKP (scmptr
)
1783 if SCM_OPENP (scmptr
)
1785 int k
= SCM_PTOBNUM (scmptr
);
1786 if (!(k
< scm_numptob
))
1788 /* Keep "revealed" ports alive. */
1789 if (scm_revealed_count (scmptr
) > 0)
1791 /* Yes, I really do mean scm_ptobs[k].free */
1792 /* rather than ftobs[k].close. .close */
1793 /* is for explicit CLOSE-PORT by user */
1794 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1795 SCM_SETSTREAM (scmptr
, 0);
1796 scm_remove_from_port_table (scmptr
);
1797 scm_gc_ports_collected
++;
1798 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1802 switch SCM_GCTYP16 (scmptr
)
1804 case scm_tc_free_cell
:
1806 if SCM_GC8MARKP (scmptr
)
1811 if SCM_GC8MARKP (scmptr
)
1813 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1815 #endif /* def SCM_BIGDIG */
1816 case scm_tc16_complex
:
1817 if SCM_GC8MARKP (scmptr
)
1819 m
+= 2 * sizeof (double);
1822 if SCM_GC8MARKP (scmptr
)
1827 k
= SCM_SMOBNUM (scmptr
);
1828 if (!(k
< scm_numsmob
))
1830 m
+= (scm_smobs
[k
].free
) (scmptr
);
1836 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1839 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1842 #ifndef GUILE_NEW_GC_SCHEME
1845 if (!--left_to_collect
)
1847 SCM_SETCAR (scmptr
, nfreelist
);
1848 *freelist
->clustertail
= scmptr
;
1849 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1851 nfreelist
= SCM_EOL
;
1852 freelist
->collected
+= span
* freelist
->cluster_size
;
1853 left_to_collect
= freelist
->cluster_size
;
1858 /* Stick the new cell on the front of nfreelist. It's
1859 critical that we mark this cell as freed; otherwise, the
1860 conservative collector might trace it as some other type
1862 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1863 SCM_SETCDR (scmptr
, nfreelist
);
1869 SCM_CLRGC8MARK (scmptr
);
1872 SCM_CLRGCMARK (scmptr
);
1874 #ifdef GC_FREE_SEGMENTS
1879 freelist
->heap_size
-= seg_size
;
1880 free ((char *) scm_heap_table
[i
].bounds
[0]);
1881 scm_heap_table
[i
].bounds
[0] = 0;
1882 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1883 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1884 scm_n_heap_segs
-= 1;
1885 i
--; /* We need to scan the segment just moved. */
1888 #endif /* ifdef GC_FREE_SEGMENTS */
1890 /* Update the real freelist pointer to point to the head of
1891 the list of free cells we've built for this segment. */
1892 freelist
->cells
= nfreelist
;
1893 #ifdef GUILE_NEW_GC_SCHEME
1894 freelist
->left_to_collect
= left_to_collect
;
1898 #ifndef GUILE_NEW_GC_SCHEME
1899 freelist
->collected
+= n
;
1902 #ifdef GUILE_DEBUG_FREELIST
1903 #ifdef GUILE_NEW_GC_SCHEME
1904 scm_check_freelist (freelist
== &scm_master_freelist
1908 scm_check_freelist (freelist
);
1910 scm_map_free_list ();
1914 #ifdef GUILE_NEW_GC_SCHEME
1915 gc_sweep_freelist_finish (&scm_master_freelist
);
1916 gc_sweep_freelist_finish (&scm_master_freelist2
);
1918 /* When we move to POSIX threads private freelists should probably
1919 be GC-protected instead. */
1920 scm_freelist
= SCM_EOL
;
1921 scm_freelist2
= SCM_EOL
;
1924 /* Scan weak vectors. */
1927 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
1929 if (!SCM_IS_WHVEC_ANY (w
))
1933 ptr
= SCM_VELTS (w
);
1935 for (j
= 0; j
< n
; ++j
)
1936 if (SCM_FREEP (ptr
[j
]))
1937 ptr
[j
] = SCM_BOOL_F
;
1939 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1942 register long n
= SCM_LENGTH (w
);
1945 ptr
= SCM_VELTS (w
);
1947 for (j
= 0; j
< n
; ++j
)
1954 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1955 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1960 while ( SCM_CONSP (alist
)
1961 && SCM_CONSP (SCM_CAR (alist
)))
1966 key
= SCM_CAAR (alist
);
1967 value
= SCM_CDAR (alist
);
1968 if ( (weak_keys
&& SCM_FREEP (key
))
1969 || (weak_values
&& SCM_FREEP (value
)))
1971 *fixup
= SCM_CDR (alist
);
1974 fixup
= SCM_CDRLOC (alist
);
1975 alist
= SCM_CDR (alist
);
1981 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1982 #ifdef GUILE_NEW_GC_SCHEME
1983 scm_gc_yield
-= scm_cells_allocated
;
1985 scm_mallocated
-= m
;
1986 scm_gc_malloc_collected
= m
;
1992 /* {Front end to malloc}
1994 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1996 * These functions provide services comperable to malloc, realloc, and
1997 * free. They are for allocating malloced parts of scheme objects.
1998 * The primary purpose of the front end is to impose calls to gc.
2003 * Return newly malloced storage or throw an error.
2005 * The parameter WHAT is a string for error reporting.
2006 * If the threshold scm_mtrigger will be passed by this
2007 * allocation, or if the first call to malloc fails,
2008 * garbage collect -- on the presumption that some objects
2009 * using malloced storage may be collected.
2011 * The limit scm_mtrigger may be raised by this allocation.
2014 scm_must_malloc (scm_sizet size
, const char *what
)
2017 unsigned long nm
= scm_mallocated
+ size
;
2019 if (nm
<= scm_mtrigger
)
2021 SCM_SYSCALL (ptr
= malloc (size
));
2024 scm_mallocated
= nm
;
2025 #ifdef GUILE_DEBUG_MALLOC
2026 scm_malloc_register (ptr
, what
);
2034 nm
= scm_mallocated
+ size
;
2035 SCM_SYSCALL (ptr
= malloc (size
));
2038 scm_mallocated
= nm
;
2039 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2040 if (nm
> scm_mtrigger
)
2041 scm_mtrigger
= nm
+ nm
/ 2;
2043 scm_mtrigger
+= scm_mtrigger
/ 2;
2045 #ifdef GUILE_DEBUG_MALLOC
2046 scm_malloc_register (ptr
, what
);
2052 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
2053 return 0; /* never reached */
2058 * is similar to scm_must_malloc.
2061 scm_must_realloc (void *where
,
2067 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
2069 if (nm
<= scm_mtrigger
)
2071 SCM_SYSCALL (ptr
= realloc (where
, size
));
2074 scm_mallocated
= nm
;
2075 #ifdef GUILE_DEBUG_MALLOC
2076 scm_malloc_reregister (where
, ptr
, what
);
2084 nm
= scm_mallocated
+ size
- old_size
;
2085 SCM_SYSCALL (ptr
= realloc (where
, size
));
2088 scm_mallocated
= nm
;
2089 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2090 if (nm
> scm_mtrigger
)
2091 scm_mtrigger
= nm
+ nm
/ 2;
2093 scm_mtrigger
+= scm_mtrigger
/ 2;
2095 #ifdef GUILE_DEBUG_MALLOC
2096 scm_malloc_reregister (where
, ptr
, what
);
2101 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
2102 return 0; /* never reached */
2106 scm_must_free (void *obj
)
2108 #ifdef GUILE_DEBUG_MALLOC
2109 scm_malloc_unregister (obj
);
2114 scm_wta (SCM_INUM0
, "already free", "");
2117 /* Announce that there has been some malloc done that will be freed
2118 * during gc. A typical use is for a smob that uses some malloced
2119 * memory but can not get it from scm_must_malloc (for whatever
2120 * reason). When a new object of this smob is created you call
2121 * scm_done_malloc with the size of the object. When your smob free
2122 * function is called, be sure to include this size in the return
2126 scm_done_malloc (long size
)
2128 scm_mallocated
+= size
;
2130 if (scm_mallocated
> scm_mtrigger
)
2132 scm_igc ("foreign mallocs");
2133 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
2135 if (scm_mallocated
> scm_mtrigger
)
2136 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
2138 scm_mtrigger
+= scm_mtrigger
/ 2;
2148 * Each heap segment is an array of objects of a particular size.
2149 * Every segment has an associated (possibly shared) freelist.
2150 * A table of segment records is kept that records the upper and
2151 * lower extents of the segment; this is used during the conservative
2152 * phase of gc to identify probably gc roots (because they point
2153 * into valid segments at reasonable offsets). */
2156 * is true if the first segment was smaller than INIT_HEAP_SEG.
2157 * If scm_expmem is set to one, subsequent segment allocations will
2158 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
2162 scm_sizet scm_max_segment_size
;
2165 * is the lowest base address of any heap segment.
2167 SCM_CELLPTR scm_heap_org
;
2169 scm_heap_seg_data_t
* scm_heap_table
= 0;
2170 int scm_n_heap_segs
= 0;
2173 * initializes a new heap segment and return the number of objects it contains.
2175 * The segment origin, segment size in bytes, and the span of objects
2176 * in cells are input parameters. The freelist is both input and output.
2178 * This function presume that the scm_heap_table has already been expanded
2179 * to accomodate a new segment record.
2184 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
2186 register SCM_CELLPTR ptr
;
2187 SCM_CELLPTR seg_end
;
2190 int span
= freelist
->span
;
2192 if (seg_org
== NULL
)
2195 ptr
= CELL_UP (seg_org
, span
);
2197 /* Compute the ceiling on valid object pointers w/in this segment.
2199 seg_end
= CELL_DN ((char *) seg_org
+ size
, span
);
2201 /* Find the right place and insert the segment record.
2204 for (new_seg_index
= 0;
2205 ( (new_seg_index
< scm_n_heap_segs
)
2206 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2212 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2213 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2218 scm_heap_table
[new_seg_index
].valid
= 0;
2219 scm_heap_table
[new_seg_index
].span
= span
;
2220 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2221 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
2222 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
2225 /* Compute the least valid object pointer w/in this segment
2227 ptr
= CELL_UP (ptr
, span
);
2231 n_new_cells
= seg_end
- ptr
;
2233 #ifdef GUILE_NEW_GC_SCHEME
2235 freelist
->heap_size
+= n_new_cells
;
2237 /* Partition objects in this segment into clusters */
2240 SCM
*clusterp
= &clusters
;
2241 int n_cluster_cells
= span
* freelist
->cluster_size
;
2243 while (n_new_cells
> span
) /* at least one spine + one freecell */
2245 /* Determine end of cluster
2247 if (n_new_cells
>= n_cluster_cells
)
2249 seg_end
= ptr
+ n_cluster_cells
;
2250 n_new_cells
-= n_cluster_cells
;
2253 /* [cmm] looks like the segment size doesn't divide cleanly by
2254 cluster size. bad cmm! */
2257 /* Allocate cluster spine
2259 *clusterp
= PTR2SCM (ptr
);
2260 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
2261 clusterp
= SCM_CDRLOC (*clusterp
);
2264 while (ptr
< seg_end
)
2266 SCM scmptr
= PTR2SCM (ptr
);
2268 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
2269 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2273 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
2276 /* Patch up the last cluster pointer in the segment
2277 * to join it to the input freelist.
2279 *clusterp
= freelist
->clusters
;
2280 freelist
->clusters
= clusters
;
2283 #else /* GUILE_NEW_GC_SCHEME */
2285 /* Prepend objects in this segment to the freelist.
2287 while (ptr
< seg_end
)
2289 SCM scmptr
= PTR2SCM (ptr
);
2291 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
2292 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2298 /* Patch up the last freelist pointer in the segment
2299 * to join it to the input freelist.
2301 SCM_SETCDR (PTR2SCM (ptr
), freelist
->cells
);
2302 freelist
->cells
= PTR2SCM (CELL_UP (seg_org
, span
));
2304 freelist
->heap_size
+= n_new_cells
;
2306 #endif /* GUILE_NEW_GC_SCHEME */
2309 fprintf (stderr
, "H");
2314 #ifndef GUILE_NEW_GC_SCHEME
2315 #define round_to_cluster_size(freelist, len) len
2319 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
2321 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2324 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2325 + ALIGNMENT_SLACK (freelist
);
2331 alloc_some_heap (scm_freelist_t
*freelist
)
2333 scm_heap_seg_data_t
* tmptable
;
2337 /* Critical code sections (such as the garbage collector)
2338 * aren't supposed to add heap segments.
2340 if (scm_gc_heap_lock
)
2341 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
2343 /* Expand the heap tables to have room for the new segment.
2344 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
2345 * only if the allocation of the segment itself succeeds.
2347 len
= (1 + scm_n_heap_segs
) * sizeof (scm_heap_seg_data_t
);
2349 SCM_SYSCALL (tmptable
= ((scm_heap_seg_data_t
*)
2350 realloc ((char *)scm_heap_table
, len
)));
2352 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
2354 scm_heap_table
= tmptable
;
2357 /* Pick a size for the new heap segment.
2358 * The rule for picking the size of a segment is explained in
2361 #ifdef GUILE_NEW_GC_SCHEME
2363 /* Assure that the new segment is predicted to be large enough.
2365 * New yield should at least equal GC fraction of new heap size, i.e.
2367 * y + dh > f * (h + dh)
2370 * f : min yield fraction
2372 * dh : size of new heap segment
2374 * This gives dh > (f * h - y) / (1 - f)
2376 int f
= freelist
->min_yield_fraction
;
2377 long h
= SCM_HEAP_SIZE
;
2378 long min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2379 len
= SCM_EXPHEAP (freelist
->heap_size
);
2381 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2383 if (len
< min_cells
)
2384 len
= min_cells
+ freelist
->cluster_size
;
2385 len
*= sizeof (scm_cell
);
2386 /* force new sampling */
2387 freelist
->collected
= LONG_MAX
;
2390 if (len
> scm_max_segment_size
)
2391 len
= scm_max_segment_size
;
2395 len
= (scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
));
2396 if ((scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
))
2401 len
= SCM_HEAP_SEG_SIZE
;
2402 #endif /* GUILE_NEW_GC_SCHEME */
2407 #ifndef GUILE_NEW_GC_SCHEME
2408 smallest
= (freelist
->span
* sizeof (scm_cell
));
2410 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2416 /* Allocate with decaying ambition. */
2417 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2418 && (len
>= smallest
))
2420 scm_sizet rounded_len
= round_to_cluster_size (freelist
, len
);
2421 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2424 init_heap_seg (ptr
, rounded_len
, freelist
);
2431 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2435 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2438 #define FUNC_NAME s_scm_unhash_name
2442 SCM_VALIDATE_SYMBOL (1,name
);
2444 bound
= scm_n_heap_segs
;
2445 for (x
= 0; x
< bound
; ++x
)
2449 p
= scm_heap_table
[x
].bounds
[0];
2450 pbound
= scm_heap_table
[x
].bounds
[1];
2453 SCM cell
= PTR2SCM (p
);
2454 if (SCM_TYP3 (cell
) == scm_tc3_cons_gloc
)
2456 /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
2457 * struct cell. See the corresponding comment in scm_gc_mark.
2459 scm_bits_t word0
= SCM_CELL_WORD_0 (cell
) - scm_tc3_cons_gloc
;
2460 SCM gloc_car
= SCM_PACK (word0
); /* access as gloc */
2461 SCM vcell
= SCM_CELL_OBJECT_1 (gloc_car
);
2462 if ((SCM_TRUE_P (name
) || SCM_EQ_P (SCM_CAR (gloc_car
), name
))
2463 && (SCM_UNPACK (vcell
) != 0) && (SCM_UNPACK (vcell
) != 1))
2465 SCM_SET_CELL_OBJECT_0 (cell
, name
);
2478 /* {GC Protection Helper Functions}
2483 scm_remember (SCM
*ptr
)
2488 These crazy functions prevent garbage collection
2489 of arguments after the first argument by
2490 ensuring they remain live throughout the
2491 function because they are used in the last
2492 line of the code block.
2493 It'd be better to have a nice compiler hint to
2494 aid the conservative stack-scanning GC. --03/09/00 gjb */
2496 scm_return_first (SCM elt
, ...)
2502 scm_return_first_int (int i
, ...)
2509 scm_permanent_object (SCM obj
)
2512 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2518 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2519 even if all other references are dropped, until someone applies
2520 scm_unprotect_object to it. This function returns OBJ.
2522 Calls to scm_protect_object nest. For every object OBJ, there is a
2523 counter which scm_protect_object(OBJ) increments and
2524 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2525 an object's counter is greater than zero, the garbage collector
2528 Of course, that's not how it's implemented. scm_protect_object and
2529 scm_unprotect_object just maintain a list of references to things.
2530 Since the GC knows about this list, all objects it mentions stay
2531 alive. scm_protect_object adds its argument to the list;
2532 scm_unprotect_object removes the first occurrence of its argument
2535 scm_protect_object (SCM obj
)
2537 scm_protects
= scm_cons (obj
, scm_protects
);
2543 /* Remove any protection for OBJ established by a prior call to
2544 scm_protect_object. This function returns OBJ.
2546 See scm_protect_object for more information. */
2548 scm_unprotect_object (SCM obj
)
2550 SCM
*tail_ptr
= &scm_protects
;
2552 while (SCM_CONSP (*tail_ptr
))
2553 if (SCM_EQ_P (SCM_CAR (*tail_ptr
), obj
))
2555 *tail_ptr
= SCM_CDR (*tail_ptr
);
2559 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
2566 /* called on process termination. */
2572 extern int on_exit (void (*procp
) (), int arg
);
2575 cleanup (int status
, void *arg
)
2577 #error Dont know how to setup a cleanup handler on your system.
2582 scm_flush_all_ports ();
2587 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2589 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2590 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2594 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2595 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2603 #ifdef GUILE_NEW_GC_SCHEME
2604 if (freelist
->min_yield_fraction
)
2605 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2607 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2614 #ifdef GUILE_NEW_GC_SCHEME
2616 init_freelist (scm_freelist_t
*freelist
,
2621 freelist
->clusters
= SCM_EOL
;
2622 freelist
->cluster_size
= cluster_size
+ 1;
2623 freelist
->left_to_collect
= 0;
2624 freelist
->clusters_allocated
= 0;
2625 freelist
->min_yield
= 0;
2626 freelist
->min_yield_fraction
= min_yield
;
2627 freelist
->span
= span
;
2628 freelist
->collected
= 0;
2629 freelist
->collected_1
= 0;
2630 freelist
->heap_size
= 0;
2634 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2635 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2636 scm_sizet max_segment_size
)
2639 scm_init_storage (scm_sizet init_heap_size_1
, scm_sizet init_heap_size_2
)
2644 if (!init_heap_size_1
)
2645 init_heap_size_1
= SCM_INIT_HEAP_SIZE_1
;
2646 if (!init_heap_size_2
)
2647 init_heap_size_2
= SCM_INIT_HEAP_SIZE_2
;
2649 j
= SCM_NUM_PROTECTS
;
2651 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2654 #ifdef GUILE_NEW_GC_SCHEME
2655 scm_freelist
= SCM_EOL
;
2656 scm_freelist2
= SCM_EOL
;
2657 init_freelist (&scm_master_freelist
,
2658 1, SCM_CLUSTER_SIZE_1
,
2659 gc_trigger_1
? gc_trigger_1
: SCM_MIN_YIELD_1
);
2660 init_freelist (&scm_master_freelist2
,
2661 2, SCM_CLUSTER_SIZE_2
,
2662 gc_trigger_2
? gc_trigger_2
: SCM_MIN_YIELD_2
);
2663 scm_max_segment_size
2664 = max_segment_size
? max_segment_size
: SCM_MAX_SEGMENT_SIZE
;
2666 scm_freelist
.cells
= SCM_EOL
;
2667 scm_freelist
.span
= 1;
2668 scm_freelist
.collected
= 0;
2669 scm_freelist
.heap_size
= 0;
2671 scm_freelist2
.cells
= SCM_EOL
;
2672 scm_freelist2
.span
= 2;
2673 scm_freelist2
.collected
= 0;
2674 scm_freelist2
.heap_size
= 0;
2679 j
= SCM_HEAP_SEG_SIZE
;
2680 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2681 scm_heap_table
= ((scm_heap_seg_data_t
*)
2682 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2684 #ifdef GUILE_NEW_GC_SCHEME
2685 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2686 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2689 if (make_initial_segment (init_heap_size_1
, &scm_freelist
) ||
2690 make_initial_segment (init_heap_size_2
, &scm_freelist2
))
2694 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2696 /* scm_hplims[0] can change. do not remove scm_heap_org */
2697 scm_weak_vectors
= SCM_EOL
;
2699 /* Initialise the list of ports. */
2700 scm_port_table
= (scm_port
**)
2701 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2702 if (!scm_port_table
)
2709 on_exit (cleanup
, 0);
2713 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2714 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2716 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2717 scm_nullstr
= scm_makstr (0L, 0);
2718 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2719 scm_symhash
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2720 scm_weak_symhash
= scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim
));
2721 scm_symhash_vars
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2722 scm_stand_in_procs
= SCM_EOL
;
2723 scm_permobjs
= SCM_EOL
;
2724 scm_protects
= SCM_EOL
;
2725 scm_asyncs
= SCM_EOL
;
2726 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2727 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2729 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));
2738 #include "libguile/gc.x"