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 */
52 #include "guardians.h"
74 #define var_start(x, y) va_start(x, y)
77 #define var_start(x, y) va_start(x)
81 /* {heap tuning parameters}
83 * These are parameters for controlling memory allocation. The heap
84 * is the area out of which scm_cons, and object headers are allocated.
86 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
87 * 64 bit machine. The units of the _SIZE parameters are bytes.
88 * Cons pairs and object headers occupy one heap cell.
90 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
91 * allocated initially the heap will grow by half its current size
92 * each subsequent time more heap is needed.
94 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
95 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
96 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
97 * is in scm_init_storage() and alloc_some_heap() in sys.c
99 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
100 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
102 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
105 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
108 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
109 * reclaimed by a GC triggered by must_malloc. If less than this is
110 * reclaimed, the trigger threshold is raised. [I don't know what a
111 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
112 * work around a oscillation that caused almost constant GC.]
115 #define SCM_INIT_HEAP_SIZE_1 (50000L * sizeof (scm_cell))
116 #define SCM_CLUSTER_SIZE_1 2000L
117 #define SCM_GC_TRIGGER_1 -45
119 #define SCM_INIT_HEAP_SIZE_2 (2500L * 2 * sizeof (scm_cell))
120 #define SCM_CLUSTER_SIZE_2 1000L
121 /* The following value may seem large, but note that if we get to GC at
122 * all, this means that we have a numerically intensive application
124 #define SCM_GC_TRIGGER_2 -45
126 #define SCM_MAX_SEGMENT_SIZE 2097000L /* a little less (adm) than 2 Mb */
128 #define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell))
130 # define SCM_HEAP_SEG_SIZE 32768L
133 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
135 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
138 /* Make heap grow with factor 1.5 */
139 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
140 #define SCM_INIT_MALLOC_LIMIT 100000
141 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
143 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
144 bounds for allocated storage */
147 /*in 386 protected mode we must only adjust the offset */
148 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
149 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
152 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
153 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
155 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
156 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
159 #define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell))
160 #define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1)
161 #ifdef GUILE_NEW_GC_SCHEME
162 #define SCM_HEAP_SIZE \
163 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
165 #define SCM_HEAP_SIZE (scm_freelist.heap_size + scm_freelist2.heap_size)
173 typedef struct scm_freelist_t
{
174 /* collected cells */
176 #ifdef GUILE_NEW_GC_SCHEME
177 /* number of cells left to collect before cluster is full */
178 unsigned int left_to_collect
;
179 /* number of clusters which have been allocated */
180 unsigned int clusters_allocated
;
181 /* a list of freelists, each of size gc_trigger,
182 except the last one which may be shorter */
185 /* this is the number of objects in each cluster, including the spine cell */
187 /* set to grow the heap when we run out of clusters
190 /* minimum number of objects allocated before GC is triggered
193 /* defines gc_trigger as percent of heap size
194 * 0 => constant trigger
196 int gc_trigger_fraction
;
198 /* number of cells per object on this list */
200 /* number of collected cells during last GC */
202 /* total number of cells in heap segments
203 * belonging to this list.
208 #ifdef GUILE_NEW_GC_SCHEME
209 SCM scm_freelist
= SCM_EOL
;
210 scm_freelist_t scm_master_freelist
= {
211 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
213 SCM scm_freelist2
= SCM_EOL
;
214 scm_freelist_t scm_master_freelist2
= {
215 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
218 scm_freelist_t scm_freelist
= { SCM_EOL
, 1, 0, 0 };
219 scm_freelist_t scm_freelist2
= { SCM_EOL
, 2, 0, 0 };
223 * is the number of bytes of must_malloc allocation needed to trigger gc.
225 unsigned long scm_mtrigger
;
229 * If set, don't expand the heap. Set only during gc, during which no allocation
230 * is supposed to take place anyway.
232 int scm_gc_heap_lock
= 0;
235 * Don't pause for collection if this is set -- just
239 int scm_block_gc
= 1;
241 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
242 * collection (GC) more space is allocated for the heap.
244 #define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
246 /* During collection, this accumulates objects holding
249 SCM scm_weak_vectors
;
251 /* GC Statistics Keeping
253 unsigned long scm_cells_allocated
= 0;
254 long scm_mallocated
= 0;
255 unsigned long scm_gc_cells_collected
;
256 unsigned long scm_gc_malloc_collected
;
257 unsigned long scm_gc_ports_collected
;
258 unsigned long scm_gc_rt
;
259 unsigned long scm_gc_time_taken
= 0;
261 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
262 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
263 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
264 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
265 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
266 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
268 typedef struct scm_heap_seg_data_t
270 /* lower and upper bounds of the segment */
271 SCM_CELLPTR bounds
[2];
273 /* address of the head-of-freelist pointer for this segment's cells.
274 All segments usually point to the same one, scm_freelist. */
275 scm_freelist_t
*freelist
;
277 /* number of SCM words per object in this segment */
280 /* If SEG_DATA->valid is non-zero, the conservative marking
281 functions will apply SEG_DATA->valid to the purported pointer and
282 SEG_DATA, and mark the object iff the function returns non-zero.
283 At the moment, I don't think anyone uses this. */
285 } scm_heap_seg_data_t
;
290 static void scm_mark_weak_vector_spines (void);
291 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
292 static void alloc_some_heap (scm_freelist_t
*);
296 /* Debugging functions. */
298 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
300 /* Return the number of the heap segment containing CELL. */
306 for (i
= 0; i
< scm_n_heap_segs
; i
++)
307 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
308 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
310 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
316 #ifdef GUILE_NEW_GC_SCHEME
318 map_free_list (scm_freelist_t
*master
, SCM freelist
)
320 int last_seg
= -1, count
= 0;
323 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
325 int this_seg
= which_seg (f
);
327 if (this_seg
!= last_seg
)
330 fprintf (stderr
, " %5d %d-cells in segment %d\n",
331 count
, master
->span
, last_seg
);
338 fprintf (stderr
, " %5d %d-cells in segment %d\n",
339 count
, master
->span
, last_seg
);
343 map_free_list (scm_freelist_t
*freelist
)
345 int last_seg
= -1, count
= 0;
348 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
))
350 int this_seg
= which_seg (f
);
352 if (this_seg
!= last_seg
)
355 fprintf (stderr
, " %5d %d-cells in segment %d\n",
356 count
, freelist
->span
, last_seg
);
363 fprintf (stderr
, " %5d %d-cells in segment %d\n",
364 count
, freelist
->span
, last_seg
);
368 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
370 "Print debugging information about the free-list.\n"
371 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
372 #define FUNC_NAME s_scm_map_free_list
375 fprintf (stderr
, "%d segments total (%d:%d",
377 scm_heap_table
[0].span
,
378 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
379 for (i
= 1; i
< scm_n_heap_segs
; i
++)
380 fprintf (stderr
, ", %d:%d",
381 scm_heap_table
[i
].span
,
382 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
383 fprintf (stderr
, ")\n");
384 #ifdef GUILE_NEW_GC_SCHEME
385 map_free_list (&scm_master_freelist
, scm_freelist
);
386 map_free_list (&scm_master_freelist2
, scm_freelist2
);
388 map_free_list (&scm_freelist
);
389 map_free_list (&scm_freelist2
);
393 return SCM_UNSPECIFIED
;
397 #ifdef GUILE_NEW_GC_SCHEME
398 static int last_cluster
;
399 static int last_size
;
402 free_list_length (char *title
, int i
, SCM freelist
)
406 for (ls
= freelist
; SCM_NNULLP (ls
); ls
= SCM_CDR (ls
))
407 if (SCM_UNPACK_CAR (ls
) == scm_tc_free_cell
)
411 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
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
);
424 fprintf (stderr
, "%s %d", title
, i
);
426 fprintf (stderr
, "%s\t%d\n", title
, n
);
434 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
437 int i
= 0, len
, n
= 0;
438 fprintf (stderr
, "%s\n\n", title
);
439 n
+= free_list_length ("free list", -1, freelist
);
440 for (clusters
= master
->clusters
;
441 SCM_NNULLP (clusters
);
442 clusters
= SCM_CDR (clusters
))
444 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
447 if (last_cluster
== i
- 1)
448 fprintf (stderr
, "\t%d\n", last_size
);
450 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
451 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
454 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
456 "Print debugging information about the free-list.\n"
457 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
458 #define FUNC_NAME s_scm_free_list_length
460 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
461 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
462 return SCM_UNSPECIFIED
;
469 #ifdef GUILE_DEBUG_FREELIST
471 /* Number of calls to SCM_NEWCELL since startup. */
472 static unsigned long scm_newcell_count
;
473 static unsigned long scm_newcell2_count
;
475 /* Search freelist for anything that isn't marked as a free cell.
476 Abort if we find something. */
477 #ifdef GUILE_NEW_GC_SCHEME
479 scm_check_freelist (SCM freelist
)
484 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
485 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
487 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
488 scm_newcell_count
, i
);
495 scm_check_freelist (scm_freelist_t
*freelist
)
500 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
501 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
503 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
504 scm_newcell_count
, i
);
511 static int scm_debug_check_freelist
= 0;
513 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
515 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
516 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
517 "compile-time flag was selected.\n")
518 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
520 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
521 return SCM_UNSPECIFIED
;
526 #ifdef GUILE_NEW_GC_SCHEME
529 scm_debug_newcell (void)
534 if (scm_debug_check_freelist
)
536 scm_check_freelist (scm_freelist
);
540 /* The rest of this is supposed to be identical to the SCM_NEWCELL
542 if (SCM_IMP (scm_freelist
))
543 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
547 scm_freelist
= SCM_CDR (scm_freelist
);
548 SCM_SETCAR (new, scm_tc16_allocated
);
555 scm_debug_newcell2 (void)
559 scm_newcell2_count
++;
560 if (scm_debug_check_freelist
)
562 scm_check_freelist (scm_freelist2
);
566 /* The rest of this is supposed to be identical to the SCM_NEWCELL
568 if (SCM_IMP (scm_freelist2
))
569 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
573 scm_freelist2
= SCM_CDR (scm_freelist2
);
574 SCM_SETCAR (new, scm_tc16_allocated
);
580 #else /* GUILE_NEW_GC_SCHEME */
583 scm_debug_newcell (void)
588 if (scm_debug_check_freelist
)
590 scm_check_freelist (&scm_freelist
);
594 /* The rest of this is supposed to be identical to the SCM_NEWCELL
596 if (SCM_IMP (scm_freelist
.cells
))
597 new = scm_gc_for_newcell (&scm_freelist
);
600 new = scm_freelist
.cells
;
601 scm_freelist
.cells
= SCM_CDR (scm_freelist
.cells
);
602 SCM_SETCAR (new, scm_tc16_allocated
);
603 ++scm_cells_allocated
;
610 scm_debug_newcell2 (void)
614 scm_newcell2_count
++;
615 if (scm_debug_check_freelist
) {
616 scm_check_freelist (&scm_freelist2
);
620 /* The rest of this is supposed to be identical to the SCM_NEWCELL2
622 if (SCM_IMP (scm_freelist2
.cells
))
623 new = scm_gc_for_newcell (&scm_freelist2
);
626 new = scm_freelist2
.cells
;
627 scm_freelist2
.cells
= SCM_CDR (scm_freelist2
.cells
);
628 SCM_SETCAR (new, scm_tc16_allocated
);
629 scm_cells_allocated
+= 2;
635 #endif /* GUILE_NEW_GC_SCHEME */
636 #endif /* GUILE_DEBUG_FREELIST */
640 #ifdef GUILE_NEW_GC_SCHEME
642 master_cells_allocated (scm_freelist_t
*master
)
644 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
645 if (SCM_NULLP (master
->clusters
))
646 objects
-= master
->left_to_collect
;
647 return master
->span
* objects
;
651 freelist_length (SCM freelist
)
654 for (n
= 0; SCM_NNULLP (freelist
); freelist
= SCM_CDR (freelist
))
660 compute_cells_allocated ()
662 return (scm_cells_allocated
663 + master_cells_allocated (&scm_master_freelist
)
664 + master_cells_allocated (&scm_master_freelist2
)
665 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
666 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
670 /* {Scheme Interface to GC}
673 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
675 "Returns an association list of statistics about Guile's current use of storage. ")
676 #define FUNC_NAME s_scm_gc_stats
681 long int local_scm_mtrigger
;
682 long int local_scm_mallocated
;
683 long int local_scm_heap_size
;
684 long int local_scm_cells_allocated
;
685 long int local_scm_gc_time_taken
;
693 for (i
= scm_n_heap_segs
; i
--; )
694 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
695 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
697 if (scm_n_heap_segs
!= n
)
702 local_scm_mtrigger
= scm_mtrigger
;
703 local_scm_mallocated
= scm_mallocated
;
704 local_scm_heap_size
= SCM_HEAP_SIZE
;
705 #ifdef GUILE_NEW_GC_SCHEME
706 local_scm_cells_allocated
= compute_cells_allocated ();
708 local_scm_cells_allocated
= scm_cells_allocated
;
710 local_scm_gc_time_taken
= scm_gc_time_taken
;
712 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
713 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
714 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
715 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
716 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
717 scm_cons (sym_heap_segments
, heap_segs
),
726 scm_gc_start (const char *what
)
728 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
729 scm_gc_cells_collected
= 0;
730 scm_gc_malloc_collected
= 0;
731 scm_gc_ports_collected
= 0;
737 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
738 scm_gc_time_taken
+= scm_gc_rt
;
739 scm_system_async_mark (scm_gc_async
);
743 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
745 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
746 "returned by this function for @var{obj}")
747 #define FUNC_NAME s_scm_object_address
749 return scm_ulong2num ((unsigned long) obj
);
754 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
756 "Scans all of SCM objects and reclaims for further use those that are\n"
757 "no longer accessible.")
758 #define FUNC_NAME s_scm_gc
763 return SCM_UNSPECIFIED
;
769 /* {C Interface For When GC is Triggered}
772 #ifdef GUILE_NEW_GC_SCHEME
775 adjust_gc_trigger (scm_freelist_t
*freelist
, unsigned long yield
)
777 /* GC trigger is adjusted so that next predicted yield is
778 * gc_trigger_fraction of total heap size.
780 * The reason why we look at actual yield instead of collected cells
781 * is that we want to take other freelists into account. On this
782 * freelist, we know that yield = collected cells, but that's
783 * probably not the case on the other lists.
785 * (We might consider computing a better prediction, for example
786 * by computing an average over multiple GC:s.)
788 if (freelist
->gc_trigger_fraction
)
790 int delta
= ((SCM_HEAP_SIZE
* freelist
->gc_trigger_fraction
/ 100)
793 fprintf (stderr
, " after GC = %d, delta = %d\n",
798 freelist
->gc_trigger
+= delta
;;
802 /* When we get POSIX threads support, the master will be global and
803 * common while the freelist will be individual for each thread.
807 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
813 if (SCM_NULLP (master
->clusters
))
815 if (master
->grow_heap_p
)
817 master
->grow_heap_p
= 0;
818 alloc_some_heap (master
);
822 unsigned long allocated
823 = (scm_cells_allocated
824 + master_cells_allocated (&scm_master_freelist
)
825 + master_cells_allocated (&scm_master_freelist2
));
827 fprintf (stderr
, "allocated = %d, ", allocated
);
830 adjust_gc_trigger (master
, allocated
- scm_cells_allocated
);
833 cell
= SCM_CAR (master
->clusters
);
834 master
->clusters
= SCM_CDR (master
->clusters
);
835 ++master
->clusters_allocated
;
837 while (SCM_NULLP (cell
));
839 *freelist
= SCM_CDR (cell
);
840 SCM_SETCAR (cell
, scm_tc16_allocated
);
845 /* This is a support routine which can be used to reserve a cluster
846 * for some special use, such as debugging. It won't be useful until
847 * free cells are preserved between garbage collections.
851 scm_alloc_cluster (scm_freelist_t
*master
)
854 cell
= scm_gc_for_newcell (master
, &freelist
);
855 SCM_SETCDR (cell
, freelist
);
860 #else /* GUILE_NEW_GC_SCHEME */
863 scm_gc_for_alloc (scm_freelist_t
*freelist
)
867 #ifdef GUILE_DEBUG_FREELIST
868 fprintf (stderr
, "Collected: %d, min_yield: %d\n",
869 freelist
->collected
, MIN_GC_YIELD (freelist
));
871 if ((freelist
->collected
< MIN_GC_YIELD (freelist
))
872 || SCM_IMP (freelist
->cells
))
873 alloc_some_heap (freelist
);
879 scm_gc_for_newcell (scm_freelist_t
*freelist
)
882 scm_gc_for_alloc (freelist
);
883 fl
= freelist
->cells
;
884 freelist
->cells
= SCM_CDR (fl
);
885 SCM_SETCAR (fl
, scm_tc16_allocated
);
889 #endif /* GUILE_NEW_GC_SCHEME */
892 scm_igc (const char *what
)
898 SCM_NULLP (scm_freelist
)
900 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
903 /* During the critical section, only the current thread may run. */
904 SCM_THREAD_CRITICAL_SECTION_START
;
907 /* fprintf (stderr, "gc: %s\n", what); */
911 if (!scm_stack_base
|| scm_block_gc
)
917 if (scm_mallocated
< 0)
918 /* The byte count of allocated objects has underflowed. This is
919 probably because you forgot to report the sizes of objects you
920 have allocated, by calling scm_done_malloc or some such. When
921 the GC freed them, it subtracted their size from
922 scm_mallocated, which underflowed. */
925 if (scm_gc_heap_lock
)
926 /* We've invoked the collector while a GC is already in progress.
927 That should never happen. */
932 scm_weak_vectors
= SCM_EOL
;
934 scm_guardian_gc_init ();
936 /* unprotect any struct types with no instances */
942 pos
= &scm_type_obj_list
;
943 type_list
= scm_type_obj_list
;
944 while (type_list
!= SCM_EOL
)
945 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
947 pos
= SCM_CDRLOC (type_list
);
948 type_list
= SCM_CDR (type_list
);
952 *pos
= SCM_CDR (type_list
);
953 type_list
= SCM_CDR (type_list
);
958 /* flush dead entries from the continuation stack */
963 elts
= SCM_VELTS (scm_continuation_stack
);
964 bound
= SCM_LENGTH (scm_continuation_stack
);
965 x
= SCM_INUM (scm_continuation_stack_ptr
);
968 elts
[x
] = SCM_BOOL_F
;
975 /* Protect from the C stack. This must be the first marking
976 * done because it provides information about what objects
977 * are "in-use" by the C code. "in-use" objects are those
978 * for which the values from SCM_LENGTH and SCM_CHARS must remain
979 * usable. This requirement is stricter than a liveness
980 * requirement -- in particular, it constrains the implementation
981 * of scm_vector_set_length_x.
983 SCM_FLUSH_REGISTER_WINDOWS
;
984 /* This assumes that all registers are saved into the jmp_buf */
985 setjmp (scm_save_regs_gc_mark
);
986 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
987 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
988 sizeof scm_save_regs_gc_mark
)
989 / sizeof (SCM_STACKITEM
)));
992 /* stack_len is long rather than scm_sizet in order to guarantee that
993 &stack_len is long aligned */
994 #ifdef SCM_STACK_GROWS_UP
996 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
998 long stack_len
= scm_stack_size (scm_stack_base
);
1000 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
1003 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
1005 long stack_len
= scm_stack_size (scm_stack_base
);
1007 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
1011 #else /* USE_THREADS */
1013 /* Mark every thread's stack and registers */
1014 scm_threads_mark_stacks ();
1016 #endif /* USE_THREADS */
1018 /* FIXME: insert a phase to un-protect string-data preserved
1019 * in scm_vector_set_length_x.
1022 j
= SCM_NUM_PROTECTS
;
1024 scm_gc_mark (scm_sys_protects
[j
]);
1026 /* FIXME: we should have a means to register C functions to be run
1027 * in different phases of GC
1029 scm_mark_subr_table ();
1032 scm_gc_mark (scm_root
->handle
);
1035 scm_mark_weak_vector_spines ();
1037 scm_guardian_zombify ();
1045 SCM_THREAD_CRITICAL_SECTION_END
;
1055 /* Mark an object precisely.
1070 if (SCM_NCELLP (ptr
))
1071 scm_wta (ptr
, "rogue pointer in heap", NULL
);
1073 switch (SCM_TYP7 (ptr
))
1075 case scm_tcs_cons_nimcar
:
1076 if (SCM_GCMARKP (ptr
))
1078 SCM_SETGCMARK (ptr
);
1079 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
1081 ptr
= SCM_CAR (ptr
);
1084 scm_gc_mark (SCM_CAR (ptr
));
1085 ptr
= SCM_GCCDR (ptr
);
1087 case scm_tcs_cons_imcar
:
1088 if (SCM_GCMARKP (ptr
))
1090 SCM_SETGCMARK (ptr
);
1091 ptr
= SCM_GCCDR (ptr
);
1094 if (SCM_GCMARKP (ptr
))
1096 SCM_SETGCMARK (ptr
);
1097 scm_gc_mark (SCM_CELL_WORD (ptr
, 2));
1098 ptr
= SCM_GCCDR (ptr
);
1100 case scm_tcs_cons_gloc
:
1101 if (SCM_GCMARKP (ptr
))
1103 SCM_SETGCMARK (ptr
);
1106 vcell
= SCM_CAR (ptr
) - 1L;
1107 switch (SCM_UNPACK (SCM_CDR (vcell
)))
1110 scm_gc_mark (vcell
);
1111 ptr
= SCM_GCCDR (ptr
);
1123 vtable_data
= (SCM
*)vcell
;
1124 layout
= vtable_data
[scm_vtable_index_layout
];
1125 len
= SCM_LENGTH (layout
);
1126 fields_desc
= SCM_CHARS (layout
);
1127 /* We're using SCM_GCCDR here like STRUCT_DATA, except
1128 that it removes the mark */
1129 mem
= (SCM
*)SCM_GCCDR (ptr
);
1131 if (SCM_UNPACK (vtable_data
[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
1133 scm_gc_mark (mem
[scm_struct_i_procedure
]);
1134 scm_gc_mark (mem
[scm_struct_i_setter
]);
1138 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
1139 if (fields_desc
[x
] == 'p')
1141 if (fields_desc
[x
] == 'p')
1144 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1145 for (j
= (long int) *mem
; x
; --x
)
1146 scm_gc_mark (*++mem
);
1151 if (!SCM_CDR (vcell
))
1153 SCM_SETGCMARK (vcell
);
1154 ptr
= vtable_data
[scm_vtable_index_vtable
];
1161 case scm_tcs_closures
:
1162 if (SCM_GCMARKP (ptr
))
1164 SCM_SETGCMARK (ptr
);
1165 if (SCM_IMP (SCM_CDR (ptr
)))
1167 ptr
= SCM_CLOSCAR (ptr
);
1170 scm_gc_mark (SCM_CLOSCAR (ptr
));
1171 ptr
= SCM_GCCDR (ptr
);
1173 case scm_tc7_vector
:
1174 case scm_tc7_lvector
:
1178 if (SCM_GC8MARKP (ptr
))
1180 SCM_SETGC8MARK (ptr
);
1181 i
= SCM_LENGTH (ptr
);
1185 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1186 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1187 ptr
= SCM_VELTS (ptr
)[0];
1189 case scm_tc7_contin
:
1192 SCM_SETGC8MARK (ptr
);
1193 if (SCM_VELTS (ptr
))
1194 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1197 (sizeof (SCM_STACKITEM
) + -1 +
1198 sizeof (scm_contregs
)) /
1199 sizeof (SCM_STACKITEM
)));
1203 case scm_tc7_byvect
:
1210 #ifdef HAVE_LONG_LONGS
1211 case scm_tc7_llvect
:
1214 case scm_tc7_string
:
1215 SCM_SETGC8MARK (ptr
);
1218 case scm_tc7_substring
:
1219 if (SCM_GC8MARKP(ptr
))
1221 SCM_SETGC8MARK (ptr
);
1222 ptr
= SCM_CDR (ptr
);
1226 if (SCM_GC8MARKP(ptr
))
1228 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1229 scm_weak_vectors
= ptr
;
1230 SCM_SETGC8MARK (ptr
);
1231 if (SCM_IS_WHVEC_ANY (ptr
))
1238 len
= SCM_LENGTH (ptr
);
1239 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1240 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1242 for (x
= 0; x
< len
; ++x
)
1245 alist
= SCM_VELTS (ptr
)[x
];
1247 /* mark everything on the alist except the keys or
1248 * values, according to weak_values and weak_keys. */
1249 while ( SCM_CONSP (alist
)
1250 && !SCM_GCMARKP (alist
)
1251 && SCM_CONSP (SCM_CAR (alist
)))
1256 kvpair
= SCM_CAR (alist
);
1257 next_alist
= SCM_CDR (alist
);
1260 * SCM_SETGCMARK (alist);
1261 * SCM_SETGCMARK (kvpair);
1263 * It may be that either the key or value is protected by
1264 * an escaped reference to part of the spine of this alist.
1265 * If we mark the spine here, and only mark one or neither of the
1266 * key and value, they may never be properly marked.
1267 * This leads to a horrible situation in which an alist containing
1268 * freelist cells is exported.
1270 * So only mark the spines of these arrays last of all marking.
1271 * If somebody confuses us by constructing a weak vector
1272 * with a circular alist then we are hosed, but at least we
1273 * won't prematurely drop table entries.
1276 scm_gc_mark (SCM_CAR (kvpair
));
1278 scm_gc_mark (SCM_GCCDR (kvpair
));
1281 if (SCM_NIMP (alist
))
1282 scm_gc_mark (alist
);
1287 case scm_tc7_msymbol
:
1288 if (SCM_GC8MARKP(ptr
))
1290 SCM_SETGC8MARK (ptr
);
1291 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1292 ptr
= SCM_SYMBOL_PROPS (ptr
);
1294 case scm_tc7_ssymbol
:
1295 if (SCM_GC8MARKP(ptr
))
1297 SCM_SETGC8MARK (ptr
);
1302 i
= SCM_PTOBNUM (ptr
);
1303 if (!(i
< scm_numptob
))
1305 if (SCM_GC8MARKP (ptr
))
1307 SCM_SETGC8MARK (ptr
);
1308 if (SCM_PTAB_ENTRY(ptr
))
1309 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1310 if (scm_ptobs
[i
].mark
)
1312 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1319 if (SCM_GC8MARKP (ptr
))
1321 SCM_SETGC8MARK (ptr
);
1322 switch (SCM_GCTYP16 (ptr
))
1323 { /* should be faster than going through scm_smobs */
1324 case scm_tc_free_cell
:
1325 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1326 case scm_tc16_allocated
:
1329 case scm_tc16_complex
:
1332 i
= SCM_SMOBNUM (ptr
);
1333 if (!(i
< scm_numsmob
))
1335 if (scm_smobs
[i
].mark
)
1337 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1345 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1350 /* Mark a Region Conservatively
1354 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1356 register long m
= n
;
1358 register SCM_CELLPTR ptr
;
1361 if (SCM_CELLP (*(SCM
**) (& x
[m
])))
1363 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
1365 j
= scm_n_heap_segs
- 1;
1366 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1367 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1374 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1376 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1384 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1388 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1393 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1397 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1403 if ( !scm_heap_table
[seg_id
].valid
1404 || scm_heap_table
[seg_id
].valid (ptr
,
1405 &scm_heap_table
[seg_id
]))
1406 if ( scm_heap_table
[seg_id
].span
== 1
1407 || SCM_DOUBLE_CELLP (*(SCM
**) (& x
[m
])))
1408 scm_gc_mark (*(SCM
*) & x
[m
]);
1417 /* The following is a C predicate which determines if an SCM value can be
1418 regarded as a pointer to a cell on the heap. The code is duplicated
1419 from scm_mark_locations. */
1423 scm_cellp (SCM value
)
1426 register SCM_CELLPTR ptr
;
1428 if SCM_CELLP (*(SCM
**) (& value
))
1430 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
1432 j
= scm_n_heap_segs
- 1;
1433 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1434 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1441 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1443 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1451 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1455 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1460 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1464 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1470 if ( !scm_heap_table
[seg_id
].valid
1471 || scm_heap_table
[seg_id
].valid (ptr
,
1472 &scm_heap_table
[seg_id
]))
1484 scm_mark_weak_vector_spines ()
1488 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1490 if (SCM_IS_WHVEC_ANY (w
))
1498 ptr
= SCM_VELTS (w
);
1500 for (j
= 0; j
< n
; ++j
)
1505 while ( SCM_CONSP (alist
)
1506 && !SCM_GCMARKP (alist
)
1507 && SCM_CONSP (SCM_CAR (alist
)))
1509 SCM_SETGCMARK (alist
);
1510 SCM_SETGCMARK (SCM_CAR (alist
));
1511 alist
= SCM_GCCDR (alist
);
1519 #ifdef GUILE_NEW_GC_SCHEME
1521 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1523 freelist
->cells
= SCM_EOL
;
1524 freelist
->left_to_collect
= freelist
->cluster_size
;
1525 freelist
->clusters_allocated
= 0;
1526 freelist
->clusters
= SCM_EOL
;
1527 freelist
->clustertail
= &freelist
->clusters
;
1528 freelist
->collected
= 0;
1532 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1534 *freelist
->clustertail
= freelist
->cells
;
1535 if (SCM_NNULLP (freelist
->cells
))
1537 SCM c
= freelist
->cells
;
1538 SCM_SETCAR (c
, SCM_CDR (c
));
1539 SCM_SETCDR (c
, SCM_EOL
);
1540 freelist
->collected
+=
1541 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1543 scm_gc_cells_collected
+= freelist
->collected
;
1545 freelist
->grow_heap_p
= (freelist
->collected
< freelist
->gc_trigger
);
1552 register SCM_CELLPTR ptr
;
1553 #ifdef SCM_POINTERS_MUNGED
1554 register SCM scmptr
;
1557 #define scmptr (SCM)ptr
1559 register SCM nfreelist
;
1560 register scm_freelist_t
*freelist
;
1568 #ifdef GUILE_NEW_GC_SCHEME
1569 gc_sweep_freelist_start (&scm_master_freelist
);
1570 gc_sweep_freelist_start (&scm_master_freelist2
);
1572 /* Reset all free list pointers. We'll reconstruct them completely
1574 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1575 scm_heap_table
[i
].freelist
->cells
= SCM_EOL
;
1578 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1580 #ifdef GUILE_NEW_GC_SCHEME
1581 register unsigned int left_to_collect
;
1583 register scm_sizet n
= 0;
1585 register scm_sizet j
;
1587 /* Unmarked cells go onto the front of the freelist this heap
1588 segment points to. Rather than updating the real freelist
1589 pointer as we go along, we accumulate the new head in
1590 nfreelist. Then, if it turns out that the entire segment is
1591 free, we free (i.e., malloc's free) the whole segment, and
1592 simply don't assign nfreelist back into the real freelist. */
1593 freelist
= scm_heap_table
[i
].freelist
;
1594 nfreelist
= freelist
->cells
;
1595 #ifdef GUILE_NEW_GC_SCHEME
1596 left_to_collect
= freelist
->left_to_collect
;
1598 span
= scm_heap_table
[i
].span
;
1600 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1601 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1602 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1604 #ifdef SCM_POINTERS_MUNGED
1605 scmptr
= PTR2SCM (ptr
);
1607 switch SCM_TYP7 (scmptr
)
1609 case scm_tcs_cons_gloc
:
1610 if (SCM_GCMARKP (scmptr
))
1612 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1613 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1618 vcell
= SCM_CAR (scmptr
) - 1L;
1620 if ((SCM_CDR (vcell
) == 0) || (SCM_UNPACK (SCM_CDR (vcell
)) == 1))
1622 scm_struct_free_t free
1623 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1624 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1628 case scm_tcs_cons_imcar
:
1629 case scm_tcs_cons_nimcar
:
1630 case scm_tcs_closures
:
1632 if (SCM_GCMARKP (scmptr
))
1636 if (SCM_GC8MARKP (scmptr
))
1642 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1643 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1647 case scm_tc7_vector
:
1648 case scm_tc7_lvector
:
1652 if (SCM_GC8MARKP (scmptr
))
1655 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1657 scm_must_free (SCM_CHARS (scmptr
));
1658 /* SCM_SETCHARS(scmptr, 0);*/
1662 if SCM_GC8MARKP (scmptr
)
1664 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1666 case scm_tc7_byvect
:
1667 if SCM_GC8MARKP (scmptr
)
1669 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1673 if SCM_GC8MARKP (scmptr
)
1675 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1678 if SCM_GC8MARKP (scmptr
)
1680 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1682 #ifdef HAVE_LONG_LONGS
1683 case scm_tc7_llvect
:
1684 if SCM_GC8MARKP (scmptr
)
1686 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1690 if SCM_GC8MARKP (scmptr
)
1692 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1695 if SCM_GC8MARKP (scmptr
)
1697 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1700 if SCM_GC8MARKP (scmptr
)
1702 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1705 case scm_tc7_substring
:
1706 if (SCM_GC8MARKP (scmptr
))
1709 case scm_tc7_string
:
1710 if (SCM_GC8MARKP (scmptr
))
1712 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1714 case scm_tc7_msymbol
:
1715 if (SCM_GC8MARKP (scmptr
))
1717 m
+= ( SCM_LENGTH (scmptr
)
1719 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1720 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1722 case scm_tc7_contin
:
1723 if SCM_GC8MARKP (scmptr
)
1725 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1726 if (SCM_VELTS (scmptr
))
1728 case scm_tc7_ssymbol
:
1729 if SCM_GC8MARKP(scmptr
)
1735 if SCM_GC8MARKP (scmptr
)
1737 if SCM_OPENP (scmptr
)
1739 int k
= SCM_PTOBNUM (scmptr
);
1740 if (!(k
< scm_numptob
))
1742 /* Keep "revealed" ports alive. */
1743 if (scm_revealed_count (scmptr
) > 0)
1745 /* Yes, I really do mean scm_ptobs[k].free */
1746 /* rather than ftobs[k].close. .close */
1747 /* is for explicit CLOSE-PORT by user */
1748 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1749 SCM_SETSTREAM (scmptr
, 0);
1750 scm_remove_from_port_table (scmptr
);
1751 scm_gc_ports_collected
++;
1752 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1756 switch SCM_GCTYP16 (scmptr
)
1758 case scm_tc_free_cell
:
1760 if SCM_GC8MARKP (scmptr
)
1765 if SCM_GC8MARKP (scmptr
)
1767 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1769 #endif /* def SCM_BIGDIG */
1770 case scm_tc16_complex
:
1771 if SCM_GC8MARKP (scmptr
)
1773 m
+= 2 * sizeof (double);
1776 if SCM_GC8MARKP (scmptr
)
1781 k
= SCM_SMOBNUM (scmptr
);
1782 if (!(k
< scm_numsmob
))
1784 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1790 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1793 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1796 #ifndef GUILE_NEW_GC_SCHEME
1799 if (!--left_to_collect
)
1801 SCM_SETCAR (scmptr
, nfreelist
);
1802 *freelist
->clustertail
= scmptr
;
1803 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1805 nfreelist
= SCM_EOL
;
1806 freelist
->collected
+= span
* freelist
->cluster_size
;
1807 left_to_collect
= freelist
->cluster_size
;
1812 /* Stick the new cell on the front of nfreelist. It's
1813 critical that we mark this cell as freed; otherwise, the
1814 conservative collector might trace it as some other type
1816 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
1817 SCM_SETCDR (scmptr
, nfreelist
);
1823 SCM_CLRGC8MARK (scmptr
);
1826 SCM_CLRGCMARK (scmptr
);
1828 #ifdef GC_FREE_SEGMENTS
1833 freelist
->heap_size
-= seg_size
;
1834 free ((char *) scm_heap_table
[i
].bounds
[0]);
1835 scm_heap_table
[i
].bounds
[0] = 0;
1836 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1837 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1838 scm_n_heap_segs
-= 1;
1839 i
--; /* We need to scan the segment just moved. */
1842 #endif /* ifdef GC_FREE_SEGMENTS */
1844 /* Update the real freelist pointer to point to the head of
1845 the list of free cells we've built for this segment. */
1846 freelist
->cells
= nfreelist
;
1847 #ifdef GUILE_NEW_GC_SCHEME
1848 freelist
->left_to_collect
= left_to_collect
;
1852 #ifndef GUILE_NEW_GC_SCHEME
1853 freelist
->collected
+= n
;
1856 #ifdef GUILE_DEBUG_FREELIST
1857 #ifdef GUILE_NEW_GC_SCHEME
1858 scm_check_freelist (freelist
== &scm_master_freelist
1862 scm_check_freelist (freelist
);
1864 scm_map_free_list ();
1868 #ifdef GUILE_NEW_GC_SCHEME
1869 gc_sweep_freelist_finish (&scm_master_freelist
);
1870 gc_sweep_freelist_finish (&scm_master_freelist2
);
1872 /* When we move to POSIX threads private freelists should probably
1873 be GC-protected instead. */
1874 scm_freelist
= SCM_EOL
;
1875 scm_freelist2
= SCM_EOL
;
1878 /* Scan weak vectors. */
1881 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1883 if (!SCM_IS_WHVEC_ANY (w
))
1887 ptr
= SCM_VELTS (w
);
1889 for (j
= 0; j
< n
; ++j
)
1890 if (SCM_FREEP (ptr
[j
]))
1891 ptr
[j
] = SCM_BOOL_F
;
1893 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1896 register long n
= SCM_LENGTH (w
);
1899 ptr
= SCM_VELTS (w
);
1901 for (j
= 0; j
< n
; ++j
)
1908 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1909 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1914 while ( SCM_CONSP (alist
)
1915 && SCM_CONSP (SCM_CAR (alist
)))
1920 key
= SCM_CAAR (alist
);
1921 value
= SCM_CDAR (alist
);
1922 if ( (weak_keys
&& SCM_FREEP (key
))
1923 || (weak_values
&& SCM_FREEP (value
)))
1925 *fixup
= SCM_CDR (alist
);
1928 fixup
= SCM_CDRLOC (alist
);
1929 alist
= SCM_CDR (alist
);
1935 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1936 scm_mallocated
-= m
;
1937 scm_gc_malloc_collected
= m
;
1943 /* {Front end to malloc}
1945 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1947 * These functions provide services comperable to malloc, realloc, and
1948 * free. They are for allocating malloced parts of scheme objects.
1949 * The primary purpose of the front end is to impose calls to gc.
1953 * Return newly malloced storage or throw an error.
1955 * The parameter WHAT is a string for error reporting.
1956 * If the threshold scm_mtrigger will be passed by this
1957 * allocation, or if the first call to malloc fails,
1958 * garbage collect -- on the presumption that some objects
1959 * using malloced storage may be collected.
1961 * The limit scm_mtrigger may be raised by this allocation.
1964 scm_must_malloc (scm_sizet size
, const char *what
)
1967 unsigned long nm
= scm_mallocated
+ size
;
1969 if (nm
<= scm_mtrigger
)
1971 SCM_SYSCALL (ptr
= malloc (size
));
1974 scm_mallocated
= nm
;
1981 nm
= scm_mallocated
+ size
;
1982 SCM_SYSCALL (ptr
= malloc (size
));
1985 scm_mallocated
= nm
;
1986 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1987 if (nm
> scm_mtrigger
)
1988 scm_mtrigger
= nm
+ nm
/ 2;
1990 scm_mtrigger
+= scm_mtrigger
/ 2;
1995 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1996 return 0; /* never reached */
2001 * is similar to scm_must_malloc.
2004 scm_must_realloc (void *where
,
2010 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
2012 if (nm
<= scm_mtrigger
)
2014 SCM_SYSCALL (ptr
= realloc (where
, size
));
2017 scm_mallocated
= nm
;
2024 nm
= scm_mallocated
+ size
- old_size
;
2025 SCM_SYSCALL (ptr
= realloc (where
, size
));
2028 scm_mallocated
= nm
;
2029 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2030 if (nm
> scm_mtrigger
)
2031 scm_mtrigger
= nm
+ nm
/ 2;
2033 scm_mtrigger
+= scm_mtrigger
/ 2;
2038 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
2039 return 0; /* never reached */
2043 scm_must_free (void *obj
)
2048 scm_wta (SCM_INUM0
, "already free", "");
2051 /* Announce that there has been some malloc done that will be freed
2052 * during gc. A typical use is for a smob that uses some malloced
2053 * memory but can not get it from scm_must_malloc (for whatever
2054 * reason). When a new object of this smob is created you call
2055 * scm_done_malloc with the size of the object. When your smob free
2056 * function is called, be sure to include this size in the return
2060 scm_done_malloc (long size
)
2062 scm_mallocated
+= size
;
2064 if (scm_mallocated
> scm_mtrigger
)
2066 scm_igc ("foreign mallocs");
2067 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
2069 if (scm_mallocated
> scm_mtrigger
)
2070 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
2072 scm_mtrigger
+= scm_mtrigger
/ 2;
2082 * Each heap segment is an array of objects of a particular size.
2083 * Every segment has an associated (possibly shared) freelist.
2084 * A table of segment records is kept that records the upper and
2085 * lower extents of the segment; this is used during the conservative
2086 * phase of gc to identify probably gc roots (because they point
2087 * into valid segments at reasonable offsets). */
2090 * is true if the first segment was smaller than INIT_HEAP_SEG.
2091 * If scm_expmem is set to one, subsequent segment allocations will
2092 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
2096 scm_sizet scm_max_segment_size
;
2099 * is the lowest base address of any heap segment.
2101 SCM_CELLPTR scm_heap_org
;
2103 scm_heap_seg_data_t
* scm_heap_table
= 0;
2104 int scm_n_heap_segs
= 0;
2107 * initializes a new heap segment and return the number of objects it contains.
2109 * The segment origin, segment size in bytes, and the span of objects
2110 * in cells are input parameters. The freelist is both input and output.
2112 * This function presume that the scm_heap_table has already been expanded
2113 * to accomodate a new segment record.
2118 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
2120 register SCM_CELLPTR ptr
;
2121 #ifdef SCM_POINTERS_MUNGED
2122 register SCM scmptr
;
2127 SCM_CELLPTR seg_end
;
2130 int span
= freelist
->span
;
2132 if (seg_org
== NULL
)
2135 ptr
= CELL_UP (seg_org
, span
);
2137 /* Compute the ceiling on valid object pointers w/in this segment.
2139 seg_end
= CELL_DN ((char *) seg_org
+ size
, span
);
2141 /* Find the right place and insert the segment record.
2144 for (new_seg_index
= 0;
2145 ( (new_seg_index
< scm_n_heap_segs
)
2146 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2152 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2153 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2158 scm_heap_table
[new_seg_index
].valid
= 0;
2159 scm_heap_table
[new_seg_index
].span
= span
;
2160 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2161 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
2162 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
2165 /* Compute the least valid object pointer w/in this segment
2167 ptr
= CELL_UP (ptr
, span
);
2171 n_new_cells
= seg_end
- ptr
;
2173 #ifdef GUILE_NEW_GC_SCHEME
2175 freelist
->heap_size
+= n_new_cells
;
2177 /* Partition objects in this segment into clusters */
2180 SCM
*clusterp
= &clusters
;
2181 int n_cluster_cells
= span
* freelist
->cluster_size
;
2183 while (n_new_cells
> span
) /* at least one spine + one freecell */
2185 /* Determine end of cluster
2187 if (n_new_cells
>= n_cluster_cells
)
2189 seg_end
= ptr
+ n_cluster_cells
;
2190 n_new_cells
-= n_cluster_cells
;
2193 /* [cmm] looks like the segment size doesn't divide cleanly by
2194 cluster size. bad cmm! */
2197 /* Allocate cluster spine
2199 *clusterp
= PTR2SCM (ptr
);
2200 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
2201 clusterp
= SCM_CDRLOC (*clusterp
);
2204 while (ptr
< seg_end
)
2206 #ifdef SCM_POINTERS_MUNGED
2207 scmptr
= PTR2SCM (ptr
);
2209 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
2210 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2214 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
2217 /* Patch up the last cluster pointer in the segment
2218 * to join it to the input freelist.
2220 *clusterp
= freelist
->clusters
;
2221 freelist
->clusters
= clusters
;
2224 #else /* GUILE_NEW_GC_SCHEME */
2226 /* Prepend objects in this segment to the freelist.
2228 while (ptr
< seg_end
)
2230 #ifdef SCM_POINTERS_MUNGED
2231 scmptr
= PTR2SCM (ptr
);
2233 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
2234 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2240 /* Patch up the last freelist pointer in the segment
2241 * to join it to the input freelist.
2243 SCM_SETCDR (PTR2SCM (ptr
), freelist
->cells
);
2244 freelist
->cells
= PTR2SCM (CELL_UP (seg_org
, span
));
2246 freelist
->heap_size
+= n_new_cells
;
2248 #endif /* GUILE_NEW_GC_SCHEME */
2251 fprintf (stderr
, "H");
2259 #ifndef GUILE_NEW_GC_SCHEME
2260 #define round_to_cluster_size(freelist, len) len
2264 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
2266 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2269 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2270 + ALIGNMENT_SLACK (freelist
);
2276 alloc_some_heap (scm_freelist_t
*freelist
)
2278 scm_heap_seg_data_t
* tmptable
;
2282 /* Critical code sections (such as the garbage collector)
2283 * aren't supposed to add heap segments.
2285 if (scm_gc_heap_lock
)
2286 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
2288 /* Expand the heap tables to have room for the new segment.
2289 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
2290 * only if the allocation of the segment itself succeeds.
2292 len
= (1 + scm_n_heap_segs
) * sizeof (scm_heap_seg_data_t
);
2294 SCM_SYSCALL (tmptable
= ((scm_heap_seg_data_t
*)
2295 realloc ((char *)scm_heap_table
, len
)));
2297 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
2299 scm_heap_table
= tmptable
;
2302 /* Pick a size for the new heap segment.
2303 * The rule for picking the size of a segment is explained in
2306 #ifdef GUILE_NEW_GC_SCHEME
2308 /* Assure that the new segment is large enough for the new trigger */
2309 int slack
= freelist
->gc_trigger
- scm_gc_cells_collected
;
2310 int min_cells
= 100 * slack
/ (99 - freelist
->gc_trigger_fraction
);
2311 len
= SCM_EXPHEAP (freelist
->heap_size
);
2313 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2315 if (len
< min_cells
)
2316 len
= min_cells
+ 1;
2317 len
*= sizeof (scm_cell
);
2320 if (len
> scm_max_segment_size
)
2321 len
= scm_max_segment_size
;
2325 len
= (scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
));
2326 if ((scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
))
2331 len
= SCM_HEAP_SEG_SIZE
;
2332 #endif /* GUILE_NEW_GC_SCHEME */
2337 #ifndef GUILE_NEW_GC_SCHEME
2338 smallest
= (freelist
->span
* sizeof (scm_cell
));
2340 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2346 /* Allocate with decaying ambition. */
2347 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2348 && (len
>= smallest
))
2350 scm_sizet rounded_len
= round_to_cluster_size(freelist
, len
);
2351 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2354 init_heap_seg (ptr
, rounded_len
, freelist
);
2361 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2366 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2369 #define FUNC_NAME s_scm_unhash_name
2373 SCM_VALIDATE_SYMBOL (1,name
);
2375 bound
= scm_n_heap_segs
;
2376 for (x
= 0; x
< bound
; ++x
)
2380 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
2381 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
2386 if (1 == (7 & (int)incar
))
2389 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
2390 && (SCM_CDR (incar
) != 0)
2391 && (SCM_UNPACK (SCM_CDR (incar
)) != 1))
2406 /* {GC Protection Helper Functions}
2411 scm_remember (SCM
*ptr
)
2416 These crazy functions prevent garbage collection
2417 of arguments after the first argument by
2418 ensuring they remain live throughout the
2419 function because they are used in the last
2420 line of the code block.
2421 It'd be better to have a nice compiler hint to
2422 aid the conservative stack-scanning GC. --03/09/00 gjb */
2424 scm_return_first (SCM elt
, ...)
2430 scm_return_first_int (int i
, ...)
2437 scm_permanent_object (SCM obj
)
2440 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2446 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2447 even if all other references are dropped, until someone applies
2448 scm_unprotect_object to it. This function returns OBJ.
2450 Calls to scm_protect_object nest. For every object OBJ, there is a
2451 counter which scm_protect_object(OBJ) increments and
2452 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2453 an object's counter is greater than zero, the garbage collector
2456 Of course, that's not how it's implemented. scm_protect_object and
2457 scm_unprotect_object just maintain a list of references to things.
2458 Since the GC knows about this list, all objects it mentions stay
2459 alive. scm_protect_object adds its argument to the list;
2460 scm_unprotect_object removes the first occurrence of its argument
2463 scm_protect_object (SCM obj
)
2465 scm_protects
= scm_cons (obj
, scm_protects
);
2471 /* Remove any protection for OBJ established by a prior call to
2472 scm_protect_object. This function returns OBJ.
2474 See scm_protect_object for more information. */
2476 scm_unprotect_object (SCM obj
)
2478 SCM
*tail_ptr
= &scm_protects
;
2480 while (SCM_CONSP (*tail_ptr
))
2481 if (SCM_CAR (*tail_ptr
) == obj
)
2483 *tail_ptr
= SCM_CDR (*tail_ptr
);
2487 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
2494 /* called on process termination. */
2500 extern int on_exit (void (*procp
) (), int arg
);
2503 cleanup (int status
, void *arg
)
2505 #error Dont know how to setup a cleanup handler on your system.
2510 scm_flush_all_ports ();
2515 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2517 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2518 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2522 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2523 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2531 #ifdef GUILE_NEW_GC_SCHEME
2532 if (freelist
->gc_trigger_fraction
)
2533 freelist
->gc_trigger
= (freelist
->heap_size
* freelist
->gc_trigger_fraction
2535 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->gc_trigger
);
2542 #ifdef GUILE_NEW_GC_SCHEME
2544 init_freelist (scm_freelist_t
*freelist
,
2549 freelist
->clusters
= SCM_EOL
;
2550 freelist
->cluster_size
= cluster_size
+ 1;
2551 freelist
->left_to_collect
= 0;
2552 freelist
->clusters_allocated
= 0;
2554 freelist
->gc_trigger_fraction
= - gc_trigger
;
2557 freelist
->gc_trigger
= gc_trigger
;
2558 freelist
->gc_trigger_fraction
= 0;
2560 freelist
->span
= span
;
2561 freelist
->collected
= 0;
2562 freelist
->heap_size
= 0;
2566 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2567 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2568 scm_sizet max_segment_size
)
2571 scm_init_storage (scm_sizet init_heap_size_1
, scm_sizet init_heap_size_2
)
2576 if (!init_heap_size_1
)
2577 init_heap_size_1
= SCM_INIT_HEAP_SIZE_1
;
2578 if (!init_heap_size_2
)
2579 init_heap_size_2
= SCM_INIT_HEAP_SIZE_2
;
2581 j
= SCM_NUM_PROTECTS
;
2583 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2586 #ifdef GUILE_NEW_GC_SCHEME
2587 scm_freelist
= SCM_EOL
;
2588 scm_freelist2
= SCM_EOL
;
2589 init_freelist (&scm_master_freelist
,
2590 1, SCM_CLUSTER_SIZE_1
,
2591 gc_trigger_1
? gc_trigger_1
: SCM_GC_TRIGGER_1
);
2592 init_freelist (&scm_master_freelist2
,
2593 2, SCM_CLUSTER_SIZE_2
,
2594 gc_trigger_2
? gc_trigger_2
: SCM_GC_TRIGGER_2
);
2595 scm_max_segment_size
2596 = max_segment_size
? max_segment_size
: SCM_MAX_SEGMENT_SIZE
;
2598 scm_freelist
.cells
= SCM_EOL
;
2599 scm_freelist
.span
= 1;
2600 scm_freelist
.collected
= 0;
2601 scm_freelist
.heap_size
= 0;
2603 scm_freelist2
.cells
= SCM_EOL
;
2604 scm_freelist2
.span
= 2;
2605 scm_freelist2
.collected
= 0;
2606 scm_freelist2
.heap_size
= 0;
2611 j
= SCM_HEAP_SEG_SIZE
;
2612 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2613 scm_heap_table
= ((scm_heap_seg_data_t
*)
2614 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2616 #ifdef GUILE_NEW_GC_SCHEME
2617 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2618 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2621 if (make_initial_segment (init_heap_size_1
, &scm_freelist
) ||
2622 make_initial_segment (init_heap_size_2
, &scm_freelist2
))
2626 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2628 /* scm_hplims[0] can change. do not remove scm_heap_org */
2629 scm_weak_vectors
= SCM_EOL
;
2631 /* Initialise the list of ports. */
2632 scm_port_table
= (scm_port
**)
2633 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2634 if (!scm_port_table
)
2641 on_exit (cleanup
, 0);
2645 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2646 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2648 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2649 scm_nullstr
= scm_makstr (0L, 0);
2650 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2651 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2652 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
2653 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2654 scm_stand_in_procs
= SCM_EOL
;
2655 scm_permobjs
= SCM_EOL
;
2656 scm_protects
= SCM_EOL
;
2657 scm_asyncs
= SCM_EOL
;
2658 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2659 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2661 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));