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 #ifdef GUILE_NEW_GC_SCHEME
257 unsigned long scm_gc_yield
;
259 unsigned long scm_gc_malloc_collected
;
260 unsigned long scm_gc_ports_collected
;
261 unsigned long scm_gc_rt
;
262 unsigned long scm_gc_time_taken
= 0;
264 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
265 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
266 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
267 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
268 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
269 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
271 typedef struct scm_heap_seg_data_t
273 /* lower and upper bounds of the segment */
274 SCM_CELLPTR bounds
[2];
276 /* address of the head-of-freelist pointer for this segment's cells.
277 All segments usually point to the same one, scm_freelist. */
278 scm_freelist_t
*freelist
;
280 /* number of SCM words per object in this segment */
283 /* If SEG_DATA->valid is non-zero, the conservative marking
284 functions will apply SEG_DATA->valid to the purported pointer and
285 SEG_DATA, and mark the object iff the function returns non-zero.
286 At the moment, I don't think anyone uses this. */
288 } scm_heap_seg_data_t
;
293 static void scm_mark_weak_vector_spines (void);
294 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
295 static void alloc_some_heap (scm_freelist_t
*);
299 /* Debugging functions. */
301 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
303 /* Return the number of the heap segment containing CELL. */
309 for (i
= 0; i
< scm_n_heap_segs
; i
++)
310 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
311 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
313 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
319 #ifdef GUILE_NEW_GC_SCHEME
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
);
346 map_free_list (scm_freelist_t
*freelist
)
348 int last_seg
= -1, count
= 0;
351 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
))
353 int this_seg
= which_seg (f
);
355 if (this_seg
!= last_seg
)
358 fprintf (stderr
, " %5d %d-cells in segment %d\n",
359 count
, freelist
->span
, last_seg
);
366 fprintf (stderr
, " %5d %d-cells in segment %d\n",
367 count
, freelist
->span
, last_seg
);
371 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
373 "Print debugging information about the free-list.\n"
374 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
375 #define FUNC_NAME s_scm_map_free_list
378 fprintf (stderr
, "%d segments total (%d:%d",
380 scm_heap_table
[0].span
,
381 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
382 for (i
= 1; i
< scm_n_heap_segs
; i
++)
383 fprintf (stderr
, ", %d:%d",
384 scm_heap_table
[i
].span
,
385 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
386 fprintf (stderr
, ")\n");
387 #ifdef GUILE_NEW_GC_SCHEME
388 map_free_list (&scm_master_freelist
, scm_freelist
);
389 map_free_list (&scm_master_freelist2
, scm_freelist2
);
391 map_free_list (&scm_freelist
);
392 map_free_list (&scm_freelist2
);
396 return SCM_UNSPECIFIED
;
400 #ifdef GUILE_NEW_GC_SCHEME
401 static int last_cluster
;
402 static int last_size
;
405 free_list_length (char *title
, int i
, SCM freelist
)
409 for (ls
= freelist
; SCM_NNULLP (ls
); ls
= SCM_CDR (ls
))
410 if (SCM_UNPACK_CAR (ls
) == scm_tc_free_cell
)
414 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
421 if (last_cluster
== i
- 1)
422 fprintf (stderr
, "\t%d\n", last_size
);
424 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
427 fprintf (stderr
, "%s %d", title
, i
);
429 fprintf (stderr
, "%s\t%d\n", title
, n
);
437 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
440 int i
= 0, len
, n
= 0;
441 fprintf (stderr
, "%s\n\n", title
);
442 n
+= free_list_length ("free list", -1, freelist
);
443 for (clusters
= master
->clusters
;
444 SCM_NNULLP (clusters
);
445 clusters
= SCM_CDR (clusters
))
447 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
450 if (last_cluster
== i
- 1)
451 fprintf (stderr
, "\t%d\n", last_size
);
453 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
454 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
457 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
459 "Print debugging information about the free-list.\n"
460 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
461 #define FUNC_NAME s_scm_free_list_length
463 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
464 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
465 return SCM_UNSPECIFIED
;
472 #ifdef GUILE_DEBUG_FREELIST
474 /* Number of calls to SCM_NEWCELL since startup. */
475 static unsigned long scm_newcell_count
;
476 static unsigned long scm_newcell2_count
;
478 /* Search freelist for anything that isn't marked as a free cell.
479 Abort if we find something. */
480 #ifdef GUILE_NEW_GC_SCHEME
482 scm_check_freelist (SCM freelist
)
487 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
488 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
490 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
491 scm_newcell_count
, i
);
498 scm_check_freelist (scm_freelist_t
*freelist
)
503 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
504 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
506 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
507 scm_newcell_count
, i
);
514 static int scm_debug_check_freelist
= 0;
516 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
518 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
519 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
520 "compile-time flag was selected.\n")
521 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
523 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
524 return SCM_UNSPECIFIED
;
529 #ifdef GUILE_NEW_GC_SCHEME
532 scm_debug_newcell (void)
537 if (scm_debug_check_freelist
)
539 scm_check_freelist (scm_freelist
);
543 /* The rest of this is supposed to be identical to the SCM_NEWCELL
545 if (SCM_IMP (scm_freelist
))
546 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
550 scm_freelist
= SCM_CDR (scm_freelist
);
551 SCM_SETCAR (new, scm_tc16_allocated
);
558 scm_debug_newcell2 (void)
562 scm_newcell2_count
++;
563 if (scm_debug_check_freelist
)
565 scm_check_freelist (scm_freelist2
);
569 /* The rest of this is supposed to be identical to the SCM_NEWCELL
571 if (SCM_IMP (scm_freelist2
))
572 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
576 scm_freelist2
= SCM_CDR (scm_freelist2
);
577 SCM_SETCAR (new, scm_tc16_allocated
);
583 #else /* GUILE_NEW_GC_SCHEME */
586 scm_debug_newcell (void)
591 if (scm_debug_check_freelist
)
593 scm_check_freelist (&scm_freelist
);
597 /* The rest of this is supposed to be identical to the SCM_NEWCELL
599 if (SCM_IMP (scm_freelist
.cells
))
600 new = scm_gc_for_newcell (&scm_freelist
);
603 new = scm_freelist
.cells
;
604 scm_freelist
.cells
= SCM_CDR (scm_freelist
.cells
);
605 SCM_SETCAR (new, scm_tc16_allocated
);
606 ++scm_cells_allocated
;
613 scm_debug_newcell2 (void)
617 scm_newcell2_count
++;
618 if (scm_debug_check_freelist
) {
619 scm_check_freelist (&scm_freelist2
);
623 /* The rest of this is supposed to be identical to the SCM_NEWCELL2
625 if (SCM_IMP (scm_freelist2
.cells
))
626 new = scm_gc_for_newcell (&scm_freelist2
);
629 new = scm_freelist2
.cells
;
630 scm_freelist2
.cells
= SCM_CDR (scm_freelist2
.cells
);
631 SCM_SETCAR (new, scm_tc16_allocated
);
632 scm_cells_allocated
+= 2;
638 #endif /* GUILE_NEW_GC_SCHEME */
639 #endif /* GUILE_DEBUG_FREELIST */
643 #ifdef GUILE_NEW_GC_SCHEME
645 master_cells_allocated (scm_freelist_t
*master
)
647 int objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
648 if (SCM_NULLP (master
->clusters
))
649 objects
-= master
->left_to_collect
;
650 return master
->span
* objects
;
654 freelist_length (SCM freelist
)
657 for (n
= 0; SCM_NNULLP (freelist
); freelist
= SCM_CDR (freelist
))
663 compute_cells_allocated ()
665 return (scm_cells_allocated
666 + master_cells_allocated (&scm_master_freelist
)
667 + master_cells_allocated (&scm_master_freelist2
)
668 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
669 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
673 /* {Scheme Interface to GC}
676 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
678 "Returns an association list of statistics about Guile's current use of storage. ")
679 #define FUNC_NAME s_scm_gc_stats
684 long int local_scm_mtrigger
;
685 long int local_scm_mallocated
;
686 long int local_scm_heap_size
;
687 long int local_scm_cells_allocated
;
688 long int local_scm_gc_time_taken
;
696 for (i
= scm_n_heap_segs
; i
--; )
697 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
698 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
700 if (scm_n_heap_segs
!= n
)
704 /* Below, we cons to produce the resulting list. We want a snapshot of
705 * the heap situation before consing.
707 local_scm_mtrigger
= scm_mtrigger
;
708 local_scm_mallocated
= scm_mallocated
;
709 local_scm_heap_size
= SCM_HEAP_SIZE
;
710 #ifdef GUILE_NEW_GC_SCHEME
711 local_scm_cells_allocated
= compute_cells_allocated ();
713 local_scm_cells_allocated
= scm_cells_allocated
;
715 local_scm_gc_time_taken
= scm_gc_time_taken
;
717 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
718 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
719 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
720 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
721 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
722 scm_cons (sym_heap_segments
, heap_segs
),
731 scm_gc_start (const char *what
)
733 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
734 scm_gc_cells_collected
= 0;
735 #ifdef GUILE_NEW_GC_SCHEME
736 scm_gc_yield
= (scm_cells_allocated
737 + master_cells_allocated (&scm_master_freelist
)
738 + master_cells_allocated (&scm_master_freelist2
));
740 scm_gc_malloc_collected
= 0;
741 scm_gc_ports_collected
= 0;
747 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
748 scm_gc_time_taken
+= scm_gc_rt
;
749 scm_system_async_mark (scm_gc_async
);
753 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
755 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
756 "returned by this function for @var{obj}")
757 #define FUNC_NAME s_scm_object_address
759 return scm_ulong2num ((unsigned long) obj
);
764 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
766 "Scans all of SCM objects and reclaims for further use those that are\n"
767 "no longer accessible.")
768 #define FUNC_NAME s_scm_gc
773 return SCM_UNSPECIFIED
;
779 /* {C Interface For When GC is Triggered}
782 #ifdef GUILE_NEW_GC_SCHEME
785 adjust_gc_trigger (scm_freelist_t
*freelist
)
787 /* GC trigger is adjusted upwards so that next predicted total yield
788 * (allocated cells actually freed by GC) becomes
789 * `gc_trigger_fraction' of total heap size. Note, however, that
790 * the absolute value of gc_trigger will correspond to `collected'
791 * on one master (the one which currently is triggering GC).
793 * The reason why we look at total yield instead of cells collected
794 * on one list is that we want to take other freelists into account.
795 * On this freelist, we know that (local) yield = collected cells,
796 * but that's probably not the case on the other lists.
798 * (We might consider computing a better prediction, for example
799 * by computing an average over multiple GC:s.)
801 if (freelist
->gc_trigger_fraction
)
803 int delta
= ((SCM_HEAP_SIZE
* freelist
->gc_trigger_fraction
/ 100)
806 fprintf (stderr
, " after GC = %d, delta = %d\n",
811 freelist
->gc_trigger
+= delta
;
815 /* When we get POSIX threads support, the master will be global and
816 * common while the freelist will be individual for each thread.
820 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
826 if (SCM_NULLP (master
->clusters
))
828 if (master
->grow_heap_p
)
830 master
->grow_heap_p
= 0;
831 alloc_some_heap (master
);
836 adjust_gc_trigger (master
);
839 cell
= SCM_CAR (master
->clusters
);
840 master
->clusters
= SCM_CDR (master
->clusters
);
841 ++master
->clusters_allocated
;
843 while (SCM_NULLP (cell
));
845 *freelist
= SCM_CDR (cell
);
846 SCM_SETCAR (cell
, scm_tc16_allocated
);
851 /* This is a support routine which can be used to reserve a cluster
852 * for some special use, such as debugging. It won't be useful until
853 * free cells are preserved between garbage collections.
857 scm_alloc_cluster (scm_freelist_t
*master
)
860 cell
= scm_gc_for_newcell (master
, &freelist
);
861 SCM_SETCDR (cell
, freelist
);
866 #else /* GUILE_NEW_GC_SCHEME */
869 scm_gc_for_alloc (scm_freelist_t
*freelist
)
873 #ifdef GUILE_DEBUG_FREELIST
874 fprintf (stderr
, "Collected: %d, min_yield: %d\n",
875 freelist
->collected
, MIN_GC_YIELD (freelist
));
877 if ((freelist
->collected
< MIN_GC_YIELD (freelist
))
878 || SCM_IMP (freelist
->cells
))
879 alloc_some_heap (freelist
);
885 scm_gc_for_newcell (scm_freelist_t
*freelist
)
888 scm_gc_for_alloc (freelist
);
889 fl
= freelist
->cells
;
890 freelist
->cells
= SCM_CDR (fl
);
891 SCM_SETCAR (fl
, scm_tc16_allocated
);
895 #endif /* GUILE_NEW_GC_SCHEME */
898 scm_igc (const char *what
)
904 SCM_NULLP (scm_freelist
)
906 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
909 /* During the critical section, only the current thread may run. */
910 SCM_THREAD_CRITICAL_SECTION_START
;
913 /* fprintf (stderr, "gc: %s\n", what); */
917 if (!scm_stack_base
|| scm_block_gc
)
923 if (scm_mallocated
< 0)
924 /* The byte count of allocated objects has underflowed. This is
925 probably because you forgot to report the sizes of objects you
926 have allocated, by calling scm_done_malloc or some such. When
927 the GC freed them, it subtracted their size from
928 scm_mallocated, which underflowed. */
931 if (scm_gc_heap_lock
)
932 /* We've invoked the collector while a GC is already in progress.
933 That should never happen. */
938 scm_weak_vectors
= SCM_EOL
;
940 scm_guardian_gc_init ();
942 /* unprotect any struct types with no instances */
948 pos
= &scm_type_obj_list
;
949 type_list
= scm_type_obj_list
;
950 while (type_list
!= SCM_EOL
)
951 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
953 pos
= SCM_CDRLOC (type_list
);
954 type_list
= SCM_CDR (type_list
);
958 *pos
= SCM_CDR (type_list
);
959 type_list
= SCM_CDR (type_list
);
964 /* flush dead entries from the continuation stack */
969 elts
= SCM_VELTS (scm_continuation_stack
);
970 bound
= SCM_LENGTH (scm_continuation_stack
);
971 x
= SCM_INUM (scm_continuation_stack_ptr
);
974 elts
[x
] = SCM_BOOL_F
;
981 /* Protect from the C stack. This must be the first marking
982 * done because it provides information about what objects
983 * are "in-use" by the C code. "in-use" objects are those
984 * for which the values from SCM_LENGTH and SCM_CHARS must remain
985 * usable. This requirement is stricter than a liveness
986 * requirement -- in particular, it constrains the implementation
987 * of scm_vector_set_length_x.
989 SCM_FLUSH_REGISTER_WINDOWS
;
990 /* This assumes that all registers are saved into the jmp_buf */
991 setjmp (scm_save_regs_gc_mark
);
992 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
993 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
994 sizeof scm_save_regs_gc_mark
)
995 / sizeof (SCM_STACKITEM
)));
998 /* stack_len is long rather than scm_sizet in order to guarantee that
999 &stack_len is long aligned */
1000 #ifdef SCM_STACK_GROWS_UP
1002 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
1004 long stack_len
= scm_stack_size (scm_stack_base
);
1006 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
1009 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
1011 long stack_len
= scm_stack_size (scm_stack_base
);
1013 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
1017 #else /* USE_THREADS */
1019 /* Mark every thread's stack and registers */
1020 scm_threads_mark_stacks ();
1022 #endif /* USE_THREADS */
1024 /* FIXME: insert a phase to un-protect string-data preserved
1025 * in scm_vector_set_length_x.
1028 j
= SCM_NUM_PROTECTS
;
1030 scm_gc_mark (scm_sys_protects
[j
]);
1032 /* FIXME: we should have a means to register C functions to be run
1033 * in different phases of GC
1035 scm_mark_subr_table ();
1038 scm_gc_mark (scm_root
->handle
);
1041 scm_mark_weak_vector_spines ();
1043 scm_guardian_zombify ();
1051 SCM_THREAD_CRITICAL_SECTION_END
;
1061 /* Mark an object precisely.
1076 if (SCM_NCELLP (ptr
))
1077 scm_wta (ptr
, "rogue pointer in heap", NULL
);
1079 switch (SCM_TYP7 (ptr
))
1081 case scm_tcs_cons_nimcar
:
1082 if (SCM_GCMARKP (ptr
))
1084 SCM_SETGCMARK (ptr
);
1085 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
1087 ptr
= SCM_CAR (ptr
);
1090 scm_gc_mark (SCM_CAR (ptr
));
1091 ptr
= SCM_GCCDR (ptr
);
1093 case scm_tcs_cons_imcar
:
1094 if (SCM_GCMARKP (ptr
))
1096 SCM_SETGCMARK (ptr
);
1097 ptr
= SCM_GCCDR (ptr
);
1100 if (SCM_GCMARKP (ptr
))
1102 SCM_SETGCMARK (ptr
);
1103 scm_gc_mark (SCM_CELL_WORD (ptr
, 2));
1104 ptr
= SCM_GCCDR (ptr
);
1106 case scm_tcs_cons_gloc
:
1107 if (SCM_GCMARKP (ptr
))
1109 SCM_SETGCMARK (ptr
);
1112 vcell
= SCM_CAR (ptr
) - 1L;
1113 switch (SCM_UNPACK (SCM_CDR (vcell
)))
1116 scm_gc_mark (vcell
);
1117 ptr
= SCM_GCCDR (ptr
);
1129 vtable_data
= (SCM
*)vcell
;
1130 layout
= vtable_data
[scm_vtable_index_layout
];
1131 len
= SCM_LENGTH (layout
);
1132 fields_desc
= SCM_CHARS (layout
);
1133 /* We're using SCM_GCCDR here like STRUCT_DATA, except
1134 that it removes the mark */
1135 mem
= (SCM
*)SCM_GCCDR (ptr
);
1137 if (SCM_UNPACK (vtable_data
[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
1139 scm_gc_mark (mem
[scm_struct_i_procedure
]);
1140 scm_gc_mark (mem
[scm_struct_i_setter
]);
1144 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
1145 if (fields_desc
[x
] == 'p')
1147 if (fields_desc
[x
] == 'p')
1150 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1151 for (j
= (long int) *mem
; x
; --x
)
1152 scm_gc_mark (*++mem
);
1157 if (!SCM_CDR (vcell
))
1159 SCM_SETGCMARK (vcell
);
1160 ptr
= vtable_data
[scm_vtable_index_vtable
];
1167 case scm_tcs_closures
:
1168 if (SCM_GCMARKP (ptr
))
1170 SCM_SETGCMARK (ptr
);
1171 if (SCM_IMP (SCM_CDR (ptr
)))
1173 ptr
= SCM_CLOSCAR (ptr
);
1176 scm_gc_mark (SCM_CLOSCAR (ptr
));
1177 ptr
= SCM_GCCDR (ptr
);
1179 case scm_tc7_vector
:
1180 case scm_tc7_lvector
:
1184 if (SCM_GC8MARKP (ptr
))
1186 SCM_SETGC8MARK (ptr
);
1187 i
= SCM_LENGTH (ptr
);
1191 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1192 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1193 ptr
= SCM_VELTS (ptr
)[0];
1195 case scm_tc7_contin
:
1198 SCM_SETGC8MARK (ptr
);
1199 if (SCM_VELTS (ptr
))
1200 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1203 (sizeof (SCM_STACKITEM
) + -1 +
1204 sizeof (scm_contregs
)) /
1205 sizeof (SCM_STACKITEM
)));
1209 case scm_tc7_byvect
:
1216 #ifdef HAVE_LONG_LONGS
1217 case scm_tc7_llvect
:
1220 case scm_tc7_string
:
1221 SCM_SETGC8MARK (ptr
);
1224 case scm_tc7_substring
:
1225 if (SCM_GC8MARKP(ptr
))
1227 SCM_SETGC8MARK (ptr
);
1228 ptr
= SCM_CDR (ptr
);
1232 if (SCM_GC8MARKP(ptr
))
1234 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1235 scm_weak_vectors
= ptr
;
1236 SCM_SETGC8MARK (ptr
);
1237 if (SCM_IS_WHVEC_ANY (ptr
))
1244 len
= SCM_LENGTH (ptr
);
1245 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1246 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1248 for (x
= 0; x
< len
; ++x
)
1251 alist
= SCM_VELTS (ptr
)[x
];
1253 /* mark everything on the alist except the keys or
1254 * values, according to weak_values and weak_keys. */
1255 while ( SCM_CONSP (alist
)
1256 && !SCM_GCMARKP (alist
)
1257 && SCM_CONSP (SCM_CAR (alist
)))
1262 kvpair
= SCM_CAR (alist
);
1263 next_alist
= SCM_CDR (alist
);
1266 * SCM_SETGCMARK (alist);
1267 * SCM_SETGCMARK (kvpair);
1269 * It may be that either the key or value is protected by
1270 * an escaped reference to part of the spine of this alist.
1271 * If we mark the spine here, and only mark one or neither of the
1272 * key and value, they may never be properly marked.
1273 * This leads to a horrible situation in which an alist containing
1274 * freelist cells is exported.
1276 * So only mark the spines of these arrays last of all marking.
1277 * If somebody confuses us by constructing a weak vector
1278 * with a circular alist then we are hosed, but at least we
1279 * won't prematurely drop table entries.
1282 scm_gc_mark (SCM_CAR (kvpair
));
1284 scm_gc_mark (SCM_GCCDR (kvpair
));
1287 if (SCM_NIMP (alist
))
1288 scm_gc_mark (alist
);
1293 case scm_tc7_msymbol
:
1294 if (SCM_GC8MARKP(ptr
))
1296 SCM_SETGC8MARK (ptr
);
1297 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1298 ptr
= SCM_SYMBOL_PROPS (ptr
);
1300 case scm_tc7_ssymbol
:
1301 if (SCM_GC8MARKP(ptr
))
1303 SCM_SETGC8MARK (ptr
);
1308 i
= SCM_PTOBNUM (ptr
);
1309 if (!(i
< scm_numptob
))
1311 if (SCM_GC8MARKP (ptr
))
1313 SCM_SETGC8MARK (ptr
);
1314 if (SCM_PTAB_ENTRY(ptr
))
1315 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1316 if (scm_ptobs
[i
].mark
)
1318 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1325 if (SCM_GC8MARKP (ptr
))
1327 SCM_SETGC8MARK (ptr
);
1328 switch (SCM_GCTYP16 (ptr
))
1329 { /* should be faster than going through scm_smobs */
1330 case scm_tc_free_cell
:
1331 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1332 case scm_tc16_allocated
:
1335 case scm_tc16_complex
:
1338 i
= SCM_SMOBNUM (ptr
);
1339 if (!(i
< scm_numsmob
))
1341 if (scm_smobs
[i
].mark
)
1343 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1351 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1356 /* Mark a Region Conservatively
1360 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1362 register long m
= n
;
1364 register SCM_CELLPTR ptr
;
1367 if (SCM_CELLP (*(SCM
**) (& x
[m
])))
1369 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
1371 j
= scm_n_heap_segs
- 1;
1372 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1373 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1380 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1382 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1390 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1394 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1399 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1403 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1409 if ( !scm_heap_table
[seg_id
].valid
1410 || scm_heap_table
[seg_id
].valid (ptr
,
1411 &scm_heap_table
[seg_id
]))
1412 if ( scm_heap_table
[seg_id
].span
== 1
1413 || SCM_DOUBLE_CELLP (*(SCM
**) (& x
[m
])))
1414 scm_gc_mark (*(SCM
*) & x
[m
]);
1423 /* The following is a C predicate which determines if an SCM value can be
1424 regarded as a pointer to a cell on the heap. The code is duplicated
1425 from scm_mark_locations. */
1429 scm_cellp (SCM value
)
1432 register SCM_CELLPTR ptr
;
1434 if SCM_CELLP (*(SCM
**) (& value
))
1436 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
1438 j
= scm_n_heap_segs
- 1;
1439 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1440 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1447 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1449 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1457 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1461 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1466 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1470 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1476 if ( !scm_heap_table
[seg_id
].valid
1477 || scm_heap_table
[seg_id
].valid (ptr
,
1478 &scm_heap_table
[seg_id
]))
1490 scm_mark_weak_vector_spines ()
1494 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1496 if (SCM_IS_WHVEC_ANY (w
))
1504 ptr
= SCM_VELTS (w
);
1506 for (j
= 0; j
< n
; ++j
)
1511 while ( SCM_CONSP (alist
)
1512 && !SCM_GCMARKP (alist
)
1513 && SCM_CONSP (SCM_CAR (alist
)))
1515 SCM_SETGCMARK (alist
);
1516 SCM_SETGCMARK (SCM_CAR (alist
));
1517 alist
= SCM_GCCDR (alist
);
1525 #ifdef GUILE_NEW_GC_SCHEME
1527 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1529 freelist
->cells
= SCM_EOL
;
1530 freelist
->left_to_collect
= freelist
->cluster_size
;
1531 freelist
->clusters_allocated
= 0;
1532 freelist
->clusters
= SCM_EOL
;
1533 freelist
->clustertail
= &freelist
->clusters
;
1534 freelist
->collected
= 0;
1538 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1540 *freelist
->clustertail
= freelist
->cells
;
1541 if (SCM_NNULLP (freelist
->cells
))
1543 SCM c
= freelist
->cells
;
1544 SCM_SETCAR (c
, SCM_CDR (c
));
1545 SCM_SETCDR (c
, SCM_EOL
);
1546 freelist
->collected
+=
1547 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1549 scm_gc_cells_collected
+= freelist
->collected
;
1551 freelist
->grow_heap_p
= (freelist
->collected
< freelist
->gc_trigger
);
1558 register SCM_CELLPTR ptr
;
1559 #ifdef SCM_POINTERS_MUNGED
1560 register SCM scmptr
;
1563 #define scmptr (SCM)ptr
1565 register SCM nfreelist
;
1566 register scm_freelist_t
*freelist
;
1574 #ifdef GUILE_NEW_GC_SCHEME
1575 gc_sweep_freelist_start (&scm_master_freelist
);
1576 gc_sweep_freelist_start (&scm_master_freelist2
);
1578 /* Reset all free list pointers. We'll reconstruct them completely
1580 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1581 scm_heap_table
[i
].freelist
->cells
= SCM_EOL
;
1584 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1586 #ifdef GUILE_NEW_GC_SCHEME
1587 register unsigned int left_to_collect
;
1589 register scm_sizet n
= 0;
1591 register scm_sizet j
;
1593 /* Unmarked cells go onto the front of the freelist this heap
1594 segment points to. Rather than updating the real freelist
1595 pointer as we go along, we accumulate the new head in
1596 nfreelist. Then, if it turns out that the entire segment is
1597 free, we free (i.e., malloc's free) the whole segment, and
1598 simply don't assign nfreelist back into the real freelist. */
1599 freelist
= scm_heap_table
[i
].freelist
;
1600 nfreelist
= freelist
->cells
;
1601 #ifdef GUILE_NEW_GC_SCHEME
1602 left_to_collect
= freelist
->left_to_collect
;
1604 span
= scm_heap_table
[i
].span
;
1606 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1607 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1608 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1610 #ifdef SCM_POINTERS_MUNGED
1611 scmptr
= PTR2SCM (ptr
);
1613 switch SCM_TYP7 (scmptr
)
1615 case scm_tcs_cons_gloc
:
1616 if (SCM_GCMARKP (scmptr
))
1618 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1619 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1624 vcell
= SCM_CAR (scmptr
) - 1L;
1626 if ((SCM_CDR (vcell
) == 0) || (SCM_UNPACK (SCM_CDR (vcell
)) == 1))
1628 scm_struct_free_t free
1629 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1630 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1634 case scm_tcs_cons_imcar
:
1635 case scm_tcs_cons_nimcar
:
1636 case scm_tcs_closures
:
1638 if (SCM_GCMARKP (scmptr
))
1642 if (SCM_GC8MARKP (scmptr
))
1648 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1649 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1653 case scm_tc7_vector
:
1654 case scm_tc7_lvector
:
1658 if (SCM_GC8MARKP (scmptr
))
1661 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1663 scm_must_free (SCM_CHARS (scmptr
));
1664 /* SCM_SETCHARS(scmptr, 0);*/
1668 if SCM_GC8MARKP (scmptr
)
1670 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1672 case scm_tc7_byvect
:
1673 if SCM_GC8MARKP (scmptr
)
1675 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1679 if SCM_GC8MARKP (scmptr
)
1681 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1684 if SCM_GC8MARKP (scmptr
)
1686 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1688 #ifdef HAVE_LONG_LONGS
1689 case scm_tc7_llvect
:
1690 if SCM_GC8MARKP (scmptr
)
1692 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1696 if SCM_GC8MARKP (scmptr
)
1698 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1701 if SCM_GC8MARKP (scmptr
)
1703 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1706 if SCM_GC8MARKP (scmptr
)
1708 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1711 case scm_tc7_substring
:
1712 if (SCM_GC8MARKP (scmptr
))
1715 case scm_tc7_string
:
1716 if (SCM_GC8MARKP (scmptr
))
1718 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1720 case scm_tc7_msymbol
:
1721 if (SCM_GC8MARKP (scmptr
))
1723 m
+= ( SCM_LENGTH (scmptr
)
1725 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1726 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1728 case scm_tc7_contin
:
1729 if SCM_GC8MARKP (scmptr
)
1731 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1732 if (SCM_VELTS (scmptr
))
1734 case scm_tc7_ssymbol
:
1735 if SCM_GC8MARKP(scmptr
)
1741 if SCM_GC8MARKP (scmptr
)
1743 if SCM_OPENP (scmptr
)
1745 int k
= SCM_PTOBNUM (scmptr
);
1746 if (!(k
< scm_numptob
))
1748 /* Keep "revealed" ports alive. */
1749 if (scm_revealed_count (scmptr
) > 0)
1751 /* Yes, I really do mean scm_ptobs[k].free */
1752 /* rather than ftobs[k].close. .close */
1753 /* is for explicit CLOSE-PORT by user */
1754 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1755 SCM_SETSTREAM (scmptr
, 0);
1756 scm_remove_from_port_table (scmptr
);
1757 scm_gc_ports_collected
++;
1758 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1762 switch SCM_GCTYP16 (scmptr
)
1764 case scm_tc_free_cell
:
1766 if SCM_GC8MARKP (scmptr
)
1771 if SCM_GC8MARKP (scmptr
)
1773 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1775 #endif /* def SCM_BIGDIG */
1776 case scm_tc16_complex
:
1777 if SCM_GC8MARKP (scmptr
)
1779 m
+= 2 * sizeof (double);
1782 if SCM_GC8MARKP (scmptr
)
1787 k
= SCM_SMOBNUM (scmptr
);
1788 if (!(k
< scm_numsmob
))
1790 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1796 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1799 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1802 #ifndef GUILE_NEW_GC_SCHEME
1805 if (!--left_to_collect
)
1807 SCM_SETCAR (scmptr
, nfreelist
);
1808 *freelist
->clustertail
= scmptr
;
1809 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1811 nfreelist
= SCM_EOL
;
1812 freelist
->collected
+= span
* freelist
->cluster_size
;
1813 left_to_collect
= freelist
->cluster_size
;
1818 /* Stick the new cell on the front of nfreelist. It's
1819 critical that we mark this cell as freed; otherwise, the
1820 conservative collector might trace it as some other type
1822 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
1823 SCM_SETCDR (scmptr
, nfreelist
);
1829 SCM_CLRGC8MARK (scmptr
);
1832 SCM_CLRGCMARK (scmptr
);
1834 #ifdef GC_FREE_SEGMENTS
1839 freelist
->heap_size
-= seg_size
;
1840 free ((char *) scm_heap_table
[i
].bounds
[0]);
1841 scm_heap_table
[i
].bounds
[0] = 0;
1842 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1843 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1844 scm_n_heap_segs
-= 1;
1845 i
--; /* We need to scan the segment just moved. */
1848 #endif /* ifdef GC_FREE_SEGMENTS */
1850 /* Update the real freelist pointer to point to the head of
1851 the list of free cells we've built for this segment. */
1852 freelist
->cells
= nfreelist
;
1853 #ifdef GUILE_NEW_GC_SCHEME
1854 freelist
->left_to_collect
= left_to_collect
;
1858 #ifndef GUILE_NEW_GC_SCHEME
1859 freelist
->collected
+= n
;
1862 #ifdef GUILE_DEBUG_FREELIST
1863 #ifdef GUILE_NEW_GC_SCHEME
1864 scm_check_freelist (freelist
== &scm_master_freelist
1868 scm_check_freelist (freelist
);
1870 scm_map_free_list ();
1874 #ifdef GUILE_NEW_GC_SCHEME
1875 gc_sweep_freelist_finish (&scm_master_freelist
);
1876 gc_sweep_freelist_finish (&scm_master_freelist2
);
1878 /* When we move to POSIX threads private freelists should probably
1879 be GC-protected instead. */
1880 scm_freelist
= SCM_EOL
;
1881 scm_freelist2
= SCM_EOL
;
1884 /* Scan weak vectors. */
1887 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1889 if (!SCM_IS_WHVEC_ANY (w
))
1893 ptr
= SCM_VELTS (w
);
1895 for (j
= 0; j
< n
; ++j
)
1896 if (SCM_FREEP (ptr
[j
]))
1897 ptr
[j
] = SCM_BOOL_F
;
1899 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1902 register long n
= SCM_LENGTH (w
);
1905 ptr
= SCM_VELTS (w
);
1907 for (j
= 0; j
< n
; ++j
)
1914 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1915 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1920 while ( SCM_CONSP (alist
)
1921 && SCM_CONSP (SCM_CAR (alist
)))
1926 key
= SCM_CAAR (alist
);
1927 value
= SCM_CDAR (alist
);
1928 if ( (weak_keys
&& SCM_FREEP (key
))
1929 || (weak_values
&& SCM_FREEP (value
)))
1931 *fixup
= SCM_CDR (alist
);
1934 fixup
= SCM_CDRLOC (alist
);
1935 alist
= SCM_CDR (alist
);
1941 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1942 #ifdef GUILE_NEW_GC_SCHEME
1943 scm_gc_yield
-= scm_cells_allocated
;
1945 scm_mallocated
-= m
;
1946 scm_gc_malloc_collected
= m
;
1952 /* {Front end to malloc}
1954 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1956 * These functions provide services comperable to malloc, realloc, and
1957 * free. They are for allocating malloced parts of scheme objects.
1958 * The primary purpose of the front end is to impose calls to gc.
1962 * Return newly malloced storage or throw an error.
1964 * The parameter WHAT is a string for error reporting.
1965 * If the threshold scm_mtrigger will be passed by this
1966 * allocation, or if the first call to malloc fails,
1967 * garbage collect -- on the presumption that some objects
1968 * using malloced storage may be collected.
1970 * The limit scm_mtrigger may be raised by this allocation.
1973 scm_must_malloc (scm_sizet size
, const char *what
)
1976 unsigned long nm
= scm_mallocated
+ size
;
1978 if (nm
<= scm_mtrigger
)
1980 SCM_SYSCALL (ptr
= malloc (size
));
1983 scm_mallocated
= nm
;
1990 nm
= scm_mallocated
+ size
;
1991 SCM_SYSCALL (ptr
= malloc (size
));
1994 scm_mallocated
= nm
;
1995 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1996 if (nm
> scm_mtrigger
)
1997 scm_mtrigger
= nm
+ nm
/ 2;
1999 scm_mtrigger
+= scm_mtrigger
/ 2;
2004 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
2005 return 0; /* never reached */
2010 * is similar to scm_must_malloc.
2013 scm_must_realloc (void *where
,
2019 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
2021 if (nm
<= scm_mtrigger
)
2023 SCM_SYSCALL (ptr
= realloc (where
, size
));
2026 scm_mallocated
= nm
;
2033 nm
= scm_mallocated
+ size
- old_size
;
2034 SCM_SYSCALL (ptr
= realloc (where
, size
));
2037 scm_mallocated
= nm
;
2038 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2039 if (nm
> scm_mtrigger
)
2040 scm_mtrigger
= nm
+ nm
/ 2;
2042 scm_mtrigger
+= scm_mtrigger
/ 2;
2047 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
2048 return 0; /* never reached */
2052 scm_must_free (void *obj
)
2057 scm_wta (SCM_INUM0
, "already free", "");
2060 /* Announce that there has been some malloc done that will be freed
2061 * during gc. A typical use is for a smob that uses some malloced
2062 * memory but can not get it from scm_must_malloc (for whatever
2063 * reason). When a new object of this smob is created you call
2064 * scm_done_malloc with the size of the object. When your smob free
2065 * function is called, be sure to include this size in the return
2069 scm_done_malloc (long size
)
2071 scm_mallocated
+= size
;
2073 if (scm_mallocated
> scm_mtrigger
)
2075 scm_igc ("foreign mallocs");
2076 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
2078 if (scm_mallocated
> scm_mtrigger
)
2079 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
2081 scm_mtrigger
+= scm_mtrigger
/ 2;
2091 * Each heap segment is an array of objects of a particular size.
2092 * Every segment has an associated (possibly shared) freelist.
2093 * A table of segment records is kept that records the upper and
2094 * lower extents of the segment; this is used during the conservative
2095 * phase of gc to identify probably gc roots (because they point
2096 * into valid segments at reasonable offsets). */
2099 * is true if the first segment was smaller than INIT_HEAP_SEG.
2100 * If scm_expmem is set to one, subsequent segment allocations will
2101 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
2105 scm_sizet scm_max_segment_size
;
2108 * is the lowest base address of any heap segment.
2110 SCM_CELLPTR scm_heap_org
;
2112 scm_heap_seg_data_t
* scm_heap_table
= 0;
2113 int scm_n_heap_segs
= 0;
2116 * initializes a new heap segment and return the number of objects it contains.
2118 * The segment origin, segment size in bytes, and the span of objects
2119 * in cells are input parameters. The freelist is both input and output.
2121 * This function presume that the scm_heap_table has already been expanded
2122 * to accomodate a new segment record.
2127 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
2129 register SCM_CELLPTR ptr
;
2130 #ifdef SCM_POINTERS_MUNGED
2131 register SCM scmptr
;
2136 SCM_CELLPTR seg_end
;
2139 int span
= freelist
->span
;
2141 if (seg_org
== NULL
)
2144 ptr
= CELL_UP (seg_org
, span
);
2146 /* Compute the ceiling on valid object pointers w/in this segment.
2148 seg_end
= CELL_DN ((char *) seg_org
+ size
, span
);
2150 /* Find the right place and insert the segment record.
2153 for (new_seg_index
= 0;
2154 ( (new_seg_index
< scm_n_heap_segs
)
2155 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2161 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2162 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2167 scm_heap_table
[new_seg_index
].valid
= 0;
2168 scm_heap_table
[new_seg_index
].span
= span
;
2169 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2170 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
2171 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
2174 /* Compute the least valid object pointer w/in this segment
2176 ptr
= CELL_UP (ptr
, span
);
2180 n_new_cells
= seg_end
- ptr
;
2182 #ifdef GUILE_NEW_GC_SCHEME
2184 freelist
->heap_size
+= n_new_cells
;
2186 /* Partition objects in this segment into clusters */
2189 SCM
*clusterp
= &clusters
;
2190 int n_cluster_cells
= span
* freelist
->cluster_size
;
2192 while (n_new_cells
> span
) /* at least one spine + one freecell */
2194 /* Determine end of cluster
2196 if (n_new_cells
>= n_cluster_cells
)
2198 seg_end
= ptr
+ n_cluster_cells
;
2199 n_new_cells
-= n_cluster_cells
;
2202 /* [cmm] looks like the segment size doesn't divide cleanly by
2203 cluster size. bad cmm! */
2206 /* Allocate cluster spine
2208 *clusterp
= PTR2SCM (ptr
);
2209 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
2210 clusterp
= SCM_CDRLOC (*clusterp
);
2213 while (ptr
< seg_end
)
2215 #ifdef SCM_POINTERS_MUNGED
2216 scmptr
= PTR2SCM (ptr
);
2218 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
2219 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2223 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
2226 /* Patch up the last cluster pointer in the segment
2227 * to join it to the input freelist.
2229 *clusterp
= freelist
->clusters
;
2230 freelist
->clusters
= clusters
;
2233 #else /* GUILE_NEW_GC_SCHEME */
2235 /* Prepend objects in this segment to the freelist.
2237 while (ptr
< seg_end
)
2239 #ifdef SCM_POINTERS_MUNGED
2240 scmptr
= PTR2SCM (ptr
);
2242 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
2243 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2249 /* Patch up the last freelist pointer in the segment
2250 * to join it to the input freelist.
2252 SCM_SETCDR (PTR2SCM (ptr
), freelist
->cells
);
2253 freelist
->cells
= PTR2SCM (CELL_UP (seg_org
, span
));
2255 freelist
->heap_size
+= n_new_cells
;
2257 #endif /* GUILE_NEW_GC_SCHEME */
2260 fprintf (stderr
, "H");
2268 #ifndef GUILE_NEW_GC_SCHEME
2269 #define round_to_cluster_size(freelist, len) len
2273 round_to_cluster_size (scm_freelist_t
*freelist
, scm_sizet len
)
2275 scm_sizet cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2278 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2279 + ALIGNMENT_SLACK (freelist
);
2285 alloc_some_heap (scm_freelist_t
*freelist
)
2287 scm_heap_seg_data_t
* tmptable
;
2291 /* Critical code sections (such as the garbage collector)
2292 * aren't supposed to add heap segments.
2294 if (scm_gc_heap_lock
)
2295 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
2297 /* Expand the heap tables to have room for the new segment.
2298 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
2299 * only if the allocation of the segment itself succeeds.
2301 len
= (1 + scm_n_heap_segs
) * sizeof (scm_heap_seg_data_t
);
2303 SCM_SYSCALL (tmptable
= ((scm_heap_seg_data_t
*)
2304 realloc ((char *)scm_heap_table
, len
)));
2306 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
2308 scm_heap_table
= tmptable
;
2311 /* Pick a size for the new heap segment.
2312 * The rule for picking the size of a segment is explained in
2315 #ifdef GUILE_NEW_GC_SCHEME
2317 /* Assure that the new segment is predicted to be large enough for
2320 int slack
= freelist
->gc_trigger
- freelist
->collected
;
2321 int min_cells
= 100 * slack
/ (99 - freelist
->gc_trigger_fraction
);
2322 len
= SCM_EXPHEAP (freelist
->heap_size
);
2324 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2326 if (len
< min_cells
)
2327 len
= min_cells
+ 1;
2328 len
*= sizeof (scm_cell
);
2331 if (len
> scm_max_segment_size
)
2332 len
= scm_max_segment_size
;
2336 len
= (scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
));
2337 if ((scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
))
2342 len
= SCM_HEAP_SEG_SIZE
;
2343 #endif /* GUILE_NEW_GC_SCHEME */
2348 #ifndef GUILE_NEW_GC_SCHEME
2349 smallest
= (freelist
->span
* sizeof (scm_cell
));
2351 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2357 /* Allocate with decaying ambition. */
2358 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2359 && (len
>= smallest
))
2361 scm_sizet rounded_len
= round_to_cluster_size(freelist
, len
);
2362 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2365 init_heap_seg (ptr
, rounded_len
, freelist
);
2372 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2377 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2380 #define FUNC_NAME s_scm_unhash_name
2384 SCM_VALIDATE_SYMBOL (1,name
);
2386 bound
= scm_n_heap_segs
;
2387 for (x
= 0; x
< bound
; ++x
)
2391 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
2392 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
2397 if (1 == (7 & (int)incar
))
2400 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
2401 && (SCM_CDR (incar
) != 0)
2402 && (SCM_UNPACK (SCM_CDR (incar
)) != 1))
2417 /* {GC Protection Helper Functions}
2422 scm_remember (SCM
*ptr
)
2427 These crazy functions prevent garbage collection
2428 of arguments after the first argument by
2429 ensuring they remain live throughout the
2430 function because they are used in the last
2431 line of the code block.
2432 It'd be better to have a nice compiler hint to
2433 aid the conservative stack-scanning GC. --03/09/00 gjb */
2435 scm_return_first (SCM elt
, ...)
2441 scm_return_first_int (int i
, ...)
2448 scm_permanent_object (SCM obj
)
2451 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2457 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2458 even if all other references are dropped, until someone applies
2459 scm_unprotect_object to it. This function returns OBJ.
2461 Calls to scm_protect_object nest. For every object OBJ, there is a
2462 counter which scm_protect_object(OBJ) increments and
2463 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2464 an object's counter is greater than zero, the garbage collector
2467 Of course, that's not how it's implemented. scm_protect_object and
2468 scm_unprotect_object just maintain a list of references to things.
2469 Since the GC knows about this list, all objects it mentions stay
2470 alive. scm_protect_object adds its argument to the list;
2471 scm_unprotect_object removes the first occurrence of its argument
2474 scm_protect_object (SCM obj
)
2476 scm_protects
= scm_cons (obj
, scm_protects
);
2482 /* Remove any protection for OBJ established by a prior call to
2483 scm_protect_object. This function returns OBJ.
2485 See scm_protect_object for more information. */
2487 scm_unprotect_object (SCM obj
)
2489 SCM
*tail_ptr
= &scm_protects
;
2491 while (SCM_CONSP (*tail_ptr
))
2492 if (SCM_CAR (*tail_ptr
) == obj
)
2494 *tail_ptr
= SCM_CDR (*tail_ptr
);
2498 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
2505 /* called on process termination. */
2511 extern int on_exit (void (*procp
) (), int arg
);
2514 cleanup (int status
, void *arg
)
2516 #error Dont know how to setup a cleanup handler on your system.
2521 scm_flush_all_ports ();
2526 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2528 scm_sizet rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2529 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2533 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2534 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2542 #ifdef GUILE_NEW_GC_SCHEME
2543 if (freelist
->gc_trigger_fraction
)
2544 freelist
->gc_trigger
= (freelist
->heap_size
* freelist
->gc_trigger_fraction
2546 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->gc_trigger
);
2553 #ifdef GUILE_NEW_GC_SCHEME
2555 init_freelist (scm_freelist_t
*freelist
,
2560 freelist
->clusters
= SCM_EOL
;
2561 freelist
->cluster_size
= cluster_size
+ 1;
2562 freelist
->left_to_collect
= 0;
2563 freelist
->clusters_allocated
= 0;
2565 freelist
->gc_trigger_fraction
= - gc_trigger
;
2568 freelist
->gc_trigger
= gc_trigger
;
2569 freelist
->gc_trigger_fraction
= 0;
2571 freelist
->span
= span
;
2572 freelist
->collected
= 0;
2573 freelist
->heap_size
= 0;
2577 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2578 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2579 scm_sizet max_segment_size
)
2582 scm_init_storage (scm_sizet init_heap_size_1
, scm_sizet init_heap_size_2
)
2587 if (!init_heap_size_1
)
2588 init_heap_size_1
= SCM_INIT_HEAP_SIZE_1
;
2589 if (!init_heap_size_2
)
2590 init_heap_size_2
= SCM_INIT_HEAP_SIZE_2
;
2592 j
= SCM_NUM_PROTECTS
;
2594 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2597 #ifdef GUILE_NEW_GC_SCHEME
2598 scm_freelist
= SCM_EOL
;
2599 scm_freelist2
= SCM_EOL
;
2600 init_freelist (&scm_master_freelist
,
2601 1, SCM_CLUSTER_SIZE_1
,
2602 gc_trigger_1
? gc_trigger_1
: SCM_GC_TRIGGER_1
);
2603 init_freelist (&scm_master_freelist2
,
2604 2, SCM_CLUSTER_SIZE_2
,
2605 gc_trigger_2
? gc_trigger_2
: SCM_GC_TRIGGER_2
);
2606 scm_max_segment_size
2607 = max_segment_size
? max_segment_size
: SCM_MAX_SEGMENT_SIZE
;
2609 scm_freelist
.cells
= SCM_EOL
;
2610 scm_freelist
.span
= 1;
2611 scm_freelist
.collected
= 0;
2612 scm_freelist
.heap_size
= 0;
2614 scm_freelist2
.cells
= SCM_EOL
;
2615 scm_freelist2
.span
= 2;
2616 scm_freelist2
.collected
= 0;
2617 scm_freelist2
.heap_size
= 0;
2622 j
= SCM_HEAP_SEG_SIZE
;
2623 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2624 scm_heap_table
= ((scm_heap_seg_data_t
*)
2625 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2627 #ifdef GUILE_NEW_GC_SCHEME
2628 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2629 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2632 if (make_initial_segment (init_heap_size_1
, &scm_freelist
) ||
2633 make_initial_segment (init_heap_size_2
, &scm_freelist2
))
2637 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2639 /* scm_hplims[0] can change. do not remove scm_heap_org */
2640 scm_weak_vectors
= SCM_EOL
;
2642 /* Initialise the list of ports. */
2643 scm_port_table
= (scm_port
**)
2644 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2645 if (!scm_port_table
)
2652 on_exit (cleanup
, 0);
2656 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2657 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2659 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2660 scm_nullstr
= scm_makstr (0L, 0);
2661 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2662 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2663 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
2664 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2665 scm_stand_in_procs
= SCM_EOL
;
2666 scm_permobjs
= SCM_EOL
;
2667 scm_protects
= SCM_EOL
;
2668 scm_asyncs
= SCM_EOL
;
2669 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2670 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2672 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));