1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999 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. */
49 #include "guardians.h"
66 #define var_start(x, y) va_start(x, y)
69 #define var_start(x, y) va_start(x)
73 /* {heap tuning parameters}
75 * These are parameters for controlling memory allocation. The heap
76 * is the area out of which scm_cons, and object headers are allocated.
78 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
79 * 64 bit machine. The units of the _SIZE parameters are bytes.
80 * Cons pairs and object headers occupy one heap cell.
82 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
83 * allocated initially the heap will grow by half its current size
84 * each subsequent time more heap is needed.
86 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
87 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
88 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
89 * is in scm_init_storage() and alloc_some_heap() in sys.c
91 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
92 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
94 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
97 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
100 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
101 * reclaimed by a GC triggered by must_malloc. If less than this is
102 * reclaimed, the trigger threshold is raised. [I don't know what a
103 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
104 * work around a oscillation that caused almost constant GC.]
107 #define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
108 #define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
110 # define SCM_HEAP_SEG_SIZE 32768L
113 # define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
115 # define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
118 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
119 #define SCM_INIT_MALLOC_LIMIT 100000
120 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
122 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
123 bounds for allocated storage */
126 /*in 386 protected mode we must only adjust the offset */
127 # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
128 # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
131 # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
132 # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
134 # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
135 # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
142 * is the head of freelist of cons pairs.
144 SCM scm_freelist
= SCM_EOL
;
147 * is the number of bytes of must_malloc allocation needed to trigger gc.
149 unsigned long scm_mtrigger
;
153 * If set, don't expand the heap. Set only during gc, during which no allocation
154 * is supposed to take place anyway.
156 int scm_gc_heap_lock
= 0;
159 * Don't pause for collection if this is set -- just
163 int scm_block_gc
= 1;
165 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
166 * collection (GC) more space is allocated for the heap.
168 #define MIN_GC_YIELD (scm_heap_size/4)
170 /* During collection, this accumulates objects holding
173 SCM scm_weak_vectors
;
175 /* GC Statistics Keeping
177 unsigned long scm_cells_allocated
= 0;
178 long scm_mallocated
= 0;
179 unsigned long scm_gc_cells_collected
;
180 unsigned long scm_gc_malloc_collected
;
181 unsigned long scm_gc_ports_collected
;
182 unsigned long scm_gc_rt
;
183 unsigned long scm_gc_time_taken
= 0;
185 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
186 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
187 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
188 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
189 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
190 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
193 struct scm_heap_seg_data
195 /* lower and upper bounds of the segment */
196 SCM_CELLPTR bounds
[2];
198 /* address of the head-of-freelist pointer for this segment's cells.
199 All segments usually point to the same one, scm_freelist. */
202 /* number of SCM words per object in this segment */
205 /* If SEG_DATA->valid is non-zero, the conservative marking
206 functions will apply SEG_DATA->valid to the purported pointer and
207 SEG_DATA, and mark the object iff the function returns non-zero.
208 At the moment, I don't think anyone uses this. */
215 static void scm_mark_weak_vector_spines
SCM_P ((void));
216 static scm_sizet init_heap_seg
SCM_P ((SCM_CELLPTR
, scm_sizet
, int, SCM
*));
217 static void alloc_some_heap
SCM_P ((int, SCM
*));
221 /* Debugging functions. */
223 #ifdef DEBUG_FREELIST
225 /* Return the number of the heap segment containing CELL. */
231 for (i
= 0; i
< scm_n_heap_segs
; i
++)
232 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
233 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
235 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
241 SCM_PROC (s_map_free_list
, "map-free-list", 0, 0, 0, scm_map_free_list
);
245 int last_seg
= -1, count
= 0;
248 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
249 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
251 int this_seg
= which_seg (f
);
253 if (this_seg
!= last_seg
)
256 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
263 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
267 return SCM_UNSPECIFIED
;
271 /* Number of calls to SCM_NEWCELL since startup. */
272 static unsigned long scm_newcell_count
;
274 /* Search freelist for anything that isn't marked as a free cell.
275 Abort if we find something. */
277 scm_check_freelist ()
282 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
283 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
285 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
286 scm_newcell_count
, i
);
292 static int scm_debug_check_freelist
= 0;
294 scm_debug_newcell (void)
299 if (scm_debug_check_freelist
)
300 scm_check_freelist ();
302 /* The rest of this is supposed to be identical to the SCM_NEWCELL
304 if (SCM_IMP (scm_freelist
))
305 new = scm_gc_for_newcell ();
309 scm_freelist
= SCM_CDR (scm_freelist
);
310 ++scm_cells_allocated
;
316 #endif /* DEBUG_FREELIST */
320 /* {Scheme Interface to GC}
323 SCM_PROC (s_gc_stats
, "gc-stats", 0, 0, 0, scm_gc_stats
);
330 SCM local_scm_mtrigger
;
331 SCM local_scm_mallocated
;
332 SCM local_scm_heap_size
;
333 SCM local_scm_cells_allocated
;
334 SCM local_scm_gc_time_taken
;
342 for (i
= scm_n_heap_segs
; i
--; )
343 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
344 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
346 if (scm_n_heap_segs
!= n
)
350 local_scm_mtrigger
= scm_mtrigger
;
351 local_scm_mallocated
= scm_mallocated
;
352 local_scm_heap_size
= scm_heap_size
;
353 local_scm_cells_allocated
= scm_cells_allocated
;
354 local_scm_gc_time_taken
= scm_gc_time_taken
;
356 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
357 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
358 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
359 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
360 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
361 scm_cons (sym_heap_segments
, heap_segs
),
372 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
373 scm_gc_cells_collected
= 0;
374 scm_gc_malloc_collected
= 0;
375 scm_gc_ports_collected
= 0;
381 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
382 scm_gc_time_taken
= scm_gc_time_taken
+ scm_gc_rt
;
383 scm_system_async_mark (scm_gc_async
);
387 SCM_PROC (s_object_address
, "object-address", 1, 0, 0, scm_object_address
);
389 scm_object_address (obj
)
392 return scm_ulong2num ((unsigned long)obj
);
396 SCM_PROC(s_gc
, "gc", 0, 0, 0, scm_gc
);
403 return SCM_UNSPECIFIED
;
408 /* {C Interface For When GC is Triggered}
412 scm_gc_for_alloc (ncells
, freelistp
)
418 if ((scm_gc_cells_collected
< MIN_GC_YIELD
) || SCM_IMP (*freelistp
))
420 alloc_some_heap (ncells
, freelistp
);
427 scm_gc_for_newcell ()
430 scm_gc_for_alloc (1, &scm_freelist
);
432 scm_freelist
= SCM_CDR (fl
);
443 /* During the critical section, only the current thread may run. */
444 SCM_THREAD_CRITICAL_SECTION_START
;
447 /* fprintf (stderr, "gc: %s\n", what); */
451 if (!scm_stack_base
|| scm_block_gc
)
457 if (scm_mallocated
< 0)
458 /* The byte count of allocated objects has underflowed. This is
459 probably because you forgot to report the sizes of objects you
460 have allocated, by calling scm_done_malloc or some such. When
461 the GC freed them, it subtracted their size from
462 scm_mallocated, which underflowed. */
465 if (scm_gc_heap_lock
)
466 /* We've invoked the collector while a GC is already in progress.
467 That should never happen. */
472 scm_weak_vectors
= SCM_EOL
;
474 scm_guardian_gc_init ();
476 /* unprotect any struct types with no instances */
482 pos
= &scm_type_obj_list
;
483 type_list
= scm_type_obj_list
;
484 while (type_list
!= SCM_EOL
)
485 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
487 pos
= SCM_CDRLOC (type_list
);
488 type_list
= SCM_CDR (type_list
);
492 *pos
= SCM_CDR (type_list
);
493 type_list
= SCM_CDR (type_list
);
498 /* flush dead entries from the continuation stack */
503 elts
= SCM_VELTS (scm_continuation_stack
);
504 bound
= SCM_LENGTH (scm_continuation_stack
);
505 x
= SCM_INUM (scm_continuation_stack_ptr
);
508 elts
[x
] = SCM_BOOL_F
;
515 /* Protect from the C stack. This must be the first marking
516 * done because it provides information about what objects
517 * are "in-use" by the C code. "in-use" objects are those
518 * for which the values from SCM_LENGTH and SCM_CHARS must remain
519 * usable. This requirement is stricter than a liveness
520 * requirement -- in particular, it constrains the implementation
521 * of scm_vector_set_length_x.
523 SCM_FLUSH_REGISTER_WINDOWS
;
524 /* This assumes that all registers are saved into the jmp_buf */
525 setjmp (scm_save_regs_gc_mark
);
526 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
527 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
528 sizeof scm_save_regs_gc_mark
)
529 / sizeof (SCM_STACKITEM
)));
532 /* stack_len is long rather than scm_sizet in order to guarantee that
533 &stack_len is long aligned */
534 #ifdef SCM_STACK_GROWS_UP
536 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
538 long stack_len
= scm_stack_size (scm_stack_base
);
540 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
543 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
545 long stack_len
= scm_stack_size (scm_stack_base
);
547 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
551 #else /* USE_THREADS */
553 /* Mark every thread's stack and registers */
554 scm_threads_mark_stacks();
556 #endif /* USE_THREADS */
558 /* FIXME: insert a phase to un-protect string-data preserved
559 * in scm_vector_set_length_x.
562 j
= SCM_NUM_PROTECTS
;
564 scm_gc_mark (scm_sys_protects
[j
]);
566 /* FIXME: we should have a means to register C functions to be run
567 * in different phases of GC
569 scm_mark_subr_table ();
572 scm_gc_mark (scm_root
->handle
);
575 scm_mark_weak_vector_spines ();
577 scm_guardian_zombify ();
585 SCM_THREAD_CRITICAL_SECTION_END
;
595 /* Mark an object precisely.
611 if (SCM_NCELLP (ptr
))
612 scm_wta (ptr
, "rogue pointer in heap", NULL
);
614 switch (SCM_TYP7 (ptr
))
616 case scm_tcs_cons_nimcar
:
617 if (SCM_GCMARKP (ptr
))
620 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
625 scm_gc_mark (SCM_CAR (ptr
));
626 ptr
= SCM_GCCDR (ptr
);
628 case scm_tcs_cons_imcar
:
630 if (SCM_GCMARKP (ptr
))
633 ptr
= SCM_GCCDR (ptr
);
635 case scm_tcs_cons_gloc
:
636 if (SCM_GCMARKP (ptr
))
641 vcell
= SCM_CAR (ptr
) - 1L;
642 switch (SCM_CDR (vcell
))
646 ptr
= SCM_GCCDR (ptr
);
658 vtable_data
= (SCM
*)vcell
;
659 layout
= vtable_data
[scm_vtable_index_layout
];
660 len
= SCM_LENGTH (layout
);
661 fields_desc
= SCM_CHARS (layout
);
662 /* We're using SCM_GCCDR here like STRUCT_DATA, except
663 that it removes the mark */
664 mem
= (SCM
*)SCM_GCCDR (ptr
);
666 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
668 scm_gc_mark (mem
[scm_struct_i_procedure
]);
669 scm_gc_mark (mem
[scm_struct_i_setter
]);
673 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
674 if (fields_desc
[x
] == 'p')
676 if (fields_desc
[x
] == 'p')
678 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
679 for (x
= *mem
; x
; --x
)
680 scm_gc_mark (*++mem
);
685 if (!SCM_CDR (vcell
))
687 SCM_SETGCMARK (vcell
);
688 ptr
= vtable_data
[scm_vtable_index_vtable
];
695 case scm_tcs_closures
:
696 if (SCM_GCMARKP (ptr
))
699 if (SCM_IMP (SCM_CDR (ptr
)))
701 ptr
= SCM_CLOSCAR (ptr
);
704 scm_gc_mark (SCM_CLOSCAR (ptr
));
705 ptr
= SCM_GCCDR (ptr
);
708 case scm_tc7_lvector
:
712 if (SCM_GC8MARKP (ptr
))
714 SCM_SETGC8MARK (ptr
);
715 i
= SCM_LENGTH (ptr
);
719 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
720 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
721 ptr
= SCM_VELTS (ptr
)[0];
726 SCM_SETGC8MARK (ptr
);
728 scm_mark_locations (SCM_VELTS (ptr
),
731 (sizeof (SCM_STACKITEM
) + -1 +
732 sizeof (scm_contregs
)) /
733 sizeof (SCM_STACKITEM
)));
748 SCM_SETGC8MARK (ptr
);
751 case scm_tc7_substring
:
752 if (SCM_GC8MARKP(ptr
))
754 SCM_SETGC8MARK (ptr
);
759 if (SCM_GC8MARKP(ptr
))
761 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
762 scm_weak_vectors
= ptr
;
763 SCM_SETGC8MARK (ptr
);
764 if (SCM_IS_WHVEC_ANY (ptr
))
771 len
= SCM_LENGTH (ptr
);
772 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
773 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
775 for (x
= 0; x
< len
; ++x
)
778 alist
= SCM_VELTS (ptr
)[x
];
780 /* mark everything on the alist except the keys or
781 * values, according to weak_values and weak_keys. */
782 while ( SCM_NIMP (alist
)
784 && !SCM_GCMARKP (alist
)
785 && SCM_NIMP (SCM_CAR (alist
))
786 && SCM_CONSP (SCM_CAR (alist
)))
791 kvpair
= SCM_CAR (alist
);
792 next_alist
= SCM_CDR (alist
);
795 * SCM_SETGCMARK (alist);
796 * SCM_SETGCMARK (kvpair);
798 * It may be that either the key or value is protected by
799 * an escaped reference to part of the spine of this alist.
800 * If we mark the spine here, and only mark one or neither of the
801 * key and value, they may never be properly marked.
802 * This leads to a horrible situation in which an alist containing
803 * freelist cells is exported.
805 * So only mark the spines of these arrays last of all marking.
806 * If somebody confuses us by constructing a weak vector
807 * with a circular alist then we are hosed, but at least we
808 * won't prematurely drop table entries.
811 scm_gc_mark (SCM_CAR (kvpair
));
813 scm_gc_mark (SCM_GCCDR (kvpair
));
816 if (SCM_NIMP (alist
))
822 case scm_tc7_msymbol
:
823 if (SCM_GC8MARKP(ptr
))
825 SCM_SETGC8MARK (ptr
);
826 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
827 ptr
= SCM_SYMBOL_PROPS (ptr
);
829 case scm_tc7_ssymbol
:
830 if (SCM_GC8MARKP(ptr
))
832 SCM_SETGC8MARK (ptr
);
837 i
= SCM_PTOBNUM (ptr
);
838 if (!(i
< scm_numptob
))
840 if (SCM_GC8MARKP (ptr
))
842 SCM_SETGC8MARK (ptr
);
843 if (SCM_PTAB_ENTRY(ptr
))
844 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
845 if (scm_ptobs
[i
].mark
)
847 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
854 if (SCM_GC8MARKP (ptr
))
856 SCM_SETGC8MARK (ptr
);
857 switch SCM_GCTYP16 (ptr
)
858 { /* should be faster than going through scm_smobs */
859 case scm_tc_free_cell
:
860 /* printf("found free_cell %X ", ptr); fflush(stdout); */
861 SCM_SETCDR (ptr
, SCM_EOL
);
863 case scm_tcs_bignums
:
867 i
= SCM_SMOBNUM (ptr
);
868 if (!(i
< scm_numsmob
))
870 if (scm_smobs
[i
].mark
)
872 ptr
= (scm_smobs
[i
].mark
) (ptr
);
880 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
885 /* Mark a Region Conservatively
889 scm_mark_locations (x
, n
)
895 register SCM_CELLPTR ptr
;
898 if SCM_CELLP (*(SCM
**) & x
[m
])
900 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
902 j
= scm_n_heap_segs
- 1;
903 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
904 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
911 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
913 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
921 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
925 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
930 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
934 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
940 if ( !scm_heap_table
[seg_id
].valid
941 || scm_heap_table
[seg_id
].valid (ptr
,
942 &scm_heap_table
[seg_id
]))
943 scm_gc_mark (*(SCM
*) & x
[m
]);
952 /* The following is a C predicate which determines if an SCM value can be
953 regarded as a pointer to a cell on the heap. The code is duplicated
954 from scm_mark_locations. */
962 register SCM_CELLPTR ptr
;
964 if SCM_CELLP (*(SCM
**) & value
)
966 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
968 j
= scm_n_heap_segs
- 1;
969 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
970 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
977 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
979 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
987 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
991 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
996 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1000 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1006 if ( !scm_heap_table
[seg_id
].valid
1007 || scm_heap_table
[seg_id
].valid (ptr
,
1008 &scm_heap_table
[seg_id
]))
1020 scm_mark_weak_vector_spines ()
1024 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1026 if (SCM_IS_WHVEC_ANY (w
))
1034 ptr
= SCM_VELTS (w
);
1036 for (j
= 0; j
< n
; ++j
)
1041 while ( SCM_NIMP (alist
)
1042 && SCM_CONSP (alist
)
1043 && !SCM_GCMARKP (alist
)
1044 && SCM_NIMP (SCM_CAR (alist
))
1045 && SCM_CONSP (SCM_CAR (alist
)))
1047 SCM_SETGCMARK (alist
);
1048 SCM_SETGCMARK (SCM_CAR (alist
));
1049 alist
= SCM_GCCDR (alist
);
1061 register SCM_CELLPTR ptr
;
1062 #ifdef SCM_POINTERS_MUNGED
1063 register SCM scmptr
;
1066 #define scmptr (SCM)ptr
1068 register SCM nfreelist
;
1069 register SCM
*hp_freelist
;
1077 /* Reset all free list pointers. We'll reconstruct them completely
1079 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1080 *scm_heap_table
[i
].freelistp
= SCM_EOL
;
1082 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1084 register scm_sizet n
= 0;
1085 register scm_sizet j
;
1087 /* Unmarked cells go onto the front of the freelist this heap
1088 segment points to. Rather than updating the real freelist
1089 pointer as we go along, we accumulate the new head in
1090 nfreelist. Then, if it turns out that the entire segment is
1091 free, we free (i.e., malloc's free) the whole segment, and
1092 simply don't assign nfreelist back into the real freelist. */
1093 hp_freelist
= scm_heap_table
[i
].freelistp
;
1094 nfreelist
= *hp_freelist
;
1096 span
= scm_heap_table
[i
].ncells
;
1097 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1098 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1099 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1101 #ifdef SCM_POINTERS_MUNGED
1102 scmptr
= PTR2SCM (ptr
);
1104 switch SCM_TYP7 (scmptr
)
1106 case scm_tcs_cons_gloc
:
1107 if (SCM_GCMARKP (scmptr
))
1109 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1110 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1115 vcell
= SCM_CAR (scmptr
) - 1L;
1117 if ((SCM_CDR (vcell
) == 0) || (SCM_CDR (vcell
) == 1))
1119 scm_struct_free_t free
1120 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1121 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1125 case scm_tcs_cons_imcar
:
1126 case scm_tcs_cons_nimcar
:
1127 case scm_tcs_closures
:
1129 if (SCM_GCMARKP (scmptr
))
1133 if (SCM_GC8MARKP (scmptr
))
1139 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1140 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1144 case scm_tc7_vector
:
1145 case scm_tc7_lvector
:
1149 if (SCM_GC8MARKP (scmptr
))
1152 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1154 scm_must_free (SCM_CHARS (scmptr
));
1155 /* SCM_SETCHARS(scmptr, 0);*/
1158 if SCM_GC8MARKP (scmptr
)
1160 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1162 case scm_tc7_byvect
:
1163 if SCM_GC8MARKP (scmptr
)
1165 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1169 if SCM_GC8MARKP (scmptr
)
1171 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1174 if SCM_GC8MARKP (scmptr
)
1176 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1179 case scm_tc7_llvect
:
1180 if SCM_GC8MARKP (scmptr
)
1182 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1186 if SCM_GC8MARKP (scmptr
)
1188 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1191 if SCM_GC8MARKP (scmptr
)
1193 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1196 if SCM_GC8MARKP (scmptr
)
1198 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1200 case scm_tc7_substring
:
1201 if (SCM_GC8MARKP (scmptr
))
1204 case scm_tc7_string
:
1205 if (SCM_GC8MARKP (scmptr
))
1207 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1209 case scm_tc7_msymbol
:
1210 if (SCM_GC8MARKP (scmptr
))
1212 m
+= ( SCM_LENGTH (scmptr
)
1214 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1215 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1217 case scm_tc7_contin
:
1218 if SCM_GC8MARKP (scmptr
)
1220 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1221 if (SCM_VELTS (scmptr
))
1223 case scm_tc7_ssymbol
:
1224 if SCM_GC8MARKP(scmptr
)
1230 if SCM_GC8MARKP (scmptr
)
1232 if SCM_OPENP (scmptr
)
1234 int k
= SCM_PTOBNUM (scmptr
);
1235 if (!(k
< scm_numptob
))
1237 /* Keep "revealed" ports alive. */
1238 if (scm_revealed_count(scmptr
) > 0)
1240 /* Yes, I really do mean scm_ptobs[k].free */
1241 /* rather than ftobs[k].close. .close */
1242 /* is for explicit CLOSE-PORT by user */
1243 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1244 SCM_SETSTREAM (scmptr
, 0);
1245 scm_remove_from_port_table (scmptr
);
1246 scm_gc_ports_collected
++;
1247 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1251 switch SCM_GCTYP16 (scmptr
)
1253 case scm_tc_free_cell
:
1254 if SCM_GC8MARKP (scmptr
)
1258 case scm_tcs_bignums
:
1259 if SCM_GC8MARKP (scmptr
)
1261 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1263 #endif /* def SCM_BIGDIG */
1265 if SCM_GC8MARKP (scmptr
)
1267 switch ((int) (SCM_CAR (scmptr
) >> 16))
1269 case (SCM_IMAG_PART
| SCM_REAL_PART
) >> 16:
1270 m
+= sizeof (double);
1271 case SCM_REAL_PART
>> 16:
1272 case SCM_IMAG_PART
>> 16:
1273 m
+= sizeof (double);
1282 if SCM_GC8MARKP (scmptr
)
1287 k
= SCM_SMOBNUM (scmptr
);
1288 if (!(k
< scm_numsmob
))
1290 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1296 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1300 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1303 /* Stick the new cell on the front of nfreelist. It's
1304 critical that we mark this cell as freed; otherwise, the
1305 conservative collector might trace it as some other type
1307 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1308 SCM_SETCDR (scmptr
, nfreelist
);
1313 SCM_CLRGC8MARK (scmptr
);
1316 SCM_CLRGCMARK (scmptr
);
1318 #ifdef GC_FREE_SEGMENTS
1323 scm_heap_size
-= seg_size
;
1324 free ((char *) scm_heap_table
[i
].bounds
[0]);
1325 scm_heap_table
[i
].bounds
[0] = 0;
1326 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1327 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1328 scm_n_heap_segs
-= 1;
1329 i
--; /* We need to scan the segment just moved. */
1332 #endif /* ifdef GC_FREE_SEGMENTS */
1333 /* Update the real freelist pointer to point to the head of
1334 the list of free cells we've built for this segment. */
1335 *hp_freelist
= nfreelist
;
1337 #ifdef DEBUG_FREELIST
1338 scm_check_freelist ();
1339 scm_map_free_list ();
1342 scm_gc_cells_collected
+= n
;
1344 /* Scan weak vectors. */
1347 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1349 if (!SCM_IS_WHVEC_ANY (w
))
1353 ptr
= SCM_VELTS (w
);
1355 for (j
= 0; j
< n
; ++j
)
1356 if (SCM_NIMP (ptr
[j
]) && SCM_FREEP (ptr
[j
]))
1357 ptr
[j
] = SCM_BOOL_F
;
1359 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1362 register long n
= SCM_LENGTH (w
);
1365 ptr
= SCM_VELTS (w
);
1367 for (j
= 0; j
< n
; ++j
)
1374 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1375 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1380 while (SCM_NIMP (alist
)
1381 && SCM_CONSP (alist
)
1382 && SCM_NIMP (SCM_CAR (alist
))
1383 && SCM_CONSP (SCM_CAR (alist
)))
1388 key
= SCM_CAAR (alist
);
1389 value
= SCM_CDAR (alist
);
1390 if ( (weak_keys
&& SCM_NIMP (key
) && SCM_FREEP (key
))
1391 || (weak_values
&& SCM_NIMP (value
) && SCM_FREEP (value
)))
1393 *fixup
= SCM_CDR (alist
);
1396 fixup
= SCM_CDRLOC (alist
);
1397 alist
= SCM_CDR (alist
);
1403 scm_cells_allocated
= (scm_heap_size
- scm_gc_cells_collected
);
1404 scm_mallocated
-= m
;
1405 scm_gc_malloc_collected
= m
;
1411 /* {Front end to malloc}
1413 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1415 * These functions provide services comperable to malloc, realloc, and
1416 * free. They are for allocating malloced parts of scheme objects.
1417 * The primary purpose of the front end is to impose calls to gc.
1421 * Return newly malloced storage or throw an error.
1423 * The parameter WHAT is a string for error reporting.
1424 * If the threshold scm_mtrigger will be passed by this
1425 * allocation, or if the first call to malloc fails,
1426 * garbage collect -- on the presumption that some objects
1427 * using malloced storage may be collected.
1429 * The limit scm_mtrigger may be raised by this allocation.
1432 scm_must_malloc (scm_sizet size
, const char *what
)
1435 unsigned long nm
= scm_mallocated
+ size
;
1437 if (nm
<= scm_mtrigger
)
1439 SCM_SYSCALL (ptr
= malloc (size
));
1442 scm_mallocated
= nm
;
1449 nm
= scm_mallocated
+ size
;
1450 SCM_SYSCALL (ptr
= malloc (size
));
1453 scm_mallocated
= nm
;
1454 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1455 if (nm
> scm_mtrigger
)
1456 scm_mtrigger
= nm
+ nm
/ 2;
1458 scm_mtrigger
+= scm_mtrigger
/ 2;
1463 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1464 return 0; /* never reached */
1469 * is similar to scm_must_malloc.
1472 scm_must_realloc (void *where
,
1478 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1480 if (nm
<= scm_mtrigger
)
1482 SCM_SYSCALL (ptr
= realloc (where
, size
));
1485 scm_mallocated
= nm
;
1492 nm
= scm_mallocated
+ size
- old_size
;
1493 SCM_SYSCALL (ptr
= realloc (where
, size
));
1496 scm_mallocated
= nm
;
1497 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1498 if (nm
> scm_mtrigger
)
1499 scm_mtrigger
= nm
+ nm
/ 2;
1501 scm_mtrigger
+= scm_mtrigger
/ 2;
1506 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1507 return 0; /* never reached */
1511 scm_must_free (void *obj
)
1516 scm_wta (SCM_INUM0
, "already free", "");
1519 /* Announce that there has been some malloc done that will be freed
1520 * during gc. A typical use is for a smob that uses some malloced
1521 * memory but can not get it from scm_must_malloc (for whatever
1522 * reason). When a new object of this smob is created you call
1523 * scm_done_malloc with the size of the object. When your smob free
1524 * function is called, be sure to include this size in the return
1528 scm_done_malloc (size
)
1531 scm_mallocated
+= size
;
1533 if (scm_mallocated
> scm_mtrigger
)
1535 scm_igc ("foreign mallocs");
1536 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1538 if (scm_mallocated
> scm_mtrigger
)
1539 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1541 scm_mtrigger
+= scm_mtrigger
/ 2;
1551 * Each heap segment is an array of objects of a particular size.
1552 * Every segment has an associated (possibly shared) freelist.
1553 * A table of segment records is kept that records the upper and
1554 * lower extents of the segment; this is used during the conservative
1555 * phase of gc to identify probably gc roots (because they point
1556 * into valid segments at reasonable offsets). */
1559 * is true if the first segment was smaller than INIT_HEAP_SEG.
1560 * If scm_expmem is set to one, subsequent segment allocations will
1561 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1566 * is the lowest base address of any heap segment.
1568 SCM_CELLPTR scm_heap_org
;
1570 struct scm_heap_seg_data
* scm_heap_table
= 0;
1571 int scm_n_heap_segs
= 0;
1574 * is the total number of cells in heap segments.
1576 unsigned long scm_heap_size
= 0;
1579 * initializes a new heap segment and return the number of objects it contains.
1581 * The segment origin, segment size in bytes, and the span of objects
1582 * in cells are input parameters. The freelist is both input and output.
1584 * This function presume that the scm_heap_table has already been expanded
1585 * to accomodate a new segment record.
1590 init_heap_seg (seg_org
, size
, ncells
, freelistp
)
1591 SCM_CELLPTR seg_org
;
1596 register SCM_CELLPTR ptr
;
1597 #ifdef SCM_POINTERS_MUNGED
1598 register SCM scmptr
;
1603 SCM_CELLPTR seg_end
;
1607 if (seg_org
== NULL
)
1612 /* Compute the ceiling on valid object pointers w/in this segment.
1614 seg_end
= CELL_DN ((char *) ptr
+ size
);
1616 /* Find the right place and insert the segment record.
1619 for (new_seg_index
= 0;
1620 ( (new_seg_index
< scm_n_heap_segs
)
1621 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1627 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1628 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1633 scm_heap_table
[new_seg_index
].valid
= 0;
1634 scm_heap_table
[new_seg_index
].ncells
= ncells
;
1635 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1636 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1637 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1640 /* Compute the least valid object pointer w/in this segment
1642 ptr
= CELL_UP (ptr
);
1645 n_new_objects
= seg_end
- ptr
;
1647 /* Prepend objects in this segment to the freelist.
1649 while (ptr
< seg_end
)
1651 #ifdef SCM_POINTERS_MUNGED
1652 scmptr
= PTR2SCM (ptr
);
1654 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1655 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ ncells
));
1661 /* Patch up the last freelist pointer in the segment
1662 * to join it to the input freelist.
1664 SCM_SETCDR (PTR2SCM (ptr
), *freelistp
);
1665 *freelistp
= PTR2SCM (CELL_UP (seg_org
));
1667 scm_heap_size
+= (ncells
* n_new_objects
);
1676 alloc_some_heap (ncells
, freelistp
)
1680 struct scm_heap_seg_data
* tmptable
;
1684 /* Critical code sections (such as the garbage collector)
1685 * aren't supposed to add heap segments.
1687 if (scm_gc_heap_lock
)
1688 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1690 /* Expand the heap tables to have room for the new segment.
1691 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1692 * only if the allocation of the segment itself succeeds.
1694 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
1696 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
1697 realloc ((char *)scm_heap_table
, len
)));
1699 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1701 scm_heap_table
= tmptable
;
1704 /* Pick a size for the new heap segment.
1705 * The rule for picking the size of a segment is explained in
1710 len
= (scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
));
1711 if ((scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
)) != len
)
1715 len
= SCM_HEAP_SEG_SIZE
;
1720 smallest
= (ncells
* sizeof (scm_cell
));
1722 len
= (ncells
* sizeof (scm_cell
));
1724 /* Allocate with decaying ambition. */
1725 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
1726 && (len
>= smallest
))
1728 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
1731 init_heap_seg (ptr
, len
, ncells
, freelistp
);
1738 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
1743 SCM_PROC (s_unhash_name
, "unhash-name", 1, 0, 0, scm_unhash_name
);
1745 scm_unhash_name (name
)
1750 SCM_ASSERT (SCM_NIMP (name
) && SCM_SYMBOLP (name
), name
, SCM_ARG1
, s_unhash_name
);
1752 bound
= scm_n_heap_segs
;
1753 for (x
= 0; x
< bound
; ++x
)
1757 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
1758 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
1763 if (1 == (7 & (int)incar
))
1766 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
1767 && (SCM_CDR (incar
) != 0)
1768 && (SCM_CDR (incar
) != 1))
1782 /* {GC Protection Helper Functions}
1793 scm_return_first (SCM elt
, ...)
1800 scm_permanent_object (obj
)
1804 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
1810 /* Protect OBJ from the garbage collector. OBJ will not be freed,
1811 even if all other references are dropped, until someone applies
1812 scm_unprotect_object to it. This function returns OBJ.
1814 Calls to scm_protect_object nest. For every object O, there is a
1815 counter which scm_protect_object(O) increments and
1816 scm_unprotect_object(O) decrements, if it is greater than zero. If
1817 an object's counter is greater than zero, the garbage collector
1820 Of course, that's not how it's implemented. scm_protect_object and
1821 scm_unprotect_object just maintain a list of references to things.
1822 Since the GC knows about this list, all objects it mentions stay
1823 alive. scm_protect_object adds its argument to the list;
1824 scm_unprotect_object removes the first occurrence of its argument
1827 scm_protect_object (obj
)
1830 scm_protects
= scm_cons (obj
, scm_protects
);
1836 /* Remove any protection for OBJ established by a prior call to
1837 scm_protect_object. This function returns OBJ.
1839 See scm_protect_object for more information. */
1841 scm_unprotect_object (obj
)
1844 SCM
*tail_ptr
= &scm_protects
;
1846 while (SCM_NIMP (*tail_ptr
) && SCM_CONSP (*tail_ptr
))
1847 if (SCM_CAR (*tail_ptr
) == obj
)
1849 *tail_ptr
= SCM_CDR (*tail_ptr
);
1853 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
1860 /* called on process termination. */
1866 extern int on_exit (void (*procp
) (), int arg
);
1869 cleanup (int status
, void *arg
)
1871 #error Dont know how to setup a cleanup handler on your system.
1876 scm_flush_all_ports ();
1881 scm_init_storage (scm_sizet init_heap_size
)
1885 j
= SCM_NUM_PROTECTS
;
1887 scm_sys_protects
[--j
] = SCM_BOOL_F
;
1889 scm_freelist
= SCM_EOL
;
1892 j
= SCM_HEAP_SEG_SIZE
;
1893 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
1894 scm_heap_table
= ((struct scm_heap_seg_data
*)
1895 scm_must_malloc (sizeof (struct scm_heap_seg_data
), "hplims"));
1896 if (0L == init_heap_size
)
1897 init_heap_size
= SCM_INIT_HEAP_SIZE
;
1899 if ((init_heap_size
!= j
)
1900 || !init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1902 j
= SCM_HEAP_SEG_SIZE
;
1903 if (!init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1908 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
1909 /* scm_hplims[0] can change. do not remove scm_heap_org */
1910 scm_weak_vectors
= SCM_EOL
;
1912 /* Initialise the list of ports. */
1913 scm_port_table
= (scm_port
**)
1914 malloc (sizeof (scm_port
*) * scm_port_table_room
);
1915 if (!scm_port_table
)
1922 on_exit (cleanup
, 0);
1926 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
1927 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
1929 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
1930 scm_nullstr
= scm_makstr (0L, 0);
1931 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
1932 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1933 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
1934 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1935 scm_stand_in_procs
= SCM_EOL
;
1936 scm_permobjs
= SCM_EOL
;
1937 scm_protects
= SCM_EOL
;
1938 scm_asyncs
= SCM_EOL
;
1939 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
1940 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
1942 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));