1 /* Copyright (C) 1995,1996 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. */
65 #define var_start(x, y) va_start(x, y)
68 #define var_start(x, y) va_start(x)
72 /* {heap tuning parameters}
74 * These are parameters for controlling memory allocation. The heap
75 * is the area out of which scm_cons, and object headers are allocated.
77 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
78 * 64 bit machine. The units of the _SIZE parameters are bytes.
79 * Cons pairs and object headers occupy one heap cell.
81 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
82 * allocated initially the heap will grow by half its current size
83 * each subsequent time more heap is needed.
85 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
86 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
87 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
88 * is in scm_init_storage() and alloc_some_heap() in sys.c
90 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
91 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
93 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
96 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
99 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
100 * reclaimed by a GC triggered by must_malloc. If less than this is
101 * reclaimed, the trigger threshold is raised. [I don't know what a
102 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
103 * work around a oscillation that caused almost constant GC.]
106 #define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
107 #define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
109 # define SCM_HEAP_SEG_SIZE 32768L
112 # define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
114 # define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
117 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
118 #define SCM_INIT_MALLOC_LIMIT 100000
119 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
121 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
122 bounds for allocated storage */
125 /*in 386 protected mode we must only adjust the offset */
126 # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
127 # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
130 # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
131 # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
133 # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
134 # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
141 * is the head of freelist of cons pairs.
143 SCM scm_freelist
= SCM_EOL
;
146 * is the number of bytes of must_malloc allocation needed to trigger gc.
152 * If set, don't expand the heap. Set only during gc, during which no allocation
153 * is supposed to take place anyway.
155 int scm_gc_heap_lock
= 0;
158 * Don't pause for collection if this is set -- just
162 int scm_block_gc
= 1;
164 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
165 * collection (GC) more space is allocated for the heap.
167 #define MIN_GC_YIELD (scm_heap_size/4)
169 /* During collection, this accumulates objects holding
172 SCM
*scm_weak_vectors
;
176 /* GC Statistics Keeping
178 unsigned long scm_cells_allocated
= 0;
179 unsigned long scm_mallocated
= 0;
180 unsigned long scm_gc_cells_collected
;
181 unsigned long scm_gc_malloc_collected
;
182 unsigned long scm_gc_ports_collected
;
183 unsigned long scm_gc_rt
;
184 unsigned long scm_gc_time_taken
= 0;
186 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
187 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
188 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
189 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
190 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
191 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
194 struct scm_heap_seg_data
196 /* lower and upper bounds of the segment */
197 SCM_CELLPTR bounds
[2];
199 /* address of the head-of-freelist pointer for this segment's cells.
200 All segments usually point to the same one, scm_freelist. */
203 /* number of SCM words per object in this segment */
206 /* If SEG_DATA->valid is non-zero, the conservative marking
207 functions will apply SEG_DATA->valid to the purported pointer and
208 SEG_DATA, and mark the object iff the function returns non-zero.
209 At the moment, I don't think anyone uses this. */
216 static void scm_mark_weak_vector_spines
SCM_P ((void));
217 static scm_sizet init_heap_seg
SCM_P ((SCM_CELLPTR
, scm_sizet
, int, SCM
*));
218 static void alloc_some_heap
SCM_P ((int, SCM
*));
222 /* Debugging functions. */
224 #ifdef DEBUG_FREELIST
226 /* Return the number of the heap segment containing CELL. */
232 for (i
= 0; i
< scm_n_heap_segs
; i
++)
233 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
234 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
236 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
242 SCM_PROC (s_map_free_list
, "map-free-list", 0, 0, 0, scm_map_free_list
);
246 int last_seg
= -1, count
= 0;
249 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
250 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
252 int this_seg
= which_seg (f
);
254 if (this_seg
!= last_seg
)
257 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
264 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
268 return SCM_UNSPECIFIED
;
272 /* Number of calls to SCM_NEWCELL since startup. */
273 static unsigned long scm_newcell_count
;
275 /* Search freelist for anything that isn't marked as a free cell.
276 Abort if we find something. */
278 scm_check_freelist ()
283 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
284 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
286 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
287 scm_newcell_count
, i
);
293 static int scm_debug_check_freelist
= 0;
295 scm_debug_newcell (SCM
*into
)
298 if (scm_debug_check_freelist
)
299 scm_check_freelist ();
301 /* The rest of this is supposed to be identical to the SCM_NEWCELL
303 if (SCM_IMP (scm_freelist
))
304 *into
= scm_gc_for_newcell ();
307 *into
= scm_freelist
;
308 scm_freelist
= SCM_CDR (scm_freelist
);
309 ++scm_cells_allocated
;
313 #endif /* DEBUG_FREELIST */
317 /* {Scheme Interface to GC}
320 SCM_PROC (s_gc_stats
, "gc-stats", 0, 0, 0, scm_gc_stats
);
327 SCM local_scm_mtrigger
;
328 SCM local_scm_mallocated
;
329 SCM local_scm_heap_size
;
330 SCM local_scm_cells_allocated
;
331 SCM local_scm_gc_time_taken
;
339 for (i
= scm_n_heap_segs
; i
--; )
340 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
341 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
343 if (scm_n_heap_segs
!= n
)
347 local_scm_mtrigger
= scm_mtrigger
;
348 local_scm_mallocated
= scm_mallocated
;
349 local_scm_heap_size
= scm_heap_size
;
350 local_scm_cells_allocated
= scm_cells_allocated
;
351 local_scm_gc_time_taken
= scm_gc_time_taken
;
353 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
354 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
355 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
356 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
357 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
358 scm_cons (sym_heap_segments
, heap_segs
),
369 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
370 scm_gc_cells_collected
= 0;
371 scm_gc_malloc_collected
= 0;
372 scm_gc_ports_collected
= 0;
378 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
379 scm_gc_time_taken
= scm_gc_time_taken
+ scm_gc_rt
;
380 scm_system_async_mark (scm_gc_async
);
384 SCM_PROC(s_object_address
, "object-address", 1, 0, 0, scm_object_addr
);
386 scm_object_addr (obj
)
389 return scm_ulong2num ((unsigned long)obj
);
393 SCM_PROC(s_gc
, "gc", 0, 0, 0, scm_gc
);
400 return SCM_UNSPECIFIED
;
405 /* {C Interface For When GC is Triggered}
409 scm_gc_for_alloc (ncells
, freelistp
)
415 if ((scm_gc_cells_collected
< MIN_GC_YIELD
) || SCM_IMP (*freelistp
))
417 alloc_some_heap (ncells
, freelistp
);
424 scm_gc_for_newcell ()
427 scm_gc_for_alloc (1, &scm_freelist
);
429 scm_freelist
= SCM_CDR (fl
);
440 /* During the critical section, only the current thread may run. */
441 SCM_THREAD_CRITICAL_SECTION_START
;
444 // fprintf (stderr, "gc: %s\n", what);
447 if (!scm_stack_base
|| scm_block_gc
)
456 /* unprotect any struct types with no instances */
462 pos
= &scm_type_obj_list
;
463 type_list
= scm_type_obj_list
;
464 while (type_list
!= SCM_EOL
)
465 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
467 pos
= SCM_CDRLOC (type_list
);
468 type_list
= SCM_CDR (type_list
);
472 *pos
= SCM_CDR (type_list
);
473 type_list
= SCM_CDR (type_list
);
478 /* flush dead entries from the continuation stack */
483 elts
= SCM_VELTS (scm_continuation_stack
);
484 bound
= SCM_LENGTH (scm_continuation_stack
);
485 x
= SCM_INUM (scm_continuation_stack_ptr
);
488 elts
[x
] = SCM_BOOL_F
;
495 /* Protect from the C stack. This must be the first marking
496 * done because it provides information about what objects
497 * are "in-use" by the C code. "in-use" objects are those
498 * for which the values from SCM_LENGTH and SCM_CHARS must remain
499 * usable. This requirement is stricter than a liveness
500 * requirement -- in particular, it constrains the implementation
501 * of scm_vector_set_length_x.
503 SCM_FLUSH_REGISTER_WINDOWS
;
504 /* This assumes that all registers are saved into the jmp_buf */
505 setjmp (scm_save_regs_gc_mark
);
506 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
507 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
508 sizeof scm_save_regs_gc_mark
)
509 / sizeof (SCM_STACKITEM
)));
512 /* stack_len is long rather than scm_sizet in order to guarantee that
513 &stack_len is long aligned */
514 #ifdef SCM_STACK_GROWS_UP
516 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
518 long stack_len
= scm_stack_size (scm_stack_base
);
520 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
523 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
525 long stack_len
= scm_stack_size (scm_stack_base
);
527 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
531 #else /* USE_THREADS */
533 /* Mark every thread's stack and registers */
534 scm_threads_mark_stacks();
536 #endif /* USE_THREADS */
538 /* FIXME: insert a phase to un-protect string-data preserved
539 * in scm_vector_set_length_x.
542 j
= SCM_NUM_PROTECTS
;
544 scm_gc_mark (scm_sys_protects
[j
]);
547 scm_gc_mark (scm_root
->handle
);
550 scm_mark_weak_vector_spines ();
558 SCM_THREAD_CRITICAL_SECTION_END
;
568 /* Mark an object precisely.
584 if (SCM_NCELLP (ptr
))
585 scm_wta (ptr
, "rogue pointer in heap", NULL
);
587 switch (SCM_TYP7 (ptr
))
589 case scm_tcs_cons_nimcar
:
590 if (SCM_GCMARKP (ptr
))
593 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
598 scm_gc_mark (SCM_CAR (ptr
));
599 ptr
= SCM_GCCDR (ptr
);
601 case scm_tcs_cons_imcar
:
602 if (SCM_GCMARKP (ptr
))
605 ptr
= SCM_GCCDR (ptr
);
607 case scm_tcs_cons_gloc
:
608 if (SCM_GCMARKP (ptr
))
613 vcell
= SCM_CAR (ptr
) - 1L;
614 switch (SCM_CDR (vcell
))
618 ptr
= SCM_GCCDR (ptr
);
630 vtable_data
= (SCM
*)vcell
;
631 layout
= vtable_data
[scm_struct_i_layout
];
632 len
= SCM_LENGTH (layout
);
633 fields_desc
= SCM_CHARS (layout
);
634 /* We're using SCM_GCCDR here like STRUCT_DATA, except
635 that it removes the mark */
636 mem
= (SCM
*)SCM_GCCDR (ptr
);
640 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
641 if (fields_desc
[x
] == 'p')
643 if (fields_desc
[x
] == 'p')
645 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
646 for (x
= *mem
; x
; --x
)
647 scm_gc_mark (*++mem
);
652 if (!SCM_CDR (vcell
))
654 SCM_SETGCMARK (vcell
);
655 ptr
= vtable_data
[scm_struct_i_vtable
];
662 case scm_tcs_closures
:
663 if (SCM_GCMARKP (ptr
))
666 if (SCM_IMP (SCM_CDR (ptr
)))
668 ptr
= SCM_CLOSCAR (ptr
);
671 scm_gc_mark (SCM_CLOSCAR (ptr
));
672 ptr
= SCM_GCCDR (ptr
);
675 case scm_tc7_lvector
:
679 if (SCM_GC8MARKP (ptr
))
681 SCM_SETGC8MARK (ptr
);
682 i
= SCM_LENGTH (ptr
);
686 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
687 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
688 ptr
= SCM_VELTS (ptr
)[0];
693 SCM_SETGC8MARK (ptr
);
695 scm_mark_locations (SCM_VELTS (ptr
),
698 (sizeof (SCM_STACKITEM
) + -1 +
699 sizeof (scm_contregs
)) /
700 sizeof (SCM_STACKITEM
)));
715 case scm_tc7_mb_string
:
716 SCM_SETGC8MARK (ptr
);
719 case scm_tc7_substring
:
720 case scm_tc7_mb_substring
:
721 if (SCM_GC8MARKP(ptr
))
723 SCM_SETGC8MARK (ptr
);
728 if (SCM_GC8MARKP(ptr
))
730 scm_weak_vectors
[scm_n_weak
++] = ptr
;
731 if (scm_n_weak
>= scm_weak_size
)
733 SCM_SYSCALL (scm_weak_vectors
=
734 (SCM
*) realloc ((char *) scm_weak_vectors
,
735 sizeof (SCM
*) * (scm_weak_size
*= 2)));
736 if (scm_weak_vectors
== NULL
)
738 scm_gen_puts (scm_regular_string
,
741 scm_gen_puts (scm_regular_string
,
742 "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
744 exit(SCM_EXIT_FAILURE
);
747 SCM_SETGC8MARK (ptr
);
748 if (SCM_IS_WHVEC_ANY (ptr
))
755 len
= SCM_LENGTH (ptr
);
756 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
757 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
759 for (x
= 0; x
< len
; ++x
)
762 alist
= SCM_VELTS (ptr
)[x
];
763 /* mark everything on the alist
764 * except the keys or values, according to weak_values and weak_keys.
766 while ( SCM_NIMP (alist
)
768 && !SCM_GCMARKP (alist
)
769 && SCM_NIMP (SCM_CAR (alist
))
770 && SCM_CONSP (SCM_CAR (alist
)))
775 kvpair
= SCM_CAR (alist
);
776 next_alist
= SCM_CDR (alist
);
779 * SCM_SETGCMARK (alist);
780 * SCM_SETGCMARK (kvpair);
782 * It may be that either the key or value is protected by
783 * an escaped reference to part of the spine of this alist.
784 * If we mark the spine here, and only mark one or neither of the
785 * key and value, they may never be properly marked.
786 * This leads to a horrible situation in which an alist containing
787 * freelist cells is exported.
789 * So only mark the spines of these arrays last of all marking.
790 * If somebody confuses us by constructing a weak vector
791 * with a circular alist then we are hosed, but at least we
792 * won't prematurely drop table entries.
795 scm_gc_mark (SCM_CAR (kvpair
));
797 scm_gc_mark (SCM_GCCDR (kvpair
));
800 if (SCM_NIMP (alist
))
806 case scm_tc7_msymbol
:
807 if (SCM_GC8MARKP(ptr
))
809 SCM_SETGC8MARK (ptr
);
810 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
811 ptr
= SCM_SYMBOL_PROPS (ptr
);
813 case scm_tc7_ssymbol
:
814 if (SCM_GC8MARKP(ptr
))
816 SCM_SETGC8MARK (ptr
);
819 ptr
= (SCM
)(scm_heap_org
+ (((unsigned long)SCM_CAR (ptr
)) >> 8));
822 i
= SCM_PTOBNUM (ptr
);
823 if (!(i
< scm_numptob
))
825 if (SCM_GC8MARKP (ptr
))
827 if (SCM_PTAB_ENTRY(ptr
))
828 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
829 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
833 if (SCM_GC8MARKP (ptr
))
835 switch SCM_TYP16 (ptr
)
836 { /* should be faster than going through scm_smobs */
837 case scm_tc_free_cell
:
838 /* printf("found free_cell %X ", ptr); fflush(stdout); */
839 SCM_SETGC8MARK (ptr
);
840 SCM_SETCDR (ptr
, SCM_EOL
);
842 case scm_tcs_bignums
:
844 SCM_SETGC8MARK (ptr
);
847 i
= SCM_SMOBNUM (ptr
);
848 if (!(i
< scm_numsmob
))
850 ptr
= (scm_smobs
[i
].mark
) (ptr
);
855 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
860 /* Mark a Region Conservatively
864 scm_mark_locations (x
, n
)
870 register SCM_CELLPTR ptr
;
873 if SCM_CELLP (*(SCM
**) & x
[m
])
875 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
877 j
= scm_n_heap_segs
- 1;
878 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
879 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
886 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
888 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
896 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
900 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
905 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
909 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
915 if ( !scm_heap_table
[seg_id
].valid
916 || scm_heap_table
[seg_id
].valid (ptr
,
917 &scm_heap_table
[seg_id
]))
918 scm_gc_mark (*(SCM
*) & x
[m
]);
927 /* The following is a C predicate which determines if an SCM value can be
928 regarded as a pointer to a cell on the heap. The code is duplicated
929 from scm_mark_locations. */
937 register SCM_CELLPTR ptr
;
939 if SCM_CELLP (*(SCM
**) & value
)
941 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
943 j
= scm_n_heap_segs
- 1;
944 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
945 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
952 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
954 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
962 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
966 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
971 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
975 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
981 if ( !scm_heap_table
[seg_id
].valid
982 || scm_heap_table
[seg_id
].valid (ptr
,
983 &scm_heap_table
[seg_id
]))
995 scm_mark_weak_vector_spines ()
999 for (i
= 0; i
< scm_n_weak
; ++i
)
1001 if (SCM_IS_WHVEC_ANY (scm_weak_vectors
[i
]))
1008 obj
= scm_weak_vectors
[i
];
1009 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1010 n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1011 for (j
= 0; j
< n
; ++j
)
1016 while ( SCM_NIMP (alist
)
1017 && SCM_CONSP (alist
)
1018 && !SCM_GCMARKP (alist
)
1019 && SCM_NIMP (SCM_CAR (alist
))
1020 && SCM_CONSP (SCM_CAR (alist
)))
1022 SCM_SETGCMARK (alist
);
1023 SCM_SETGCMARK (SCM_CAR (alist
));
1024 alist
= SCM_GCCDR (alist
);
1036 register SCM_CELLPTR ptr
;
1037 #ifdef SCM_POINTERS_MUNGED
1038 register SCM scmptr
;
1041 #define scmptr (SCM)ptr
1043 register SCM nfreelist
;
1044 register SCM
*hp_freelist
;
1047 register scm_sizet j
;
1055 /* Reset all free list pointers. We'll reconstruct them completely
1057 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1058 *scm_heap_table
[i
].freelistp
= SCM_EOL
;
1060 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1062 /* Unmarked cells go onto the front of the freelist this heap
1063 segment points to. Rather than updating the real freelist
1064 pointer as we go along, we accumulate the new head in
1065 nfreelist. Then, if it turns out that the entire segment is
1066 free, we free (i.e., malloc's free) the whole segment, and
1067 simply don't assign nfreelist back into the real freelist. */
1068 hp_freelist
= scm_heap_table
[i
].freelistp
;
1069 nfreelist
= *hp_freelist
;
1071 span
= scm_heap_table
[i
].ncells
;
1072 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1073 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1074 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1076 #ifdef SCM_POINTERS_MUNGED
1077 scmptr
= PTR2SCM (ptr
);
1079 switch SCM_TYP7 (scmptr
)
1081 case scm_tcs_cons_gloc
:
1082 if (SCM_GCMARKP (scmptr
))
1084 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1085 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1090 vcell
= SCM_CAR (scmptr
) - 1L;
1092 if ((SCM_CDR (vcell
) == 0) || (SCM_CDR (vcell
) == 1))
1094 SCM
*p
= (SCM
*) SCM_GCCDR (scmptr
);
1095 m
+= p
[scm_struct_i_n_words
] * sizeof (SCM
);
1096 /* I feel like I'm programming in BCPL here... */
1097 free ((char *) p
[scm_struct_i_ptr
]);
1101 case scm_tcs_cons_imcar
:
1102 case scm_tcs_cons_nimcar
:
1103 case scm_tcs_closures
:
1104 if (SCM_GCMARKP (scmptr
))
1108 if (SCM_GC8MARKP (scmptr
))
1114 m
+= (1 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1115 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 1));
1119 case scm_tc7_vector
:
1120 case scm_tc7_lvector
:
1124 if (SCM_GC8MARKP (scmptr
))
1127 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1129 scm_must_free (SCM_CHARS (scmptr
));
1130 /* SCM_SETCHARS(scmptr, 0);*/
1133 if SCM_GC8MARKP (scmptr
)
1135 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1137 case scm_tc7_byvect
:
1138 if SCM_GC8MARKP (scmptr
)
1140 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1144 if SCM_GC8MARKP (scmptr
)
1146 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1149 if SCM_GC8MARKP (scmptr
)
1151 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1154 case scm_tc7_llvect
:
1155 if SCM_GC8MARKP (scmptr
)
1157 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1161 if SCM_GC8MARKP (scmptr
)
1163 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1166 if SCM_GC8MARKP (scmptr
)
1168 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1171 if SCM_GC8MARKP (scmptr
)
1173 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1175 case scm_tc7_substring
:
1176 case scm_tc7_mb_substring
:
1177 if (SCM_GC8MARKP (scmptr
))
1180 case scm_tc7_string
:
1181 case scm_tc7_mb_string
:
1182 if (SCM_GC8MARKP (scmptr
))
1184 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1186 case scm_tc7_msymbol
:
1187 if (SCM_GC8MARKP (scmptr
))
1189 m
+= ( SCM_LENGTH (scmptr
)
1191 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1192 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1194 case scm_tc7_contin
:
1195 if SCM_GC8MARKP (scmptr
)
1197 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1198 if (SCM_VELTS (scmptr
))
1200 case scm_tc7_ssymbol
:
1201 if SCM_GC8MARKP(scmptr
)
1207 if SCM_GC8MARKP (scmptr
)
1209 if SCM_OPENP (scmptr
)
1211 int k
= SCM_PTOBNUM (scmptr
);
1212 if (!(k
< scm_numptob
))
1214 /* Keep "revealed" ports alive. */
1215 if (scm_revealed_count(scmptr
) > 0)
1217 /* Yes, I really do mean scm_ptobs[k].free */
1218 /* rather than ftobs[k].close. .close */
1219 /* is for explicit CLOSE-PORT by user */
1220 (scm_ptobs
[k
].free
) (SCM_STREAM (scmptr
));
1221 SCM_SETSTREAM (scmptr
, 0);
1222 scm_remove_from_port_table (scmptr
);
1223 scm_gc_ports_collected
++;
1224 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1228 switch SCM_GCTYP16 (scmptr
)
1230 case scm_tc_free_cell
:
1231 if SCM_GC8MARKP (scmptr
)
1235 case scm_tcs_bignums
:
1236 if SCM_GC8MARKP (scmptr
)
1238 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1240 #endif /* def SCM_BIGDIG */
1242 if SCM_GC8MARKP (scmptr
)
1244 switch ((int) (SCM_CAR (scmptr
) >> 16))
1246 case (SCM_IMAG_PART
| SCM_REAL_PART
) >> 16:
1247 m
+= sizeof (double);
1248 case SCM_REAL_PART
>> 16:
1249 case SCM_IMAG_PART
>> 16:
1250 m
+= sizeof (double);
1259 if SCM_GC8MARKP (scmptr
)
1264 k
= SCM_SMOBNUM (scmptr
);
1265 if (!(k
< scm_numsmob
))
1267 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1273 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1277 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1280 /* Stick the new cell on the front of nfreelist. */
1281 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1282 SCM_SETCDR (scmptr
, nfreelist
);
1287 SCM_CLRGC8MARK (scmptr
);
1290 SCM_CLRGCMARK (scmptr
);
1292 #ifdef GC_FREE_SEGMENTS
1295 scm_heap_size
-= seg_size
;
1296 free ((char *) scm_heap_table
[i
].bounds
[0]);
1297 scm_heap_table
[i
].bounds
[0] = 0;
1298 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1299 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1300 scm_n_heap_segs
-= 1;
1301 i
--; /* We need to scan the segment just moved. */
1304 #endif /* ifdef GC_FREE_SEGMENTS */
1305 /* Update the real freelist pointer to point to the head of
1306 the list of free cells we've built for this segment. */
1307 *hp_freelist
= nfreelist
;
1309 #ifdef DEBUG_FREELIST
1310 scm_check_freelist ();
1311 scm_map_free_list ();
1314 scm_gc_cells_collected
+= n
;
1317 /* Scan weak vectors. */
1320 for (i
= 0; i
< scm_n_weak
; ++i
)
1322 if (!SCM_IS_WHVEC_ANY (scm_weak_vectors
[i
]))
1324 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1325 n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1326 for (j
= 0; j
< n
; ++j
)
1327 if (SCM_NIMP (ptr
[j
]) && SCM_FREEP (ptr
[j
]))
1328 ptr
[j
] = SCM_BOOL_F
;
1330 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1333 obj
= scm_weak_vectors
[i
];
1334 ptr
= SCM_VELTS (scm_weak_vectors
[i
]);
1335 n
= SCM_LENGTH (scm_weak_vectors
[i
]);
1336 for (j
= 0; j
< n
; ++j
)
1343 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1344 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1349 while (SCM_NIMP (alist
)
1350 && SCM_CONSP (alist
)
1351 && SCM_NIMP (SCM_CAR (alist
))
1352 && SCM_CONSP (SCM_CAR (alist
)))
1357 key
= SCM_CAAR (alist
);
1358 value
= SCM_CDAR (alist
);
1359 if ( (weak_keys
&& SCM_NIMP (key
) && SCM_FREEP (key
))
1360 || (weak_values
&& SCM_NIMP (value
) && SCM_FREEP (value
)))
1362 *fixup
= SCM_CDR (alist
);
1365 fixup
= SCM_CDRLOC (alist
);
1366 alist
= SCM_CDR (alist
);
1372 scm_cells_allocated
= (scm_heap_size
- scm_gc_cells_collected
);
1373 scm_mallocated
-= m
;
1374 scm_gc_malloc_collected
= m
;
1380 /* {Front end to malloc}
1382 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1384 * These functions provide services comperable to malloc, realloc, and
1385 * free. They are for allocating malloced parts of scheme objects.
1386 * The primary purpose of the front end is to impose calls to gc.
1390 * Return newly malloced storage or throw an error.
1392 * The parameter WHAT is a string for error reporting.
1393 * If the threshold scm_mtrigger will be passed by this
1394 * allocation, or if the first call to malloc fails,
1395 * garbage collect -- on the presumption that some objects
1396 * using malloced storage may be collected.
1398 * The limit scm_mtrigger may be raised by this allocation.
1401 scm_must_malloc (len
, what
)
1406 scm_sizet size
= len
;
1407 long nm
= scm_mallocated
+ size
;
1410 scm_wta (SCM_MAKINUM (len
), (char *) SCM_NALLOC
, what
);
1411 if ((nm
<= scm_mtrigger
))
1413 SCM_SYSCALL (ptr
= (char *) malloc (size
));
1416 scm_mallocated
= nm
;
1422 nm
= scm_mallocated
+ size
;
1423 SCM_SYSCALL (ptr
= (char *) malloc (size
));
1426 scm_mallocated
= nm
;
1427 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1428 if (nm
> scm_mtrigger
)
1429 scm_mtrigger
= nm
+ nm
/ 2;
1431 scm_mtrigger
+= scm_mtrigger
/ 2;
1440 * is similar to scm_must_malloc.
1443 scm_must_realloc (where
, olen
, len
, what
)
1450 scm_sizet size
= len
;
1451 long nm
= scm_mallocated
+ size
- olen
;
1454 scm_wta (SCM_MAKINUM (len
), (char *) SCM_NALLOC
, what
);
1455 if ((nm
<= scm_mtrigger
))
1457 SCM_SYSCALL (ptr
= (char *) realloc (where
, size
));
1460 scm_mallocated
= nm
;
1465 nm
= scm_mallocated
+ size
- olen
;
1466 SCM_SYSCALL (ptr
= (char *) realloc (where
, size
));
1469 scm_mallocated
= nm
;
1470 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1471 if (nm
> scm_mtrigger
)
1472 scm_mtrigger
= nm
+ nm
/ 2;
1474 scm_mtrigger
+= scm_mtrigger
/ 2;
1488 scm_wta (SCM_INUM0
, "already free", "");
1491 /* Announce that there has been some malloc done that will be freed
1492 * during gc. A typical use is for a smob that uses some malloced
1493 * memory but can not get it from scm_must_malloc (for whatever
1494 * reason). When a new object of this smob is created you call
1495 * scm_done_malloc with the size of the object. When your smob free
1496 * function is called, be sure to include this size in the return
1500 scm_done_malloc (size
)
1503 scm_mallocated
+= size
;
1505 if (scm_mallocated
> scm_mtrigger
)
1507 scm_igc ("foreign mallocs");
1508 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1510 if (scm_mallocated
> scm_mtrigger
)
1511 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1513 scm_mtrigger
+= scm_mtrigger
/ 2;
1523 * Each heap segment is an array of objects of a particular size.
1524 * Every segment has an associated (possibly shared) freelist.
1525 * A table of segment records is kept that records the upper and
1526 * lower extents of the segment; this is used during the conservative
1527 * phase of gc to identify probably gc roots (because they point
1528 * into valid segments at reasonable offsets). */
1531 * is true if the first segment was smaller than INIT_HEAP_SEG.
1532 * If scm_expmem is set to one, subsequent segment allocations will
1533 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1538 * is the lowest base address of any heap segment.
1540 SCM_CELLPTR scm_heap_org
;
1542 struct scm_heap_seg_data
* scm_heap_table
= 0;
1543 int scm_n_heap_segs
= 0;
1546 * is the total number of cells in heap segments.
1548 long scm_heap_size
= 0;
1551 * initializes a new heap segment and return the number of objects it contains.
1553 * The segment origin, segment size in bytes, and the span of objects
1554 * in cells are input parameters. The freelist is both input and output.
1556 * This function presume that the scm_heap_table has already been expanded
1557 * to accomodate a new segment record.
1562 init_heap_seg (seg_org
, size
, ncells
, freelistp
)
1563 SCM_CELLPTR seg_org
;
1568 register SCM_CELLPTR ptr
;
1569 #ifdef SCM_POINTERS_MUNGED
1570 register SCM scmptr
;
1575 SCM_CELLPTR seg_end
;
1576 scm_sizet new_seg_index
;
1577 scm_sizet n_new_objects
;
1579 if (seg_org
== NULL
)
1584 /* Compute the ceiling on valid object pointers w/in this segment.
1586 seg_end
= CELL_DN ((char *) ptr
+ size
);
1588 /* Find the right place and insert the segment record.
1591 for (new_seg_index
= 0;
1592 ( (new_seg_index
< scm_n_heap_segs
)
1593 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1599 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1600 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1605 scm_heap_table
[new_seg_index
].valid
= 0;
1606 scm_heap_table
[new_seg_index
].ncells
= ncells
;
1607 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1608 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1609 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1612 /* Compute the least valid object pointer w/in this segment
1614 ptr
= CELL_UP (ptr
);
1617 n_new_objects
= seg_end
- ptr
;
1619 /* Prepend objects in this segment to the freelist.
1621 while (ptr
< seg_end
)
1623 #ifdef SCM_POINTERS_MUNGED
1624 scmptr
= PTR2SCM (ptr
);
1626 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1627 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ ncells
));
1633 /* Patch up the last freelist pointer in the segment
1634 * to join it to the input freelist.
1636 SCM_SETCDR (PTR2SCM (ptr
), *freelistp
);
1637 *freelistp
= PTR2SCM (CELL_UP (seg_org
));
1639 scm_heap_size
+= (ncells
* n_new_objects
);
1648 alloc_some_heap (ncells
, freelistp
)
1652 struct scm_heap_seg_data
* tmptable
;
1656 /* Critical code sections (such as the garbage collector)
1657 * aren't supposed to add heap segments.
1659 if (scm_gc_heap_lock
)
1660 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1662 /* Expand the heap tables to have room for the new segment.
1663 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1664 * only if the allocation of the segment itself succeeds.
1666 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
1668 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
1669 realloc ((char *)scm_heap_table
, len
)));
1671 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1673 scm_heap_table
= tmptable
;
1676 /* Pick a size for the new heap segment.
1677 * The rule for picking the size of a segment is explained in
1682 len
= (scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
));
1683 if ((scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
)) != len
)
1687 len
= SCM_HEAP_SEG_SIZE
;
1692 smallest
= (ncells
* sizeof (scm_cell
));
1694 len
= (ncells
* sizeof (scm_cell
));
1696 /* Allocate with decaying ambition. */
1697 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
1698 && (len
>= smallest
))
1700 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
1703 init_heap_seg (ptr
, len
, ncells
, freelistp
);
1710 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
1715 SCM_PROC (s_unhash_name
, "unhash-name", 1, 0, 0, scm_unhash_name
);
1717 scm_unhash_name (name
)
1722 SCM_ASSERT (SCM_NIMP (name
) && SCM_SYMBOLP (name
), name
, SCM_ARG1
, s_unhash_name
);
1724 bound
= scm_n_heap_segs
;
1725 for (x
= 0; x
< bound
; ++x
)
1729 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
1730 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
1735 if (1 == (7 & (int)incar
))
1738 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
1739 && (SCM_CDR (incar
) != 0)
1740 && (SCM_CDR (incar
) != 1))
1754 /* {GC Protection Helper Functions}
1766 scm_return_first (SCM elt
, ...)
1769 scm_return_first (elt
, va_alist
)
1779 scm_permanent_object (obj
)
1783 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
1789 /* Protect OBJ from the garbage collector. OBJ will not be freed,
1790 even if all other references are dropped, until someone applies
1791 scm_unprotect_object to it. This function returns OBJ.
1793 Note that calls to scm_protect_object do not nest. You can call
1794 scm_protect_object any number of times on a given object, and the
1795 next call to scm_unprotect_object will unprotect it completely.
1797 Basically, scm_protect_object and scm_unprotect_object just
1798 maintain a list of references to things. Since the GC knows about
1799 this list, all objects it mentions stay alive. scm_protect_object
1800 adds its argument to the list; scm_unprotect_object remove its
1801 argument from the list. */
1803 scm_protect_object (obj
)
1806 /* This function really should use address hashing tables, but I
1807 don't know how to use them yet. For now we just use a list. */
1808 scm_protects
= scm_cons (obj
, scm_protects
);
1814 /* Remove any protection for OBJ established by a prior call to
1815 scm_protect_obj. This function returns OBJ.
1817 See scm_protect_obj for more information. */
1819 scm_unprotect_object (obj
)
1822 scm_protects
= scm_delq_x (obj
, scm_protects
);
1830 scm_init_storage (init_heap_size
)
1831 long init_heap_size
;
1835 j
= SCM_NUM_PROTECTS
;
1837 scm_sys_protects
[--j
] = SCM_BOOL_F
;
1839 scm_freelist
= SCM_EOL
;
1842 j
= SCM_HEAP_SEG_SIZE
;
1843 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
1844 scm_heap_table
= ((struct scm_heap_seg_data
*)
1845 scm_must_malloc (sizeof (struct scm_heap_seg_data
), "hplims"));
1846 if (0L == init_heap_size
)
1847 init_heap_size
= SCM_INIT_HEAP_SIZE
;
1849 if ((init_heap_size
!= j
)
1850 || !init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1852 j
= SCM_HEAP_SEG_SIZE
;
1853 if (!init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1858 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
1859 /* scm_hplims[0] can change. do not remove scm_heap_org */
1860 if (!(scm_weak_vectors
= (SCM
*) malloc ((scm_weak_size
= 32) * sizeof(SCM
*))))
1863 /* Initialise the list of ports. */
1864 scm_port_table
= (struct scm_port_table
**) malloc ((long) (sizeof (struct scm_port_table
)
1865 * scm_port_table_room
));
1866 if (!scm_port_table
)
1870 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
1871 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
1873 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
1874 scm_nullstr
= scm_makstr (0L, 0);
1875 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1876 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
, SCM_UNDEFINED
);
1877 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
1878 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
, SCM_UNDEFINED
);
1879 scm_stand_in_procs
= SCM_EOL
;
1880 scm_permobjs
= SCM_EOL
;
1881 scm_protects
= SCM_EOL
;
1882 scm_asyncs
= SCM_EOL
;
1883 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
1884 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
1886 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));