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/smob.h"
54 #include "libguile/unif.h"
55 #include "libguile/async.h"
56 #include "libguile/ports.h"
57 #include "libguile/root.h"
58 #include "libguile/strings.h"
59 #include "libguile/vectors.h"
60 #include "libguile/weaks.h"
61 #include "libguile/hashtab.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 #define SCM_HEAP_SIZE \
174 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
175 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
182 typedef struct scm_freelist_t
{
183 /* collected cells */
185 /* number of cells left to collect before cluster is full */
186 unsigned int left_to_collect
;
187 /* number of clusters which have been allocated */
188 unsigned int clusters_allocated
;
189 /* a list of freelists, each of size cluster_size,
190 * except the last one which may be shorter
194 /* this is the number of objects in each cluster, including the spine cell */
196 /* indicates that we should grow heap instead of GC:ing
199 /* minimum yield on this list in order not to grow the heap
202 /* defines min_yield as percent of total heap size
204 int min_yield_fraction
;
205 /* number of cells per object on this list */
207 /* number of collected cells during last GC */
209 /* number of collected cells during penultimate GC */
211 /* total number of cells in heap segments
212 * belonging to this list.
217 SCM scm_freelist
= SCM_EOL
;
218 scm_freelist_t scm_master_freelist
= {
219 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
221 SCM scm_freelist2
= SCM_EOL
;
222 scm_freelist_t scm_master_freelist2
= {
223 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
227 * is the number of bytes of must_malloc allocation needed to trigger gc.
229 unsigned long scm_mtrigger
;
233 * If set, don't expand the heap. Set only during gc, during which no allocation
234 * is supposed to take place anyway.
236 int scm_gc_heap_lock
= 0;
239 * Don't pause for collection if this is set -- just
243 int scm_block_gc
= 1;
245 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
246 * collection (GC) more space is allocated for the heap.
248 #define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
250 /* During collection, this accumulates objects holding
253 SCM scm_weak_vectors
;
255 /* GC Statistics Keeping
257 unsigned long scm_cells_allocated
= 0;
258 long scm_mallocated
= 0;
259 unsigned long scm_gc_cells_collected
;
260 unsigned long scm_gc_yield
;
261 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
262 unsigned long scm_gc_malloc_collected
;
263 unsigned long scm_gc_ports_collected
;
264 unsigned long scm_gc_rt
;
265 unsigned long scm_gc_time_taken
= 0;
267 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
268 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
269 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
270 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
271 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
272 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
274 typedef struct scm_heap_seg_data_t
276 /* lower and upper bounds of the segment */
277 SCM_CELLPTR bounds
[2];
279 /* address of the head-of-freelist pointer for this segment's cells.
280 All segments usually point to the same one, scm_freelist. */
281 scm_freelist_t
*freelist
;
283 /* number of cells per object in this segment */
286 /* If SEG_DATA->valid is non-zero, the conservative marking
287 functions will apply SEG_DATA->valid to the purported pointer and
288 SEG_DATA, and mark the object iff the function returns non-zero.
289 At the moment, I don't think anyone uses this. */
291 } scm_heap_seg_data_t
;
295 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
296 static void alloc_some_heap (scm_freelist_t
*);
300 /* Debugging functions. */
302 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
304 /* Return the number of the heap segment containing CELL. */
310 for (i
= 0; i
< scm_n_heap_segs
; i
++)
311 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
312 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
314 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
321 map_free_list (scm_freelist_t
*master
, SCM freelist
)
323 int last_seg
= -1, count
= 0;
326 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
328 int this_seg
= which_seg (f
);
330 if (this_seg
!= last_seg
)
333 fprintf (stderr
, " %5d %d-cells in segment %d\n",
334 count
, master
->span
, last_seg
);
341 fprintf (stderr
, " %5d %d-cells in segment %d\n",
342 count
, master
->span
, last_seg
);
345 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
347 "Print debugging information about the free-list.\n"
348 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
349 #define FUNC_NAME s_scm_map_free_list
352 fprintf (stderr
, "%d segments total (%d:%d",
354 scm_heap_table
[0].span
,
355 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
356 for (i
= 1; i
< scm_n_heap_segs
; i
++)
357 fprintf (stderr
, ", %d:%d",
358 scm_heap_table
[i
].span
,
359 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
360 fprintf (stderr
, ")\n");
361 map_free_list (&scm_master_freelist
, scm_freelist
);
362 map_free_list (&scm_master_freelist2
, scm_freelist2
);
365 return SCM_UNSPECIFIED
;
369 static int last_cluster
;
370 static int last_size
;
373 free_list_length (char *title
, int i
, SCM freelist
)
377 for (ls
= freelist
; SCM_NNULLP (ls
); ls
= SCM_CDR (ls
))
378 if (SCM_UNPACK_CAR (ls
) == scm_tc_free_cell
)
382 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
389 if (last_cluster
== i
- 1)
390 fprintf (stderr
, "\t%d\n", last_size
);
392 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
395 fprintf (stderr
, "%s %d", title
, i
);
397 fprintf (stderr
, "%s\t%d\n", title
, n
);
405 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
408 int i
= 0, len
, n
= 0;
409 fprintf (stderr
, "%s\n\n", title
);
410 n
+= free_list_length ("free list", -1, freelist
);
411 for (clusters
= master
->clusters
;
412 SCM_NNULLP (clusters
);
413 clusters
= SCM_CDR (clusters
))
415 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
418 if (last_cluster
== i
- 1)
419 fprintf (stderr
, "\t%d\n", last_size
);
421 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
422 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
425 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
427 "Print debugging information about the free-list.\n"
428 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
429 #define FUNC_NAME s_scm_free_list_length
431 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
432 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
433 return SCM_UNSPECIFIED
;
439 #ifdef GUILE_DEBUG_FREELIST
441 /* Number of calls to SCM_NEWCELL since startup. */
442 static unsigned long scm_newcell_count
;
443 static unsigned long scm_newcell2_count
;
445 /* Search freelist for anything that isn't marked as a free cell.
446 Abort if we find something. */
448 scm_check_freelist (SCM freelist
)
453 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
454 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
456 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
457 scm_newcell_count
, i
);
463 static int scm_debug_check_freelist
= 0;
465 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
467 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
468 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
469 "compile-time flag was selected.\n")
470 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
472 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
473 return SCM_UNSPECIFIED
;
479 scm_debug_newcell (void)
484 if (scm_debug_check_freelist
)
486 scm_check_freelist (scm_freelist
);
490 /* The rest of this is supposed to be identical to the SCM_NEWCELL
492 if (SCM_IMP (scm_freelist
))
493 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
497 scm_freelist
= SCM_CDR (scm_freelist
);
498 SCM_SETCAR (new, scm_tc16_allocated
);
505 scm_debug_newcell2 (void)
509 scm_newcell2_count
++;
510 if (scm_debug_check_freelist
)
512 scm_check_freelist (scm_freelist2
);
516 /* The rest of this is supposed to be identical to the SCM_NEWCELL
518 if (SCM_IMP (scm_freelist2
))
519 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
523 scm_freelist2
= SCM_CDR (scm_freelist2
);
524 SCM_SETCAR (new, scm_tc16_allocated
);
530 #endif /* GUILE_DEBUG_FREELIST */
535 master_cells_allocated (scm_freelist_t
*master
)
537 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
538 if (SCM_NULLP (master
->clusters
))
539 objects
-= master
->left_to_collect
;
540 return master
->span
* objects
;
544 freelist_length (SCM freelist
)
547 for (n
= 0; SCM_NNULLP (freelist
); freelist
= SCM_CDR (freelist
))
553 compute_cells_allocated ()
555 return (scm_cells_allocated
556 + master_cells_allocated (&scm_master_freelist
)
557 + master_cells_allocated (&scm_master_freelist2
)
558 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
559 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
562 /* {Scheme Interface to GC}
565 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
567 "Returns an association list of statistics about Guile's current use of storage. ")
568 #define FUNC_NAME s_scm_gc_stats
573 long int local_scm_mtrigger
;
574 long int local_scm_mallocated
;
575 long int local_scm_heap_size
;
576 long int local_scm_cells_allocated
;
577 long int local_scm_gc_time_taken
;
585 for (i
= scm_n_heap_segs
; i
--; )
586 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
587 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
589 if (scm_n_heap_segs
!= n
)
593 /* Below, we cons to produce the resulting list. We want a snapshot of
594 * the heap situation before consing.
596 local_scm_mtrigger
= scm_mtrigger
;
597 local_scm_mallocated
= scm_mallocated
;
598 local_scm_heap_size
= SCM_HEAP_SIZE
;
599 local_scm_cells_allocated
= compute_cells_allocated ();
600 local_scm_gc_time_taken
= scm_gc_time_taken
;
602 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
603 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
604 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
605 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
606 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
607 scm_cons (sym_heap_segments
, heap_segs
),
616 scm_gc_start (const char *what
)
618 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
619 scm_gc_cells_collected
= 0;
620 scm_gc_yield_1
= scm_gc_yield
;
621 scm_gc_yield
= (scm_cells_allocated
622 + master_cells_allocated (&scm_master_freelist
)
623 + master_cells_allocated (&scm_master_freelist2
));
624 scm_gc_malloc_collected
= 0;
625 scm_gc_ports_collected
= 0;
631 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
632 scm_gc_time_taken
+= scm_gc_rt
;
633 scm_system_async_mark (scm_gc_async
);
637 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
639 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
640 "returned by this function for @var{obj}")
641 #define FUNC_NAME s_scm_object_address
643 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
648 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
650 "Scans all of SCM objects and reclaims for further use those that are\n"
651 "no longer accessible.")
652 #define FUNC_NAME s_scm_gc
657 return SCM_UNSPECIFIED
;
663 /* {C Interface For When GC is Triggered}
667 adjust_min_yield (scm_freelist_t
*freelist
)
669 /* min yield is adjusted upwards so that next predicted total yield
670 * (allocated cells actually freed by GC) becomes
671 * `min_yield_fraction' of total heap size. Note, however, that
672 * the absolute value of min_yield will correspond to `collected'
673 * on one master (the one which currently is triggering GC).
675 * The reason why we look at total yield instead of cells collected
676 * on one list is that we want to take other freelists into account.
677 * On this freelist, we know that (local) yield = collected cells,
678 * but that's probably not the case on the other lists.
680 * (We might consider computing a better prediction, for example
681 * by computing an average over multiple GC:s.)
683 if (freelist
->min_yield_fraction
)
685 /* Pick largest of last two yields. */
686 int delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
687 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
689 fprintf (stderr
, " after GC = %d, delta = %d\n",
694 freelist
->min_yield
+= delta
;
698 /* When we get POSIX threads support, the master will be global and
699 * common while the freelist will be individual for each thread.
703 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
709 if (SCM_NULLP (master
->clusters
))
711 if (master
->grow_heap_p
)
713 master
->grow_heap_p
= 0;
714 alloc_some_heap (master
);
719 fprintf (stderr
, "allocated = %d, ",
721 + master_cells_allocated (&scm_master_freelist
)
722 + master_cells_allocated (&scm_master_freelist2
));
725 adjust_min_yield (master
);
728 cell
= SCM_CAR (master
->clusters
);
729 master
->clusters
= SCM_CDR (master
->clusters
);
730 ++master
->clusters_allocated
;
732 while (SCM_NULLP (cell
));
734 *freelist
= SCM_CDR (cell
);
735 SCM_SET_CELL_TYPE (cell
, scm_tc16_allocated
);
740 /* This is a support routine which can be used to reserve a cluster
741 * for some special use, such as debugging. It won't be useful until
742 * free cells are preserved between garbage collections.
746 scm_alloc_cluster (scm_freelist_t
*master
)
749 cell
= scm_gc_for_newcell (master
, &freelist
);
750 SCM_SETCDR (cell
, freelist
);
755 SCM scm_after_gc_hook
;
757 scm_c_hook_t scm_before_gc_c_hook
;
758 scm_c_hook_t scm_before_mark_c_hook
;
759 scm_c_hook_t scm_before_sweep_c_hook
;
760 scm_c_hook_t scm_after_sweep_c_hook
;
761 scm_c_hook_t scm_after_gc_c_hook
;
764 scm_igc (const char *what
)
768 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
771 SCM_NULLP (scm_freelist
)
773 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
776 /* During the critical section, only the current thread may run. */
777 SCM_THREAD_CRITICAL_SECTION_START
;
780 /* fprintf (stderr, "gc: %s\n", what); */
784 if (!scm_stack_base
|| scm_block_gc
)
790 if (scm_mallocated
< 0)
791 /* The byte count of allocated objects has underflowed. This is
792 probably because you forgot to report the sizes of objects you
793 have allocated, by calling scm_done_malloc or some such. When
794 the GC freed them, it subtracted their size from
795 scm_mallocated, which underflowed. */
798 if (scm_gc_heap_lock
)
799 /* We've invoked the collector while a GC is already in progress.
800 That should never happen. */
805 /* unprotect any struct types with no instances */
811 pos
= &scm_type_obj_list
;
812 type_list
= scm_type_obj_list
;
813 while (type_list
!= SCM_EOL
)
814 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
816 pos
= SCM_CDRLOC (type_list
);
817 type_list
= SCM_CDR (type_list
);
821 *pos
= SCM_CDR (type_list
);
822 type_list
= SCM_CDR (type_list
);
827 /* flush dead entries from the continuation stack */
832 elts
= SCM_VELTS (scm_continuation_stack
);
833 bound
= SCM_LENGTH (scm_continuation_stack
);
834 x
= SCM_INUM (scm_continuation_stack_ptr
);
837 elts
[x
] = SCM_BOOL_F
;
842 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
846 /* Protect from the C stack. This must be the first marking
847 * done because it provides information about what objects
848 * are "in-use" by the C code. "in-use" objects are those
849 * for which the values from SCM_LENGTH and SCM_CHARS must remain
850 * usable. This requirement is stricter than a liveness
851 * requirement -- in particular, it constrains the implementation
852 * of scm_vector_set_length_x.
854 SCM_FLUSH_REGISTER_WINDOWS
;
855 /* This assumes that all registers are saved into the jmp_buf */
856 setjmp (scm_save_regs_gc_mark
);
857 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
858 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
859 sizeof scm_save_regs_gc_mark
)
860 / sizeof (SCM_STACKITEM
)));
863 scm_sizet stack_len
= scm_stack_size (scm_stack_base
);
864 #ifdef SCM_STACK_GROWS_UP
865 scm_mark_locations (scm_stack_base
, stack_len
);
867 scm_mark_locations (scm_stack_base
- stack_len
, stack_len
);
871 #else /* USE_THREADS */
873 /* Mark every thread's stack and registers */
874 scm_threads_mark_stacks ();
876 #endif /* USE_THREADS */
878 /* FIXME: insert a phase to un-protect string-data preserved
879 * in scm_vector_set_length_x.
882 j
= SCM_NUM_PROTECTS
;
884 scm_gc_mark (scm_sys_protects
[j
]);
886 /* FIXME: we should have a means to register C functions to be run
887 * in different phases of GC
889 scm_mark_subr_table ();
892 scm_gc_mark (scm_root
->handle
);
895 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
899 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
905 SCM_THREAD_CRITICAL_SECTION_END
;
907 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
916 /* Mark an object precisely.
931 if (SCM_NCELLP (ptr
))
932 scm_wta (ptr
, "rogue pointer in heap", NULL
);
934 switch (SCM_TYP7 (ptr
))
936 case scm_tcs_cons_nimcar
:
937 if (SCM_GCMARKP (ptr
))
940 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
945 scm_gc_mark (SCM_CAR (ptr
));
946 ptr
= SCM_GCCDR (ptr
);
948 case scm_tcs_cons_imcar
:
949 if (SCM_GCMARKP (ptr
))
952 ptr
= SCM_GCCDR (ptr
);
955 if (SCM_GCMARKP (ptr
))
958 scm_gc_mark (SCM_CELL_OBJECT_2 (ptr
));
959 ptr
= SCM_GCCDR (ptr
);
961 case scm_tcs_cons_gloc
:
962 if (SCM_GCMARKP (ptr
))
966 /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
967 * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
968 * to a heap cell. If it is a struct, the cell word #0 of ptr is a
969 * pointer to a struct vtable data region. The fact that these are
970 * accessed in the same way restricts the possibilites to change the
971 * data layout of structs or heap cells.
973 scm_bits_t word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
974 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
975 switch (vtable_data
[scm_vtable_index_vcell
])
980 SCM gloc_car
= SCM_PACK (word0
);
981 scm_gc_mark (gloc_car
);
982 ptr
= SCM_GCCDR (ptr
);
988 /* ptr is a struct */
989 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
990 int len
= SCM_LENGTH (layout
);
991 char * fields_desc
= SCM_CHARS (layout
);
992 /* We're using SCM_GCCDR here like STRUCT_DATA, except
993 that it removes the mark */
994 scm_bits_t
* struct_data
= (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (ptr
));
996 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
998 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
999 scm_gc_mark (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1005 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1006 if (fields_desc
[x
] == 'p')
1007 scm_gc_mark (SCM_PACK (*struct_data
));
1008 if (fields_desc
[x
] == 'p')
1010 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1011 for (x
= *struct_data
; x
; --x
)
1012 scm_gc_mark (SCM_PACK (*++struct_data
));
1014 scm_gc_mark (SCM_PACK (*struct_data
));
1017 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1019 vtable_data
[scm_vtable_index_vcell
] = 1;
1020 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1027 case scm_tcs_closures
:
1028 if (SCM_GCMARKP (ptr
))
1030 SCM_SETGCMARK (ptr
);
1031 if (SCM_IMP (SCM_CDR (ptr
)))
1033 ptr
= SCM_CLOSCAR (ptr
);
1036 scm_gc_mark (SCM_CLOSCAR (ptr
));
1037 ptr
= SCM_GCCDR (ptr
);
1039 case scm_tc7_vector
:
1040 case scm_tc7_lvector
:
1044 if (SCM_GC8MARKP (ptr
))
1046 SCM_SETGC8MARK (ptr
);
1047 i
= SCM_LENGTH (ptr
);
1051 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1052 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1053 ptr
= SCM_VELTS (ptr
)[0];
1055 case scm_tc7_contin
:
1058 SCM_SETGC8MARK (ptr
);
1059 if (SCM_VELTS (ptr
))
1060 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1063 (sizeof (SCM_STACKITEM
) + -1 +
1064 sizeof (scm_contregs
)) /
1065 sizeof (SCM_STACKITEM
)));
1069 case scm_tc7_byvect
:
1076 #ifdef HAVE_LONG_LONGS
1077 case scm_tc7_llvect
:
1080 case scm_tc7_string
:
1081 SCM_SETGC8MARK (ptr
);
1084 case scm_tc7_substring
:
1085 if (SCM_GC8MARKP(ptr
))
1087 SCM_SETGC8MARK (ptr
);
1088 ptr
= SCM_CDR (ptr
);
1092 if (SCM_GC8MARKP(ptr
))
1094 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1095 scm_weak_vectors
= ptr
;
1096 SCM_SETGC8MARK (ptr
);
1097 if (SCM_IS_WHVEC_ANY (ptr
))
1104 len
= SCM_LENGTH (ptr
);
1105 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1106 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1108 for (x
= 0; x
< len
; ++x
)
1111 alist
= SCM_VELTS (ptr
)[x
];
1113 /* mark everything on the alist except the keys or
1114 * values, according to weak_values and weak_keys. */
1115 while ( SCM_CONSP (alist
)
1116 && !SCM_GCMARKP (alist
)
1117 && SCM_CONSP (SCM_CAR (alist
)))
1122 kvpair
= SCM_CAR (alist
);
1123 next_alist
= SCM_CDR (alist
);
1126 * SCM_SETGCMARK (alist);
1127 * SCM_SETGCMARK (kvpair);
1129 * It may be that either the key or value is protected by
1130 * an escaped reference to part of the spine of this alist.
1131 * If we mark the spine here, and only mark one or neither of the
1132 * key and value, they may never be properly marked.
1133 * This leads to a horrible situation in which an alist containing
1134 * freelist cells is exported.
1136 * So only mark the spines of these arrays last of all marking.
1137 * If somebody confuses us by constructing a weak vector
1138 * with a circular alist then we are hosed, but at least we
1139 * won't prematurely drop table entries.
1142 scm_gc_mark (SCM_CAR (kvpair
));
1144 scm_gc_mark (SCM_GCCDR (kvpair
));
1147 if (SCM_NIMP (alist
))
1148 scm_gc_mark (alist
);
1153 case scm_tc7_msymbol
:
1154 if (SCM_GC8MARKP(ptr
))
1156 SCM_SETGC8MARK (ptr
);
1157 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1158 ptr
= SCM_SYMBOL_PROPS (ptr
);
1160 case scm_tc7_ssymbol
:
1161 if (SCM_GC8MARKP(ptr
))
1163 SCM_SETGC8MARK (ptr
);
1168 i
= SCM_PTOBNUM (ptr
);
1169 if (!(i
< scm_numptob
))
1171 if (SCM_GC8MARKP (ptr
))
1173 SCM_SETGC8MARK (ptr
);
1174 if (SCM_PTAB_ENTRY(ptr
))
1175 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1176 if (scm_ptobs
[i
].mark
)
1178 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1185 if (SCM_GC8MARKP (ptr
))
1187 SCM_SETGC8MARK (ptr
);
1188 switch (SCM_GCTYP16 (ptr
))
1189 { /* should be faster than going through scm_smobs */
1190 case scm_tc_free_cell
:
1191 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1192 case scm_tc16_allocated
:
1195 case scm_tc16_complex
:
1198 i
= SCM_SMOBNUM (ptr
);
1199 if (!(i
< scm_numsmob
))
1201 if (scm_smobs
[i
].mark
)
1203 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1211 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1216 /* Mark a Region Conservatively
1220 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1222 register long m
= n
;
1224 register SCM_CELLPTR ptr
;
1227 if (SCM_CELLP (* (SCM
*) &x
[m
]))
1229 ptr
= SCM2PTR (* (SCM
*) &x
[m
]);
1231 j
= scm_n_heap_segs
- 1;
1232 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1233 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1240 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1242 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1250 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1254 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1259 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1263 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1269 if (!scm_heap_table
[seg_id
].valid
1270 || scm_heap_table
[seg_id
].valid (ptr
,
1271 &scm_heap_table
[seg_id
]))
1272 if (scm_heap_table
[seg_id
].span
== 1
1273 || SCM_DOUBLE_CELLP (* (SCM
*) &x
[m
]))
1274 scm_gc_mark (* (SCM
*) &x
[m
]);
1283 /* The function scm_cellp determines whether an SCM value can be regarded as a
1284 * pointer to a cell on the heap. Binary search is used in order to determine
1285 * the heap segment that contains the cell.
1288 scm_cellp (SCM value
)
1290 if (SCM_CELLP (value
)) {
1291 scm_cell
* ptr
= SCM2PTR (value
);
1293 unsigned int j
= scm_n_heap_segs
- 1;
1296 int k
= (i
+ j
) / 2;
1297 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
)) {
1299 } else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
)) {
1304 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1305 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
)
1306 && (!scm_heap_table
[i
].valid
|| scm_heap_table
[i
].valid (ptr
, &scm_heap_table
[i
]))
1307 && (scm_heap_table
[i
].span
== 1 || SCM_DOUBLE_CELLP (value
))) {
1319 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1321 freelist
->cells
= SCM_EOL
;
1322 freelist
->left_to_collect
= freelist
->cluster_size
;
1323 freelist
->clusters_allocated
= 0;
1324 freelist
->clusters
= SCM_EOL
;
1325 freelist
->clustertail
= &freelist
->clusters
;
1326 freelist
->collected_1
= freelist
->collected
;
1327 freelist
->collected
= 0;
1331 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1334 *freelist
->clustertail
= freelist
->cells
;
1335 if (SCM_NNULLP (freelist
->cells
))
1337 SCM c
= freelist
->cells
;
1338 SCM_SETCAR (c
, SCM_CDR (c
));
1339 SCM_SETCDR (c
, SCM_EOL
);
1340 freelist
->collected
+=
1341 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1343 scm_gc_cells_collected
+= freelist
->collected
;
1345 /* Although freelist->min_yield is used to test freelist->collected
1346 * (which is the local GC yield for freelist), it is adjusted so
1347 * that *total* yield is freelist->min_yield_fraction of total heap
1348 * size. This means that a too low yield is compensated by more
1349 * heap on the list which is currently doing most work, which is
1350 * just what we want.
1352 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1353 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1359 register SCM_CELLPTR ptr
;
1360 register SCM nfreelist
;
1361 register scm_freelist_t
*freelist
;
1369 gc_sweep_freelist_start (&scm_master_freelist
);
1370 gc_sweep_freelist_start (&scm_master_freelist2
);
1372 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1374 register unsigned int left_to_collect
;
1375 register scm_sizet j
;
1377 /* Unmarked cells go onto the front of the freelist this heap
1378 segment points to. Rather than updating the real freelist
1379 pointer as we go along, we accumulate the new head in
1380 nfreelist. Then, if it turns out that the entire segment is
1381 free, we free (i.e., malloc's free) the whole segment, and
1382 simply don't assign nfreelist back into the real freelist. */
1383 freelist
= scm_heap_table
[i
].freelist
;
1384 nfreelist
= freelist
->cells
;
1385 left_to_collect
= freelist
->left_to_collect
;
1386 span
= scm_heap_table
[i
].span
;
1388 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1389 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1390 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1392 SCM scmptr
= PTR2SCM (ptr
);
1394 switch SCM_TYP7 (scmptr
)
1396 case scm_tcs_cons_gloc
:
1398 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1399 * struct or a gloc. See the corresponding comment in
1402 scm_bits_t word0
= SCM_CELL_WORD_0 (scmptr
) - scm_tc3_cons_gloc
;
1403 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1404 if (SCM_GCMARKP (scmptr
))
1406 if (vtable_data
[scm_vtable_index_vcell
] == 1)
1407 vtable_data
[scm_vtable_index_vcell
] = 0;
1412 if (vtable_data
[scm_vtable_index_vcell
] == 0
1413 || vtable_data
[scm_vtable_index_vcell
] == 1)
1415 scm_struct_free_t free
1416 = (scm_struct_free_t
) vtable_data
[scm_struct_i_free
];
1417 m
+= free (vtable_data
, (scm_bits_t
*) SCM_UNPACK (SCM_GCCDR (scmptr
)));
1422 case scm_tcs_cons_imcar
:
1423 case scm_tcs_cons_nimcar
:
1424 case scm_tcs_closures
:
1426 if (SCM_GCMARKP (scmptr
))
1430 if (SCM_GC8MARKP (scmptr
))
1436 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1437 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1441 case scm_tc7_vector
:
1442 case scm_tc7_lvector
:
1446 if (SCM_GC8MARKP (scmptr
))
1449 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1451 scm_must_free (SCM_CHARS (scmptr
));
1452 /* SCM_SETCHARS(scmptr, 0);*/
1456 if SCM_GC8MARKP (scmptr
)
1458 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1460 case scm_tc7_byvect
:
1461 if SCM_GC8MARKP (scmptr
)
1463 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1467 if SCM_GC8MARKP (scmptr
)
1469 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1472 if SCM_GC8MARKP (scmptr
)
1474 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1476 #ifdef HAVE_LONG_LONGS
1477 case scm_tc7_llvect
:
1478 if SCM_GC8MARKP (scmptr
)
1480 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1484 if SCM_GC8MARKP (scmptr
)
1486 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1489 if SCM_GC8MARKP (scmptr
)
1491 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1494 if SCM_GC8MARKP (scmptr
)
1496 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1499 case scm_tc7_substring
:
1500 if (SCM_GC8MARKP (scmptr
))
1503 case scm_tc7_string
:
1504 if (SCM_GC8MARKP (scmptr
))
1506 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1508 case scm_tc7_msymbol
:
1509 if (SCM_GC8MARKP (scmptr
))
1511 m
+= (SCM_LENGTH (scmptr
) + 1
1512 + (SCM_CHARS (scmptr
) - (char *) SCM_SLOTS (scmptr
)));
1513 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1515 case scm_tc7_contin
:
1516 if SCM_GC8MARKP (scmptr
)
1518 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1519 if (SCM_VELTS (scmptr
))
1521 case scm_tc7_ssymbol
:
1522 if SCM_GC8MARKP(scmptr
)
1528 if SCM_GC8MARKP (scmptr
)
1530 if SCM_OPENP (scmptr
)
1532 int k
= SCM_PTOBNUM (scmptr
);
1533 if (!(k
< scm_numptob
))
1535 /* Keep "revealed" ports alive. */
1536 if (scm_revealed_count (scmptr
) > 0)
1538 /* Yes, I really do mean scm_ptobs[k].free */
1539 /* rather than ftobs[k].close. .close */
1540 /* is for explicit CLOSE-PORT by user */
1541 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1542 SCM_SETSTREAM (scmptr
, 0);
1543 scm_remove_from_port_table (scmptr
);
1544 scm_gc_ports_collected
++;
1545 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1549 switch SCM_GCTYP16 (scmptr
)
1551 case scm_tc_free_cell
:
1553 if SCM_GC8MARKP (scmptr
)
1558 if SCM_GC8MARKP (scmptr
)
1560 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1562 #endif /* def SCM_BIGDIG */
1563 case scm_tc16_complex
:
1564 if SCM_GC8MARKP (scmptr
)
1566 m
+= 2 * sizeof (double);
1569 if SCM_GC8MARKP (scmptr
)
1574 k
= SCM_SMOBNUM (scmptr
);
1575 if (!(k
< scm_numsmob
))
1577 m
+= (scm_smobs
[k
].free
) (scmptr
);
1583 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1586 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1589 if (!--left_to_collect
)
1591 SCM_SETCAR (scmptr
, nfreelist
);
1592 *freelist
->clustertail
= scmptr
;
1593 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1595 nfreelist
= SCM_EOL
;
1596 freelist
->collected
+= span
* freelist
->cluster_size
;
1597 left_to_collect
= freelist
->cluster_size
;
1601 /* Stick the new cell on the front of nfreelist. It's
1602 critical that we mark this cell as freed; otherwise, the
1603 conservative collector might trace it as some other type
1605 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1606 SCM_SETCDR (scmptr
, nfreelist
);
1612 SCM_CLRGC8MARK (scmptr
);
1615 SCM_CLRGCMARK (scmptr
);
1617 #ifdef GC_FREE_SEGMENTS
1622 freelist
->heap_size
-= seg_size
;
1623 free ((char *) scm_heap_table
[i
].bounds
[0]);
1624 scm_heap_table
[i
].bounds
[0] = 0;
1625 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1626 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1627 scm_n_heap_segs
-= 1;
1628 i
--; /* We need to scan the segment just moved. */
1631 #endif /* ifdef GC_FREE_SEGMENTS */
1633 /* Update the real freelist pointer to point to the head of
1634 the list of free cells we've built for this segment. */
1635 freelist
->cells
= nfreelist
;
1636 freelist
->left_to_collect
= left_to_collect
;
1639 #ifdef GUILE_DEBUG_FREELIST
1640 scm_check_freelist (freelist
== &scm_master_freelist
1643 scm_map_free_list ();
1647 gc_sweep_freelist_finish (&scm_master_freelist
);
1648 gc_sweep_freelist_finish (&scm_master_freelist2
);
1650 /* When we move to POSIX threads private freelists should probably
1651 be GC-protected instead. */
1652 scm_freelist
= SCM_EOL
;
1653 scm_freelist2
= SCM_EOL
;
1655 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1656 scm_gc_yield
-= scm_cells_allocated
;
1657 scm_mallocated
-= m
;
1658 scm_gc_malloc_collected
= m
;
1664 /* {Front end to malloc}
1666 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1668 * These functions provide services comperable to malloc, realloc, and
1669 * free. They are for allocating malloced parts of scheme objects.
1670 * The primary purpose of the front end is to impose calls to gc.
1675 * Return newly malloced storage or throw an error.
1677 * The parameter WHAT is a string for error reporting.
1678 * If the threshold scm_mtrigger will be passed by this
1679 * allocation, or if the first call to malloc fails,
1680 * garbage collect -- on the presumption that some objects
1681 * using malloced storage may be collected.
1683 * The limit scm_mtrigger may be raised by this allocation.
1686 scm_must_malloc (scm_sizet size
, const char *what
)
1689 unsigned long nm
= scm_mallocated
+ size
;
1691 if (nm
<= scm_mtrigger
)
1693 SCM_SYSCALL (ptr
= malloc (size
));
1696 scm_mallocated
= nm
;
1697 #ifdef GUILE_DEBUG_MALLOC
1698 scm_malloc_register (ptr
, what
);
1706 nm
= scm_mallocated
+ size
;
1707 SCM_SYSCALL (ptr
= malloc (size
));
1710 scm_mallocated
= nm
;
1711 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1712 if (nm
> scm_mtrigger
)
1713 scm_mtrigger
= nm
+ nm
/ 2;
1715 scm_mtrigger
+= scm_mtrigger
/ 2;
1717 #ifdef GUILE_DEBUG_MALLOC
1718 scm_malloc_register (ptr
, what
);
1724 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1725 return 0; /* never reached */
1730 * is similar to scm_must_malloc.
1733 scm_must_realloc (void *where
,
1739 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1741 if (nm
<= scm_mtrigger
)
1743 SCM_SYSCALL (ptr
= realloc (where
, size
));
1746 scm_mallocated
= nm
;
1747 #ifdef GUILE_DEBUG_MALLOC
1748 scm_malloc_reregister (where
, ptr
, what
);
1756 nm
= scm_mallocated
+ size
- old_size
;
1757 SCM_SYSCALL (ptr
= realloc (where
, size
));
1760 scm_mallocated
= nm
;
1761 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1762 if (nm
> scm_mtrigger
)
1763 scm_mtrigger
= nm
+ nm
/ 2;
1765 scm_mtrigger
+= scm_mtrigger
/ 2;
1767 #ifdef GUILE_DEBUG_MALLOC
1768 scm_malloc_reregister (where
, ptr
, what
);
1773 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1774 return 0; /* never reached */
1778 scm_must_free (void *obj
)
1780 #ifdef GUILE_DEBUG_MALLOC
1781 scm_malloc_unregister (obj
);
1786 scm_wta (SCM_INUM0
, "already free", "");
1789 /* Announce that there has been some malloc done that will be freed
1790 * during gc. A typical use is for a smob that uses some malloced
1791 * memory but can not get it from scm_must_malloc (for whatever
1792 * reason). When a new object of this smob is created you call
1793 * scm_done_malloc with the size of the object. When your smob free
1794 * function is called, be sure to include this size in the return
1798 scm_done_malloc (long size
)
1800 scm_mallocated
+= size
;
1802 if (scm_mallocated
> scm_mtrigger
)
1804 scm_igc ("foreign mallocs");
1805 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1807 if (scm_mallocated
> scm_mtrigger
)
1808 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1810 scm_mtrigger
+= scm_mtrigger
/ 2;
1820 * Each heap segment is an array of objects of a particular size.
1821 * Every segment has an associated (possibly shared) freelist.
1822 * A table of segment records is kept that records the upper and
1823 * lower extents of the segment; this is used during the conservative
1824 * phase of gc to identify probably gc roots (because they point
1825 * into valid segments at reasonable offsets). */
1828 * is true if the first segment was smaller than INIT_HEAP_SEG.
1829 * If scm_expmem is set to one, subsequent segment allocations will
1830 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1834 scm_sizet scm_max_segment_size
;
1837 * is the lowest base address of any heap segment.
1839 SCM_CELLPTR scm_heap_org
;
1841 scm_heap_seg_data_t
* scm_heap_table
= 0;
1842 int scm_n_heap_segs
= 0;
1845 * initializes a new heap segment and return the number of objects it contains.
1847 * The segment origin, segment size in bytes, and the span of objects
1848 * in cells are input parameters. The freelist is both input and output.
1850 * This function presume that the scm_heap_table has already been expanded
1851 * to accomodate a new segment record.
1856 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
1858 register SCM_CELLPTR ptr
;
1859 SCM_CELLPTR seg_end
;
1862 int span
= freelist
->span
;
1864 if (seg_org
== NULL
)
1867 ptr
= CELL_UP (seg_org
, span
);
1869 /* Compute the ceiling on valid object pointers w/in this segment.
1871 seg_end
= CELL_DN ((char *) seg_org
+ size
, span
);
1873 /* Find the right place and insert the segment record.
1876 for (new_seg_index
= 0;
1877 ( (new_seg_index
< scm_n_heap_segs
)
1878 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1884 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1885 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1890 scm_heap_table
[new_seg_index
].valid
= 0;
1891 scm_heap_table
[new_seg_index
].span
= span
;
1892 scm_heap_table
[new_seg_index
].freelist
= freelist
;
1893 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
1894 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
1897 /* Compute the least valid object pointer w/in this segment
1899 ptr
= CELL_UP (ptr
, span
);
1903 n_new_cells
= seg_end
- ptr
;
1905 freelist
->heap_size
+= n_new_cells
;
1907 /* Partition objects in this segment into clusters */
1910 SCM
*clusterp
= &clusters
;
1911 int n_cluster_cells
= span
* freelist
->cluster_size
;
1913 while (n_new_cells
> span
) /* at least one spine + one freecell */
1915 /* Determine end of cluster
1917 if (n_new_cells
>= n_cluster_cells
)
1919 seg_end
= ptr
+ n_cluster_cells
;
1920 n_new_cells
-= n_cluster_cells
;
1923 /* [cmm] looks like the segment size doesn't divide cleanly by
1924 cluster size. bad cmm! */
1927 /* Allocate cluster spine
1929 *clusterp
= PTR2SCM (ptr
);
1930 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
1931 clusterp
= SCM_CDRLOC (*clusterp
);
1934 while (ptr
< seg_end
)
1936 SCM scmptr
= PTR2SCM (ptr
);
1938 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1939 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
1943 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
1946 /* Patch up the last cluster pointer in the segment
1947 * to join it to the input freelist.
1949 *clusterp
= freelist
->clusters
;
1950 freelist
->clusters
= clusters
;
1954 fprintf (stderr
, "H");
1960 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
1962 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
1965 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
1966 + ALIGNMENT_SLACK (freelist
);
1970 alloc_some_heap (scm_freelist_t
*freelist
)
1972 scm_heap_seg_data_t
* tmptable
;
1976 /* Critical code sections (such as the garbage collector)
1977 * aren't supposed to add heap segments.
1979 if (scm_gc_heap_lock
)
1980 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1982 /* Expand the heap tables to have room for the new segment.
1983 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1984 * only if the allocation of the segment itself succeeds.
1986 len
= (1 + scm_n_heap_segs
) * sizeof (scm_heap_seg_data_t
);
1988 SCM_SYSCALL (tmptable
= ((scm_heap_seg_data_t
*)
1989 realloc ((char *)scm_heap_table
, len
)));
1991 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1993 scm_heap_table
= tmptable
;
1996 /* Pick a size for the new heap segment.
1997 * The rule for picking the size of a segment is explained in
2001 /* Assure that the new segment is predicted to be large enough.
2003 * New yield should at least equal GC fraction of new heap size, i.e.
2005 * y + dh > f * (h + dh)
2008 * f : min yield fraction
2010 * dh : size of new heap segment
2012 * This gives dh > (f * h - y) / (1 - f)
2014 int f
= freelist
->min_yield_fraction
;
2015 long h
= SCM_HEAP_SIZE
;
2016 long min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2017 len
= SCM_EXPHEAP (freelist
->heap_size
);
2019 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2021 if (len
< min_cells
)
2022 len
= min_cells
+ freelist
->cluster_size
;
2023 len
*= sizeof (scm_cell
);
2024 /* force new sampling */
2025 freelist
->collected
= LONG_MAX
;
2028 if (len
> scm_max_segment_size
)
2029 len
= scm_max_segment_size
;
2034 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2039 /* Allocate with decaying ambition. */
2040 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2041 && (len
>= smallest
))
2043 scm_sizet rounded_len
= round_to_cluster_size (freelist
, len
);
2044 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2047 init_heap_seg (ptr
, rounded_len
, freelist
);
2054 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2058 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2061 #define FUNC_NAME s_scm_unhash_name
2065 SCM_VALIDATE_SYMBOL (1,name
);
2067 bound
= scm_n_heap_segs
;
2068 for (x
= 0; x
< bound
; ++x
)
2072 p
= scm_heap_table
[x
].bounds
[0];
2073 pbound
= scm_heap_table
[x
].bounds
[1];
2076 SCM cell
= PTR2SCM (p
);
2077 if (SCM_TYP3 (cell
) == scm_tc3_cons_gloc
)
2079 /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
2080 * struct cell. See the corresponding comment in scm_gc_mark.
2082 scm_bits_t word0
= SCM_CELL_WORD_0 (cell
) - scm_tc3_cons_gloc
;
2083 SCM gloc_car
= SCM_PACK (word0
); /* access as gloc */
2084 SCM vcell
= SCM_CELL_OBJECT_1 (gloc_car
);
2085 if ((SCM_TRUE_P (name
) || SCM_EQ_P (SCM_CAR (gloc_car
), name
))
2086 && (SCM_UNPACK (vcell
) != 0) && (SCM_UNPACK (vcell
) != 1))
2088 SCM_SET_CELL_OBJECT_0 (cell
, name
);
2101 /* {GC Protection Helper Functions}
2106 scm_remember (SCM
*ptr
)
2111 These crazy functions prevent garbage collection
2112 of arguments after the first argument by
2113 ensuring they remain live throughout the
2114 function because they are used in the last
2115 line of the code block.
2116 It'd be better to have a nice compiler hint to
2117 aid the conservative stack-scanning GC. --03/09/00 gjb */
2119 scm_return_first (SCM elt
, ...)
2125 scm_return_first_int (int i
, ...)
2132 scm_permanent_object (SCM obj
)
2135 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2141 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2142 even if all other references are dropped, until someone applies
2143 scm_unprotect_object to it. This function returns OBJ.
2145 Calls to scm_protect_object nest. For every object OBJ, there is a
2146 counter which scm_protect_object(OBJ) increments and
2147 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2148 an object's counter is greater than zero, the garbage collector
2149 will not free it. */
2152 scm_protect_object (SCM obj
)
2156 /* This critical section barrier will be replaced by a mutex. */
2159 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2161 if (SCM_IMP (handle
))
2162 scm_hashq_create_handle_x (scm_protects
, obj
, SCM_MAKINUM (1));
2164 SCM_SETCDR (handle
, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle
)) + 1));
2172 /* Remove any protection for OBJ established by a prior call to
2173 scm_protect_object. This function returns OBJ.
2175 See scm_protect_object for more information. */
2177 scm_unprotect_object (SCM obj
)
2181 /* This critical section barrier will be replaced by a mutex. */
2184 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2186 if (SCM_NIMP (handle
))
2188 int count
= SCM_INUM (SCM_CAR (handle
)) - 1;
2190 scm_hashq_remove_x (scm_protects
, obj
);
2192 SCM_SETCDR (handle
, SCM_MAKINUM (count
));
2202 /* called on process termination. */
2208 extern int on_exit (void (*procp
) (), int arg
);
2211 cleanup (int status
, void *arg
)
2213 #error Dont know how to setup a cleanup handler on your system.
2218 scm_flush_all_ports ();
2223 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2225 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2226 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2230 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2231 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2239 if (freelist
->min_yield_fraction
)
2240 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2242 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2249 init_freelist (scm_freelist_t
*freelist
,
2254 freelist
->clusters
= SCM_EOL
;
2255 freelist
->cluster_size
= cluster_size
+ 1;
2256 freelist
->left_to_collect
= 0;
2257 freelist
->clusters_allocated
= 0;
2258 freelist
->min_yield
= 0;
2259 freelist
->min_yield_fraction
= min_yield
;
2260 freelist
->span
= span
;
2261 freelist
->collected
= 0;
2262 freelist
->collected_1
= 0;
2263 freelist
->heap_size
= 0;
2267 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2268 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2269 scm_sizet max_segment_size
)
2273 if (!init_heap_size_1
)
2274 init_heap_size_1
= SCM_INIT_HEAP_SIZE_1
;
2275 if (!init_heap_size_2
)
2276 init_heap_size_2
= SCM_INIT_HEAP_SIZE_2
;
2278 j
= SCM_NUM_PROTECTS
;
2280 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2283 scm_freelist
= SCM_EOL
;
2284 scm_freelist2
= SCM_EOL
;
2285 init_freelist (&scm_master_freelist
,
2286 1, SCM_CLUSTER_SIZE_1
,
2287 gc_trigger_1
? gc_trigger_1
: SCM_MIN_YIELD_1
);
2288 init_freelist (&scm_master_freelist2
,
2289 2, SCM_CLUSTER_SIZE_2
,
2290 gc_trigger_2
? gc_trigger_2
: SCM_MIN_YIELD_2
);
2291 scm_max_segment_size
2292 = max_segment_size
? max_segment_size
: SCM_MAX_SEGMENT_SIZE
;
2296 j
= SCM_HEAP_SEG_SIZE
;
2297 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2298 scm_heap_table
= ((scm_heap_seg_data_t
*)
2299 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2301 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2302 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2305 /* scm_hplims[0] can change. do not remove scm_heap_org */
2306 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2308 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2309 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2310 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2311 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2312 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2314 /* Initialise the list of ports. */
2315 scm_port_table
= (scm_port
**)
2316 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2317 if (!scm_port_table
)
2324 on_exit (cleanup
, 0);
2328 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2329 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2331 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2332 scm_nullstr
= scm_makstr (0L, 0);
2333 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2334 scm_symhash
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2335 scm_weak_symhash
= scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim
));
2336 scm_symhash_vars
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2337 scm_stand_in_procs
= SCM_EOL
;
2338 scm_permobjs
= SCM_EOL
;
2339 scm_protects
= scm_make_vector (SCM_MAKINUM (31), SCM_EOL
);
2340 scm_asyncs
= SCM_EOL
;
2341 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2342 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2344 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));
2353 scm_after_gc_hook
= scm_create_hook ("after-gc-hook", 0);
2354 #include "libguile/gc.x"