1 /* Copyright (C) 1995, 1996, 1997, 1998 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
;
177 /* GC Statistics Keeping
179 unsigned long scm_cells_allocated
= 0;
180 unsigned long scm_mallocated
= 0;
181 unsigned long scm_gc_cells_collected
;
182 unsigned long scm_gc_malloc_collected
;
183 unsigned long scm_gc_ports_collected
;
184 unsigned long scm_gc_rt
;
185 unsigned long scm_gc_time_taken
= 0;
187 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
188 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
189 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
190 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
191 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
192 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
195 struct scm_heap_seg_data
197 /* lower and upper bounds of the segment */
198 SCM_CELLPTR bounds
[2];
200 /* address of the head-of-freelist pointer for this segment's cells.
201 All segments usually point to the same one, scm_freelist. */
204 /* number of SCM words per object in this segment */
207 /* If SEG_DATA->valid is non-zero, the conservative marking
208 functions will apply SEG_DATA->valid to the purported pointer and
209 SEG_DATA, and mark the object iff the function returns non-zero.
210 At the moment, I don't think anyone uses this. */
217 static void scm_mark_weak_vector_spines
SCM_P ((void));
218 static scm_sizet init_heap_seg
SCM_P ((SCM_CELLPTR
, scm_sizet
, int, SCM
*));
219 static void alloc_some_heap
SCM_P ((int, SCM
*));
223 /* Debugging functions. */
225 #ifdef DEBUG_FREELIST
227 /* Return the number of the heap segment containing CELL. */
233 for (i
= 0; i
< scm_n_heap_segs
; i
++)
234 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
235 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
237 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
243 SCM_PROC (s_map_free_list
, "map-free-list", 0, 0, 0, scm_map_free_list
);
247 int last_seg
= -1, count
= 0;
250 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
251 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
253 int this_seg
= which_seg (f
);
255 if (this_seg
!= last_seg
)
258 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
265 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
269 return SCM_UNSPECIFIED
;
273 /* Number of calls to SCM_NEWCELL since startup. */
274 static unsigned long scm_newcell_count
;
276 /* Search freelist for anything that isn't marked as a free cell.
277 Abort if we find something. */
279 scm_check_freelist ()
284 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
285 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
287 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
288 scm_newcell_count
, i
);
294 static int scm_debug_check_freelist
= 0;
296 scm_debug_newcell (void)
301 if (scm_debug_check_freelist
)
302 scm_check_freelist ();
304 /* The rest of this is supposed to be identical to the SCM_NEWCELL
306 if (SCM_IMP (scm_freelist
))
307 new = scm_gc_for_newcell ();
311 scm_freelist
= SCM_CDR (scm_freelist
);
312 ++scm_cells_allocated
;
318 #endif /* DEBUG_FREELIST */
322 /* {Scheme Interface to GC}
325 SCM_PROC (s_gc_stats
, "gc-stats", 0, 0, 0, scm_gc_stats
);
332 SCM local_scm_mtrigger
;
333 SCM local_scm_mallocated
;
334 SCM local_scm_heap_size
;
335 SCM local_scm_cells_allocated
;
336 SCM local_scm_gc_time_taken
;
344 for (i
= scm_n_heap_segs
; i
--; )
345 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
346 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
348 if (scm_n_heap_segs
!= n
)
352 local_scm_mtrigger
= scm_mtrigger
;
353 local_scm_mallocated
= scm_mallocated
;
354 local_scm_heap_size
= scm_heap_size
;
355 local_scm_cells_allocated
= scm_cells_allocated
;
356 local_scm_gc_time_taken
= scm_gc_time_taken
;
358 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
359 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
360 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
361 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
362 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
363 scm_cons (sym_heap_segments
, heap_segs
),
374 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
375 scm_gc_cells_collected
= 0;
376 scm_gc_malloc_collected
= 0;
377 scm_gc_ports_collected
= 0;
383 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
384 scm_gc_time_taken
= scm_gc_time_taken
+ scm_gc_rt
;
385 scm_system_async_mark (scm_gc_async
);
389 SCM_PROC (s_object_address
, "object-address", 1, 0, 0, scm_object_address
);
391 scm_object_address (obj
)
394 return scm_ulong2num ((unsigned long)obj
);
398 SCM_PROC(s_gc
, "gc", 0, 0, 0, scm_gc
);
405 return SCM_UNSPECIFIED
;
410 /* {C Interface For When GC is Triggered}
414 scm_gc_for_alloc (ncells
, freelistp
)
420 if ((scm_gc_cells_collected
< MIN_GC_YIELD
) || SCM_IMP (*freelistp
))
422 alloc_some_heap (ncells
, freelistp
);
429 scm_gc_for_newcell ()
432 scm_gc_for_alloc (1, &scm_freelist
);
434 scm_freelist
= SCM_CDR (fl
);
445 /* During the critical section, only the current thread may run. */
446 SCM_THREAD_CRITICAL_SECTION_START
;
449 /* fprintf (stderr, "gc: %s\n", what); */
452 if (!scm_stack_base
|| scm_block_gc
)
461 scm_guardian_gc_init ();
463 /* unprotect any struct types with no instances */
469 pos
= &scm_type_obj_list
;
470 type_list
= scm_type_obj_list
;
471 while (type_list
!= SCM_EOL
)
472 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
474 pos
= SCM_CDRLOC (type_list
);
475 type_list
= SCM_CDR (type_list
);
479 *pos
= SCM_CDR (type_list
);
480 type_list
= SCM_CDR (type_list
);
485 /* flush dead entries from the continuation stack */
490 elts
= SCM_VELTS (scm_continuation_stack
);
491 bound
= SCM_LENGTH (scm_continuation_stack
);
492 x
= SCM_INUM (scm_continuation_stack_ptr
);
495 elts
[x
] = SCM_BOOL_F
;
502 /* Protect from the C stack. This must be the first marking
503 * done because it provides information about what objects
504 * are "in-use" by the C code. "in-use" objects are those
505 * for which the values from SCM_LENGTH and SCM_CHARS must remain
506 * usable. This requirement is stricter than a liveness
507 * requirement -- in particular, it constrains the implementation
508 * of scm_vector_set_length_x.
510 SCM_FLUSH_REGISTER_WINDOWS
;
511 /* This assumes that all registers are saved into the jmp_buf */
512 setjmp (scm_save_regs_gc_mark
);
513 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
514 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
515 sizeof scm_save_regs_gc_mark
)
516 / sizeof (SCM_STACKITEM
)));
519 /* stack_len is long rather than scm_sizet in order to guarantee that
520 &stack_len is long aligned */
521 #ifdef SCM_STACK_GROWS_UP
523 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
525 long stack_len
= scm_stack_size (scm_stack_base
);
527 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
530 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
532 long stack_len
= scm_stack_size (scm_stack_base
);
534 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
538 #else /* USE_THREADS */
540 /* Mark every thread's stack and registers */
541 scm_threads_mark_stacks();
543 #endif /* USE_THREADS */
545 /* FIXME: insert a phase to un-protect string-data preserved
546 * in scm_vector_set_length_x.
549 j
= SCM_NUM_PROTECTS
;
551 scm_gc_mark (scm_sys_protects
[j
]);
554 scm_gc_mark (scm_root
->handle
);
557 scm_mark_weak_vector_spines ();
559 scm_guardian_zombify ();
567 SCM_THREAD_CRITICAL_SECTION_END
;
577 /* Mark an object precisely.
593 if (SCM_NCELLP (ptr
))
594 scm_wta (ptr
, "rogue pointer in heap", NULL
);
596 switch (SCM_TYP7 (ptr
))
598 case scm_tcs_cons_nimcar
:
599 if (SCM_GCMARKP (ptr
))
602 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
607 scm_gc_mark (SCM_CAR (ptr
));
608 ptr
= SCM_GCCDR (ptr
);
610 case scm_tcs_cons_imcar
:
612 if (SCM_GCMARKP (ptr
))
615 ptr
= SCM_GCCDR (ptr
);
617 case scm_tcs_cons_gloc
:
618 if (SCM_GCMARKP (ptr
))
623 vcell
= SCM_CAR (ptr
) - 1L;
624 switch (SCM_CDR (vcell
))
628 ptr
= SCM_GCCDR (ptr
);
640 vtable_data
= (SCM
*)vcell
;
641 layout
= vtable_data
[scm_vtable_index_layout
];
642 len
= SCM_LENGTH (layout
);
643 fields_desc
= SCM_CHARS (layout
);
644 /* We're using SCM_GCCDR here like STRUCT_DATA, except
645 that it removes the mark */
646 mem
= (SCM
*)SCM_GCCDR (ptr
);
648 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
650 scm_gc_mark (mem
[scm_struct_i_proc
+ 0]);
651 scm_gc_mark (mem
[scm_struct_i_proc
+ 1]);
652 scm_gc_mark (mem
[scm_struct_i_proc
+ 2]);
653 scm_gc_mark (mem
[scm_struct_i_proc
+ 3]);
654 scm_gc_mark (mem
[scm_struct_i_setter
]);
658 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
659 if (fields_desc
[x
] == 'p')
661 if (fields_desc
[x
] == 'p')
663 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
664 for (x
= *mem
; x
; --x
)
665 scm_gc_mark (*++mem
);
670 if (!SCM_CDR (vcell
))
672 SCM_SETGCMARK (vcell
);
673 ptr
= vtable_data
[scm_vtable_index_vtable
];
680 case scm_tcs_closures
:
681 if (SCM_GCMARKP (ptr
))
684 if (SCM_IMP (SCM_CDR (ptr
)))
686 ptr
= SCM_CLOSCAR (ptr
);
689 scm_gc_mark (SCM_CLOSCAR (ptr
));
690 ptr
= SCM_GCCDR (ptr
);
693 case scm_tc7_lvector
:
697 if (SCM_GC8MARKP (ptr
))
699 SCM_SETGC8MARK (ptr
);
700 i
= SCM_LENGTH (ptr
);
704 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
705 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
706 ptr
= SCM_VELTS (ptr
)[0];
711 SCM_SETGC8MARK (ptr
);
713 scm_mark_locations (SCM_VELTS (ptr
),
716 (sizeof (SCM_STACKITEM
) + -1 +
717 sizeof (scm_contregs
)) /
718 sizeof (SCM_STACKITEM
)));
733 SCM_SETGC8MARK (ptr
);
736 case scm_tc7_substring
:
737 if (SCM_GC8MARKP(ptr
))
739 SCM_SETGC8MARK (ptr
);
744 if (SCM_GC8MARKP(ptr
))
746 scm_weak_vectors
[scm_n_weak
++] = ptr
;
747 if (scm_n_weak
>= scm_weak_size
)
749 SCM_SYSCALL (scm_weak_vectors
=
750 (SCM
*) realloc ((char *) scm_weak_vectors
,
751 sizeof (SCM
) * (scm_weak_size
*= 2)));
752 if (scm_weak_vectors
== NULL
)
754 scm_puts ("weak vector table", scm_cur_errp
);
755 scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
757 exit(SCM_EXIT_FAILURE
);
760 SCM_SETGC8MARK (ptr
);
761 if (SCM_IS_WHVEC_ANY (ptr
))
768 len
= SCM_LENGTH (ptr
);
769 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
770 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
772 for (x
= 0; x
< len
; ++x
)
775 alist
= SCM_VELTS (ptr
)[x
];
776 /* mark everything on the alist
777 * except the keys or values, according to weak_values and weak_keys.
779 while ( SCM_NIMP (alist
)
781 && !SCM_GCMARKP (alist
)
782 && SCM_NIMP (SCM_CAR (alist
))
783 && SCM_CONSP (SCM_CAR (alist
)))
788 kvpair
= SCM_CAR (alist
);
789 next_alist
= SCM_CDR (alist
);
792 * SCM_SETGCMARK (alist);
793 * SCM_SETGCMARK (kvpair);
795 * It may be that either the key or value is protected by
796 * an escaped reference to part of the spine of this alist.
797 * If we mark the spine here, and only mark one or neither of the
798 * key and value, they may never be properly marked.
799 * This leads to a horrible situation in which an alist containing
800 * freelist cells is exported.
802 * So only mark the spines of these arrays last of all marking.
803 * If somebody confuses us by constructing a weak vector
804 * with a circular alist then we are hosed, but at least we
805 * won't prematurely drop table entries.
808 scm_gc_mark (SCM_CAR (kvpair
));
810 scm_gc_mark (SCM_GCCDR (kvpair
));
813 if (SCM_NIMP (alist
))
819 case scm_tc7_msymbol
:
820 if (SCM_GC8MARKP(ptr
))
822 SCM_SETGC8MARK (ptr
);
823 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
824 ptr
= SCM_SYMBOL_PROPS (ptr
);
826 case scm_tc7_ssymbol
:
827 if (SCM_GC8MARKP(ptr
))
829 SCM_SETGC8MARK (ptr
);
832 ptr
= (SCM
)(scm_heap_org
+ (((unsigned long)SCM_CAR (ptr
)) >> 8));
835 i
= SCM_PTOBNUM (ptr
);
836 if (!(i
< scm_numptob
))
838 if (SCM_GC8MARKP (ptr
))
840 SCM_SETGC8MARK (ptr
);
841 if (SCM_PTAB_ENTRY(ptr
))
842 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
843 if (scm_ptobs
[i
].mark
)
845 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
852 if (SCM_GC8MARKP (ptr
))
854 SCM_SETGC8MARK (ptr
);
855 switch SCM_GCTYP16 (ptr
)
856 { /* should be faster than going through scm_smobs */
857 case scm_tc_free_cell
:
858 /* printf("found free_cell %X ", ptr); fflush(stdout); */
859 SCM_SETCDR (ptr
, SCM_EOL
);
861 case scm_tcs_bignums
:
865 i
= SCM_SMOBNUM (ptr
);
866 if (!(i
< scm_numsmob
))
868 if (scm_smobs
[i
].mark
)
870 ptr
= (scm_smobs
[i
].mark
) (ptr
);
878 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
883 /* Mark a Region Conservatively
887 scm_mark_locations (x
, n
)
893 register SCM_CELLPTR ptr
;
896 if SCM_CELLP (*(SCM
**) & x
[m
])
898 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
900 j
= scm_n_heap_segs
- 1;
901 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
902 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
909 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
911 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
919 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
923 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
928 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
932 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
938 if ( !scm_heap_table
[seg_id
].valid
939 || scm_heap_table
[seg_id
].valid (ptr
,
940 &scm_heap_table
[seg_id
]))
941 scm_gc_mark (*(SCM
*) & x
[m
]);
950 /* The following is a C predicate which determines if an SCM value can be
951 regarded as a pointer to a cell on the heap. The code is duplicated
952 from scm_mark_locations. */
960 register SCM_CELLPTR ptr
;
962 if SCM_CELLP (*(SCM
**) & value
)
964 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
966 j
= scm_n_heap_segs
- 1;
967 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
968 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
975 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
977 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
985 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
989 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
994 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
998 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1004 if ( !scm_heap_table
[seg_id
].valid
1005 || scm_heap_table
[seg_id
].valid (ptr
,
1006 &scm_heap_table
[seg_id
]))
1018 scm_mark_weak_vector_spines ()
1022 for (i
= 0; i
< scm_n_weak
; ++i
)
1024 if (SCM_IS_WHVEC_ANY (scm_weak_vectors
[i
]))
1031 obj
= scm_weak_vectors
[i
];
1032 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1033 n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1034 for (j
= 0; j
< n
; ++j
)
1039 while ( SCM_NIMP (alist
)
1040 && SCM_CONSP (alist
)
1041 && !SCM_GCMARKP (alist
)
1042 && SCM_NIMP (SCM_CAR (alist
))
1043 && SCM_CONSP (SCM_CAR (alist
)))
1045 SCM_SETGCMARK (alist
);
1046 SCM_SETGCMARK (SCM_CAR (alist
));
1047 alist
= SCM_GCCDR (alist
);
1059 register SCM_CELLPTR ptr
;
1060 #ifdef SCM_POINTERS_MUNGED
1061 register SCM scmptr
;
1064 #define scmptr (SCM)ptr
1066 register SCM nfreelist
;
1067 register SCM
*hp_freelist
;
1075 /* Reset all free list pointers. We'll reconstruct them completely
1077 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1078 *scm_heap_table
[i
].freelistp
= SCM_EOL
;
1080 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1082 register scm_sizet n
= 0;
1083 register scm_sizet j
;
1085 /* Unmarked cells go onto the front of the freelist this heap
1086 segment points to. Rather than updating the real freelist
1087 pointer as we go along, we accumulate the new head in
1088 nfreelist. Then, if it turns out that the entire segment is
1089 free, we free (i.e., malloc's free) the whole segment, and
1090 simply don't assign nfreelist back into the real freelist. */
1091 hp_freelist
= scm_heap_table
[i
].freelistp
;
1092 nfreelist
= *hp_freelist
;
1094 span
= scm_heap_table
[i
].ncells
;
1095 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1096 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1097 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1099 #ifdef SCM_POINTERS_MUNGED
1100 scmptr
= PTR2SCM (ptr
);
1102 switch SCM_TYP7 (scmptr
)
1104 case scm_tcs_cons_gloc
:
1105 if (SCM_GCMARKP (scmptr
))
1107 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1108 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1113 vcell
= SCM_CAR (scmptr
) - 1L;
1115 if ((SCM_CDR (vcell
) == 0) || (SCM_CDR (vcell
) == 1))
1117 SCM
*p
= (SCM
*) SCM_GCCDR (scmptr
);
1118 if (((SCM
*) vcell
)[scm_struct_i_flags
]
1119 & SCM_STRUCTF_LIGHT
)
1121 SCM layout
= ((SCM
*)vcell
)[scm_vtable_index_layout
];
1122 m
+= (SCM_LENGTH (layout
) / 2) * sizeof (SCM
);
1127 m
+= p
[scm_struct_i_n_words
] * sizeof (SCM
) + 7;
1128 /* I feel like I'm programming in BCPL here... */
1129 free ((char *) p
[scm_struct_i_ptr
]);
1134 case scm_tcs_cons_imcar
:
1135 case scm_tcs_cons_nimcar
:
1136 case scm_tcs_closures
:
1138 if (SCM_GCMARKP (scmptr
))
1142 if (SCM_GC8MARKP (scmptr
))
1148 m
+= (1 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1149 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 1));
1153 case scm_tc7_vector
:
1154 case scm_tc7_lvector
:
1158 if (SCM_GC8MARKP (scmptr
))
1161 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1163 scm_must_free (SCM_CHARS (scmptr
));
1164 /* SCM_SETCHARS(scmptr, 0);*/
1167 if SCM_GC8MARKP (scmptr
)
1169 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1171 case scm_tc7_byvect
:
1172 if SCM_GC8MARKP (scmptr
)
1174 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1178 if SCM_GC8MARKP (scmptr
)
1180 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1183 if SCM_GC8MARKP (scmptr
)
1185 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1188 case scm_tc7_llvect
:
1189 if SCM_GC8MARKP (scmptr
)
1191 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1195 if SCM_GC8MARKP (scmptr
)
1197 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1200 if SCM_GC8MARKP (scmptr
)
1202 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1205 if SCM_GC8MARKP (scmptr
)
1207 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1209 case scm_tc7_substring
:
1210 if (SCM_GC8MARKP (scmptr
))
1213 case scm_tc7_string
:
1214 if (SCM_GC8MARKP (scmptr
))
1216 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1218 case scm_tc7_msymbol
:
1219 if (SCM_GC8MARKP (scmptr
))
1221 m
+= ( SCM_LENGTH (scmptr
)
1223 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1224 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1226 case scm_tc7_contin
:
1227 if SCM_GC8MARKP (scmptr
)
1229 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1230 if (SCM_VELTS (scmptr
))
1232 case scm_tc7_ssymbol
:
1233 if SCM_GC8MARKP(scmptr
)
1239 if SCM_GC8MARKP (scmptr
)
1241 if SCM_OPENP (scmptr
)
1243 int k
= SCM_PTOBNUM (scmptr
);
1244 if (!(k
< scm_numptob
))
1246 /* Keep "revealed" ports alive. */
1247 if (scm_revealed_count(scmptr
) > 0)
1249 /* Yes, I really do mean scm_ptobs[k].free */
1250 /* rather than ftobs[k].close. .close */
1251 /* is for explicit CLOSE-PORT by user */
1252 (scm_ptobs
[k
].free
) (scmptr
);
1253 SCM_SETSTREAM (scmptr
, 0);
1254 scm_remove_from_port_table (scmptr
);
1255 scm_gc_ports_collected
++;
1256 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1260 switch SCM_GCTYP16 (scmptr
)
1262 case scm_tc_free_cell
:
1263 if SCM_GC8MARKP (scmptr
)
1267 case scm_tcs_bignums
:
1268 if SCM_GC8MARKP (scmptr
)
1270 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1272 #endif /* def SCM_BIGDIG */
1274 if SCM_GC8MARKP (scmptr
)
1276 switch ((int) (SCM_CAR (scmptr
) >> 16))
1278 case (SCM_IMAG_PART
| SCM_REAL_PART
) >> 16:
1279 m
+= sizeof (double);
1280 case SCM_REAL_PART
>> 16:
1281 case SCM_IMAG_PART
>> 16:
1282 m
+= sizeof (double);
1291 if SCM_GC8MARKP (scmptr
)
1296 k
= SCM_SMOBNUM (scmptr
);
1297 if (!(k
< scm_numsmob
))
1299 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1305 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1309 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1312 /* Stick the new cell on the front of nfreelist. It's
1313 critical that we mark this cell as freed; otherwise, the
1314 conservative collector might trace it as some other type
1316 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1317 SCM_SETCDR (scmptr
, nfreelist
);
1322 SCM_CLRGC8MARK (scmptr
);
1325 SCM_CLRGCMARK (scmptr
);
1327 #ifdef GC_FREE_SEGMENTS
1332 scm_heap_size
-= seg_size
;
1333 free ((char *) scm_heap_table
[i
].bounds
[0]);
1334 scm_heap_table
[i
].bounds
[0] = 0;
1335 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1336 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1337 scm_n_heap_segs
-= 1;
1338 i
--; /* We need to scan the segment just moved. */
1341 #endif /* ifdef GC_FREE_SEGMENTS */
1342 /* Update the real freelist pointer to point to the head of
1343 the list of free cells we've built for this segment. */
1344 *hp_freelist
= nfreelist
;
1346 #ifdef DEBUG_FREELIST
1347 scm_check_freelist ();
1348 scm_map_free_list ();
1351 scm_gc_cells_collected
+= n
;
1353 /* Scan weak vectors. */
1356 for (i
= 0; i
< scm_n_weak
; ++i
)
1358 if (!SCM_IS_WHVEC_ANY (scm_weak_vectors
[i
]))
1362 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1363 n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1364 for (j
= 0; j
< n
; ++j
)
1365 if (SCM_NIMP (ptr
[j
]) && SCM_FREEP (ptr
[j
]))
1366 ptr
[j
] = SCM_BOOL_F
;
1368 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1370 SCM obj
= scm_weak_vectors
[i
];
1371 register long n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1374 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1376 for (j
= 0; j
< n
; ++j
)
1383 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1384 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1389 while (SCM_NIMP (alist
)
1390 && SCM_CONSP (alist
)
1391 && SCM_NIMP (SCM_CAR (alist
))
1392 && SCM_CONSP (SCM_CAR (alist
)))
1397 key
= SCM_CAAR (alist
);
1398 value
= SCM_CDAR (alist
);
1399 if ( (weak_keys
&& SCM_NIMP (key
) && SCM_FREEP (key
))
1400 || (weak_values
&& SCM_NIMP (value
) && SCM_FREEP (value
)))
1402 *fixup
= SCM_CDR (alist
);
1405 fixup
= SCM_CDRLOC (alist
);
1406 alist
= SCM_CDR (alist
);
1412 scm_cells_allocated
= (scm_heap_size
- scm_gc_cells_collected
);
1413 scm_mallocated
-= m
;
1414 scm_gc_malloc_collected
= m
;
1420 /* {Front end to malloc}
1422 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1424 * These functions provide services comperable to malloc, realloc, and
1425 * free. They are for allocating malloced parts of scheme objects.
1426 * The primary purpose of the front end is to impose calls to gc.
1430 * Return newly malloced storage or throw an error.
1432 * The parameter WHAT is a string for error reporting.
1433 * If the threshold scm_mtrigger will be passed by this
1434 * allocation, or if the first call to malloc fails,
1435 * garbage collect -- on the presumption that some objects
1436 * using malloced storage may be collected.
1438 * The limit scm_mtrigger may be raised by this allocation.
1441 scm_must_malloc (len
, what
)
1446 scm_sizet size
= len
;
1447 unsigned long nm
= scm_mallocated
+ size
;
1450 scm_wta (SCM_MAKINUM (len
), (char *) SCM_NALLOC
, what
);
1451 if ((nm
<= scm_mtrigger
))
1453 SCM_SYSCALL (ptr
= (char *) malloc (size
));
1456 scm_mallocated
= nm
;
1462 nm
= scm_mallocated
+ size
;
1463 SCM_SYSCALL (ptr
= (char *) malloc (size
));
1466 scm_mallocated
= nm
;
1467 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1468 if (nm
> scm_mtrigger
)
1469 scm_mtrigger
= nm
+ nm
/ 2;
1471 scm_mtrigger
+= scm_mtrigger
/ 2;
1480 * is similar to scm_must_malloc.
1483 scm_must_realloc (char *where
,
1489 scm_sizet size
= len
;
1490 scm_sizet nm
= scm_mallocated
+ size
- olen
;
1493 scm_wta (SCM_MAKINUM (len
), (char *) SCM_NALLOC
, what
);
1494 if ((nm
<= scm_mtrigger
))
1496 SCM_SYSCALL (ptr
= (char *) realloc (where
, size
));
1499 scm_mallocated
= nm
;
1504 nm
= scm_mallocated
+ size
- olen
;
1505 SCM_SYSCALL (ptr
= (char *) realloc (where
, size
));
1508 scm_mallocated
= nm
;
1509 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1510 if (nm
> scm_mtrigger
)
1511 scm_mtrigger
= nm
+ nm
/ 2;
1513 scm_mtrigger
+= scm_mtrigger
/ 2;
1527 scm_wta (SCM_INUM0
, "already free", "");
1530 /* Announce that there has been some malloc done that will be freed
1531 * during gc. A typical use is for a smob that uses some malloced
1532 * memory but can not get it from scm_must_malloc (for whatever
1533 * reason). When a new object of this smob is created you call
1534 * scm_done_malloc with the size of the object. When your smob free
1535 * function is called, be sure to include this size in the return
1539 scm_done_malloc (size
)
1542 scm_mallocated
+= size
;
1544 if (scm_mallocated
> scm_mtrigger
)
1546 scm_igc ("foreign mallocs");
1547 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1549 if (scm_mallocated
> scm_mtrigger
)
1550 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1552 scm_mtrigger
+= scm_mtrigger
/ 2;
1562 * Each heap segment is an array of objects of a particular size.
1563 * Every segment has an associated (possibly shared) freelist.
1564 * A table of segment records is kept that records the upper and
1565 * lower extents of the segment; this is used during the conservative
1566 * phase of gc to identify probably gc roots (because they point
1567 * into valid segments at reasonable offsets). */
1570 * is true if the first segment was smaller than INIT_HEAP_SEG.
1571 * If scm_expmem is set to one, subsequent segment allocations will
1572 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1577 * is the lowest base address of any heap segment.
1579 SCM_CELLPTR scm_heap_org
;
1581 struct scm_heap_seg_data
* scm_heap_table
= 0;
1582 int scm_n_heap_segs
= 0;
1585 * is the total number of cells in heap segments.
1587 unsigned long scm_heap_size
= 0;
1590 * initializes a new heap segment and return the number of objects it contains.
1592 * The segment origin, segment size in bytes, and the span of objects
1593 * in cells are input parameters. The freelist is both input and output.
1595 * This function presume that the scm_heap_table has already been expanded
1596 * to accomodate a new segment record.
1601 init_heap_seg (seg_org
, size
, ncells
, freelistp
)
1602 SCM_CELLPTR seg_org
;
1607 register SCM_CELLPTR ptr
;
1608 #ifdef SCM_POINTERS_MUNGED
1609 register SCM scmptr
;
1614 SCM_CELLPTR seg_end
;
1618 if (seg_org
== NULL
)
1623 /* Compute the ceiling on valid object pointers w/in this segment.
1625 seg_end
= CELL_DN ((char *) ptr
+ size
);
1627 /* Find the right place and insert the segment record.
1630 for (new_seg_index
= 0;
1631 ( (new_seg_index
< scm_n_heap_segs
)
1632 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1638 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1639 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1644 scm_heap_table
[new_seg_index
].valid
= 0;
1645 scm_heap_table
[new_seg_index
].ncells
= ncells
;
1646 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1647 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1648 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1651 /* Compute the least valid object pointer w/in this segment
1653 ptr
= CELL_UP (ptr
);
1656 n_new_objects
= seg_end
- ptr
;
1658 /* Prepend objects in this segment to the freelist.
1660 while (ptr
< seg_end
)
1662 #ifdef SCM_POINTERS_MUNGED
1663 scmptr
= PTR2SCM (ptr
);
1665 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1666 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ ncells
));
1672 /* Patch up the last freelist pointer in the segment
1673 * to join it to the input freelist.
1675 SCM_SETCDR (PTR2SCM (ptr
), *freelistp
);
1676 *freelistp
= PTR2SCM (CELL_UP (seg_org
));
1678 scm_heap_size
+= (ncells
* n_new_objects
);
1687 alloc_some_heap (ncells
, freelistp
)
1691 struct scm_heap_seg_data
* tmptable
;
1695 /* Critical code sections (such as the garbage collector)
1696 * aren't supposed to add heap segments.
1698 if (scm_gc_heap_lock
)
1699 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1701 /* Expand the heap tables to have room for the new segment.
1702 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1703 * only if the allocation of the segment itself succeeds.
1705 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
1707 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
1708 realloc ((char *)scm_heap_table
, len
)));
1710 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1712 scm_heap_table
= tmptable
;
1715 /* Pick a size for the new heap segment.
1716 * The rule for picking the size of a segment is explained in
1721 len
= (scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
));
1722 if ((scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
)) != len
)
1726 len
= SCM_HEAP_SEG_SIZE
;
1731 smallest
= (ncells
* sizeof (scm_cell
));
1733 len
= (ncells
* sizeof (scm_cell
));
1735 /* Allocate with decaying ambition. */
1736 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
1737 && (len
>= smallest
))
1739 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
1742 init_heap_seg (ptr
, len
, ncells
, freelistp
);
1749 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
1754 SCM_PROC (s_unhash_name
, "unhash-name", 1, 0, 0, scm_unhash_name
);
1756 scm_unhash_name (name
)
1761 SCM_ASSERT (SCM_NIMP (name
) && SCM_SYMBOLP (name
), name
, SCM_ARG1
, s_unhash_name
);
1763 bound
= scm_n_heap_segs
;
1764 for (x
= 0; x
< bound
; ++x
)
1768 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
1769 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
1774 if (1 == (7 & (int)incar
))
1777 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
1778 && (SCM_CDR (incar
) != 0)
1779 && (SCM_CDR (incar
) != 1))
1793 /* {GC Protection Helper Functions}
1804 scm_return_first (SCM elt
, ...)
1811 scm_permanent_object (obj
)
1815 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
1821 /* Protect OBJ from the garbage collector. OBJ will not be freed,
1822 even if all other references are dropped, until someone applies
1823 scm_unprotect_object to it. This function returns OBJ.
1825 Calls to scm_protect_object nest. For every object O, there is a
1826 counter which scm_protect_object(O) increments and
1827 scm_unprotect_object(O) decrements, if it is greater than zero. If
1828 an object's counter is greater than zero, the garbage collector
1831 Of course, that's not how it's implemented. scm_protect_object and
1832 scm_unprotect_object just maintain a list of references to things.
1833 Since the GC knows about this list, all objects it mentions stay
1834 alive. scm_protect_object adds its argument to the list;
1835 scm_unprotect_object removes the first occurrence of its argument
1838 scm_protect_object (obj
)
1841 scm_protects
= scm_cons (obj
, scm_protects
);
1847 /* Remove any protection for OBJ established by a prior call to
1848 scm_protect_object. This function returns OBJ.
1850 See scm_protect_object for more information. */
1852 scm_unprotect_object (obj
)
1855 SCM
*tail_ptr
= &scm_protects
;
1857 while (SCM_NIMP (*tail_ptr
) && SCM_CONSP (*tail_ptr
))
1858 if (SCM_CAR (*tail_ptr
) == obj
)
1860 *tail_ptr
= SCM_CDR (*tail_ptr
);
1864 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
1872 scm_init_storage (scm_sizet init_heap_size
)
1876 j
= SCM_NUM_PROTECTS
;
1878 scm_sys_protects
[--j
] = SCM_BOOL_F
;
1880 scm_freelist
= SCM_EOL
;
1883 j
= SCM_HEAP_SEG_SIZE
;
1884 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
1885 scm_heap_table
= ((struct scm_heap_seg_data
*)
1886 scm_must_malloc (sizeof (struct scm_heap_seg_data
), "hplims"));
1887 if (0L == init_heap_size
)
1888 init_heap_size
= SCM_INIT_HEAP_SIZE
;
1890 if ((init_heap_size
!= j
)
1891 || !init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1893 j
= SCM_HEAP_SEG_SIZE
;
1894 if (!init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1899 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
1900 /* scm_hplims[0] can change. do not remove scm_heap_org */
1901 if (!(scm_weak_vectors
= (SCM
*) malloc ((scm_weak_size
= 32) * sizeof(SCM
))))
1904 /* Initialise the list of ports. */
1905 scm_port_table
= (struct scm_port_table
**) malloc ((long) (sizeof (struct scm_port_table
)
1906 * scm_port_table_room
));
1907 if (!scm_port_table
)
1911 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
1912 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
1914 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
1915 scm_nullstr
= scm_makstr (0L, 0);
1916 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
1917 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1918 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
1919 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1920 scm_stand_in_procs
= SCM_EOL
;
1921 scm_permobjs
= SCM_EOL
;
1922 scm_protects
= SCM_EOL
;
1923 scm_asyncs
= SCM_EOL
;
1924 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
1925 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
1927 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));