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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
53 #include "guardians.h"
58 #include "scm_validate.h"
71 #define var_start(x, y) va_start(x, y)
74 #define var_start(x, y) va_start(x)
78 /* {heap tuning parameters}
80 * These are parameters for controlling memory allocation. The heap
81 * is the area out of which scm_cons, and object headers are allocated.
83 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
84 * 64 bit machine. The units of the _SIZE parameters are bytes.
85 * Cons pairs and object headers occupy one heap cell.
87 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
88 * allocated initially the heap will grow by half its current size
89 * each subsequent time more heap is needed.
91 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
92 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
93 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
94 * is in scm_init_storage() and alloc_some_heap() in sys.c
96 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
97 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
99 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
102 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
105 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
106 * reclaimed by a GC triggered by must_malloc. If less than this is
107 * reclaimed, the trigger threshold is raised. [I don't know what a
108 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
109 * work around a oscillation that caused almost constant GC.]
112 #define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
113 #define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
115 # define SCM_HEAP_SEG_SIZE 32768L
118 # define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
120 # define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
123 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
124 #define SCM_INIT_MALLOC_LIMIT 100000
125 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
127 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
128 bounds for allocated storage */
131 /*in 386 protected mode we must only adjust the offset */
132 # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
133 # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
136 # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
137 # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
139 # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
140 # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
147 * is the head of freelist of cons pairs.
149 SCM scm_freelist
= SCM_EOL
;
152 * is the number of bytes of must_malloc allocation needed to trigger gc.
154 unsigned long scm_mtrigger
;
158 * If set, don't expand the heap. Set only during gc, during which no allocation
159 * is supposed to take place anyway.
161 int scm_gc_heap_lock
= 0;
164 * Don't pause for collection if this is set -- just
168 int scm_block_gc
= 1;
170 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
171 * collection (GC) more space is allocated for the heap.
173 #define MIN_GC_YIELD (scm_heap_size/4)
175 /* During collection, this accumulates objects holding
178 SCM scm_weak_vectors
;
180 /* GC Statistics Keeping
182 unsigned long scm_cells_allocated
= 0;
183 long scm_mallocated
= 0;
184 unsigned long scm_gc_cells_collected
;
185 unsigned long scm_gc_malloc_collected
;
186 unsigned long scm_gc_ports_collected
;
187 unsigned long scm_gc_rt
;
188 unsigned long scm_gc_time_taken
= 0;
190 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
191 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
192 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
193 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
194 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
195 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
198 struct scm_heap_seg_data
200 /* lower and upper bounds of the segment */
201 SCM_CELLPTR bounds
[2];
203 /* address of the head-of-freelist pointer for this segment's cells.
204 All segments usually point to the same one, scm_freelist. */
207 /* number of SCM words per object in this segment */
210 /* If SEG_DATA->valid is non-zero, the conservative marking
211 functions will apply SEG_DATA->valid to the purported pointer and
212 SEG_DATA, and mark the object iff the function returns non-zero.
213 At the moment, I don't think anyone uses this. */
220 static void scm_mark_weak_vector_spines(void);
221 static scm_sizet
init_heap_seg(SCM_CELLPTR
, scm_sizet
, int, SCM
*);
222 static void alloc_some_heap(int, SCM
*);
226 /* Debugging functions. */
228 #ifdef GUILE_DEBUG_FREELIST
230 /* Return the number of the heap segment containing CELL. */
236 for (i
= 0; i
< scm_n_heap_segs
; i
++)
237 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
238 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
240 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
246 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
248 "Print debugging information about the free-list.\n"
249 "`map-free-list' is only included in GUILE_DEBUG_FREELIST builds of Guile.")
250 #define FUNC_NAME s_scm_map_free_list
252 int last_seg
= -1, count
= 0;
255 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
256 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
258 int this_seg
= which_seg (f
);
260 if (this_seg
!= last_seg
)
263 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
270 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
274 return SCM_UNSPECIFIED
;
279 /* Number of calls to SCM_NEWCELL since startup. */
280 static unsigned long scm_newcell_count
;
282 /* Search freelist for anything that isn't marked as a free cell.
283 Abort if we find something. */
285 scm_check_freelist ()
290 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
291 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
293 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
294 scm_newcell_count
, i
);
300 static int scm_debug_check_freelist
= 0;
302 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
304 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
305 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
306 "compile-time flag was selected.\n")
307 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
309 SCM_VALIDATE_BOOL_COPY (1,flag
,scm_debug_check_freelist
);
310 return SCM_UNSPECIFIED
;
316 scm_debug_newcell (void)
321 if (scm_debug_check_freelist
) {
322 scm_check_freelist ();
326 /* The rest of this is supposed to be identical to the SCM_NEWCELL
328 if (SCM_IMP (scm_freelist
))
329 new = scm_gc_for_newcell ();
333 scm_freelist
= SCM_CDR (scm_freelist
);
334 SCM_SETCAR (new, scm_tc16_allocated
);
335 ++scm_cells_allocated
;
341 #endif /* GUILE_DEBUG_FREELIST */
345 /* {Scheme Interface to GC}
348 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
350 "Returns an association list of statistics about Guile's current use of storage. ")
351 #define FUNC_NAME s_scm_gc_stats
356 SCM local_scm_mtrigger
;
357 SCM local_scm_mallocated
;
358 SCM local_scm_heap_size
;
359 SCM local_scm_cells_allocated
;
360 SCM local_scm_gc_time_taken
;
368 for (i
= scm_n_heap_segs
; i
--; )
369 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
370 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
372 if (scm_n_heap_segs
!= n
)
376 local_scm_mtrigger
= scm_mtrigger
;
377 local_scm_mallocated
= scm_mallocated
;
378 local_scm_heap_size
= scm_heap_size
;
379 local_scm_cells_allocated
= scm_cells_allocated
;
380 local_scm_gc_time_taken
= scm_gc_time_taken
;
382 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
383 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
384 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
385 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
386 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
387 scm_cons (sym_heap_segments
, heap_segs
),
396 scm_gc_start (const char *what
)
398 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
399 scm_gc_cells_collected
= 0;
400 scm_gc_malloc_collected
= 0;
401 scm_gc_ports_collected
= 0;
407 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
408 scm_gc_time_taken
= scm_gc_time_taken
+ scm_gc_rt
;
409 scm_system_async_mark (scm_gc_async
);
413 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
415 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
416 "returned by this function for @var{obj}")
417 #define FUNC_NAME s_scm_object_address
419 return scm_ulong2num ((unsigned long)obj
);
424 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
426 "Scans all of SCM objects and reclaims for further use those that are\n"
427 "no longer accessible.")
428 #define FUNC_NAME s_scm_gc
433 return SCM_UNSPECIFIED
;
439 /* {C Interface For When GC is Triggered}
443 scm_gc_for_alloc (int ncells
, SCM
*freelistp
)
447 if ((scm_gc_cells_collected
< MIN_GC_YIELD
) || SCM_IMP (*freelistp
))
449 alloc_some_heap (ncells
, freelistp
);
456 scm_gc_for_newcell ()
459 scm_gc_for_alloc (1, &scm_freelist
);
461 scm_freelist
= SCM_CDR (fl
);
462 SCM_SETCAR(fl
, scm_tc16_allocated
);
467 scm_igc (const char *what
)
472 /* During the critical section, only the current thread may run. */
473 SCM_THREAD_CRITICAL_SECTION_START
;
476 /* fprintf (stderr, "gc: %s\n", what); */
480 if (!scm_stack_base
|| scm_block_gc
)
486 if (scm_mallocated
< 0)
487 /* The byte count of allocated objects has underflowed. This is
488 probably because you forgot to report the sizes of objects you
489 have allocated, by calling scm_done_malloc or some such. When
490 the GC freed them, it subtracted their size from
491 scm_mallocated, which underflowed. */
494 if (scm_gc_heap_lock
)
495 /* We've invoked the collector while a GC is already in progress.
496 That should never happen. */
501 scm_weak_vectors
= SCM_EOL
;
503 scm_guardian_gc_init ();
505 /* unprotect any struct types with no instances */
511 pos
= &scm_type_obj_list
;
512 type_list
= scm_type_obj_list
;
513 while (type_list
!= SCM_EOL
)
514 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
516 pos
= SCM_CDRLOC (type_list
);
517 type_list
= SCM_CDR (type_list
);
521 *pos
= SCM_CDR (type_list
);
522 type_list
= SCM_CDR (type_list
);
527 /* flush dead entries from the continuation stack */
532 elts
= SCM_VELTS (scm_continuation_stack
);
533 bound
= SCM_LENGTH (scm_continuation_stack
);
534 x
= SCM_INUM (scm_continuation_stack_ptr
);
537 elts
[x
] = SCM_BOOL_F
;
544 /* Protect from the C stack. This must be the first marking
545 * done because it provides information about what objects
546 * are "in-use" by the C code. "in-use" objects are those
547 * for which the values from SCM_LENGTH and SCM_CHARS must remain
548 * usable. This requirement is stricter than a liveness
549 * requirement -- in particular, it constrains the implementation
550 * of scm_vector_set_length_x.
552 SCM_FLUSH_REGISTER_WINDOWS
;
553 /* This assumes that all registers are saved into the jmp_buf */
554 setjmp (scm_save_regs_gc_mark
);
555 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
556 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
557 sizeof scm_save_regs_gc_mark
)
558 / sizeof (SCM_STACKITEM
)));
561 /* stack_len is long rather than scm_sizet in order to guarantee that
562 &stack_len is long aligned */
563 #ifdef SCM_STACK_GROWS_UP
565 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
567 long stack_len
= scm_stack_size (scm_stack_base
);
569 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
572 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
574 long stack_len
= scm_stack_size (scm_stack_base
);
576 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
580 #else /* USE_THREADS */
582 /* Mark every thread's stack and registers */
583 scm_threads_mark_stacks();
585 #endif /* USE_THREADS */
587 /* FIXME: insert a phase to un-protect string-data preserved
588 * in scm_vector_set_length_x.
591 j
= SCM_NUM_PROTECTS
;
593 scm_gc_mark (scm_sys_protects
[j
]);
595 /* FIXME: we should have a means to register C functions to be run
596 * in different phases of GC
598 scm_mark_subr_table ();
601 scm_gc_mark (scm_root
->handle
);
604 scm_mark_weak_vector_spines ();
606 scm_guardian_zombify ();
614 SCM_THREAD_CRITICAL_SECTION_END
;
624 /* Mark an object precisely.
639 if (SCM_NCELLP (ptr
))
640 scm_wta (ptr
, "rogue pointer in heap", NULL
);
642 switch (SCM_TYP7 (ptr
))
644 case scm_tcs_cons_nimcar
:
645 if (SCM_GCMARKP (ptr
))
648 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
653 scm_gc_mark (SCM_CAR (ptr
));
654 ptr
= SCM_GCCDR (ptr
);
656 case scm_tcs_cons_imcar
:
658 if (SCM_GCMARKP (ptr
))
661 ptr
= SCM_GCCDR (ptr
);
663 case scm_tcs_cons_gloc
:
664 if (SCM_GCMARKP (ptr
))
669 vcell
= SCM_CAR (ptr
) - 1L;
670 switch (SCM_CDR (vcell
))
674 ptr
= SCM_GCCDR (ptr
);
686 vtable_data
= (SCM
*)vcell
;
687 layout
= vtable_data
[scm_vtable_index_layout
];
688 len
= SCM_LENGTH (layout
);
689 fields_desc
= SCM_CHARS (layout
);
690 /* We're using SCM_GCCDR here like STRUCT_DATA, except
691 that it removes the mark */
692 mem
= (SCM
*)SCM_GCCDR (ptr
);
694 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
696 scm_gc_mark (mem
[scm_struct_i_procedure
]);
697 scm_gc_mark (mem
[scm_struct_i_setter
]);
701 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
702 if (fields_desc
[x
] == 'p')
704 if (fields_desc
[x
] == 'p')
706 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
707 for (x
= *mem
; x
; --x
)
708 scm_gc_mark (*++mem
);
713 if (!SCM_CDR (vcell
))
715 SCM_SETGCMARK (vcell
);
716 ptr
= vtable_data
[scm_vtable_index_vtable
];
723 case scm_tcs_closures
:
724 if (SCM_GCMARKP (ptr
))
727 if (SCM_IMP (SCM_CDR (ptr
)))
729 ptr
= SCM_CLOSCAR (ptr
);
732 scm_gc_mark (SCM_CLOSCAR (ptr
));
733 ptr
= SCM_GCCDR (ptr
);
736 case scm_tc7_lvector
:
740 if (SCM_GC8MARKP (ptr
))
742 SCM_SETGC8MARK (ptr
);
743 i
= SCM_LENGTH (ptr
);
747 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
748 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
749 ptr
= SCM_VELTS (ptr
)[0];
754 SCM_SETGC8MARK (ptr
);
756 scm_mark_locations (SCM_VELTS (ptr
),
759 (sizeof (SCM_STACKITEM
) + -1 +
760 sizeof (scm_contregs
)) /
761 sizeof (SCM_STACKITEM
)));
772 #ifdef HAVE_LONG_LONGS
777 SCM_SETGC8MARK (ptr
);
780 case scm_tc7_substring
:
781 if (SCM_GC8MARKP(ptr
))
783 SCM_SETGC8MARK (ptr
);
788 if (SCM_GC8MARKP(ptr
))
790 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
791 scm_weak_vectors
= ptr
;
792 SCM_SETGC8MARK (ptr
);
793 if (SCM_IS_WHVEC_ANY (ptr
))
800 len
= SCM_LENGTH (ptr
);
801 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
802 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
804 for (x
= 0; x
< len
; ++x
)
807 alist
= SCM_VELTS (ptr
)[x
];
809 /* mark everything on the alist except the keys or
810 * values, according to weak_values and weak_keys. */
811 while ( SCM_CONSP (alist
)
812 && !SCM_GCMARKP (alist
)
813 && SCM_CONSP (SCM_CAR (alist
)))
818 kvpair
= SCM_CAR (alist
);
819 next_alist
= SCM_CDR (alist
);
822 * SCM_SETGCMARK (alist);
823 * SCM_SETGCMARK (kvpair);
825 * It may be that either the key or value is protected by
826 * an escaped reference to part of the spine of this alist.
827 * If we mark the spine here, and only mark one or neither of the
828 * key and value, they may never be properly marked.
829 * This leads to a horrible situation in which an alist containing
830 * freelist cells is exported.
832 * So only mark the spines of these arrays last of all marking.
833 * If somebody confuses us by constructing a weak vector
834 * with a circular alist then we are hosed, but at least we
835 * won't prematurely drop table entries.
838 scm_gc_mark (SCM_CAR (kvpair
));
840 scm_gc_mark (SCM_GCCDR (kvpair
));
843 if (SCM_NIMP (alist
))
849 case scm_tc7_msymbol
:
850 if (SCM_GC8MARKP(ptr
))
852 SCM_SETGC8MARK (ptr
);
853 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
854 ptr
= SCM_SYMBOL_PROPS (ptr
);
856 case scm_tc7_ssymbol
:
857 if (SCM_GC8MARKP(ptr
))
859 SCM_SETGC8MARK (ptr
);
864 i
= SCM_PTOBNUM (ptr
);
865 if (!(i
< scm_numptob
))
867 if (SCM_GC8MARKP (ptr
))
869 SCM_SETGC8MARK (ptr
);
870 if (SCM_PTAB_ENTRY(ptr
))
871 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
872 if (scm_ptobs
[i
].mark
)
874 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
881 if (SCM_GC8MARKP (ptr
))
883 SCM_SETGC8MARK (ptr
);
884 switch SCM_GCTYP16 (ptr
)
885 { /* should be faster than going through scm_smobs */
886 case scm_tc_free_cell
:
887 /* printf("found free_cell %X ", ptr); fflush(stdout); */
889 case scm_tc16_allocated
:
890 SCM_SETGC8MARK (ptr
);
892 case scm_tcs_bignums
:
896 i
= SCM_SMOBNUM (ptr
);
897 if (!(i
< scm_numsmob
))
899 if (scm_smobs
[i
].mark
)
901 ptr
= (scm_smobs
[i
].mark
) (ptr
);
909 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
914 /* Mark a Region Conservatively
918 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
922 register SCM_CELLPTR ptr
;
925 if SCM_CELLP (*(SCM
**) & x
[m
])
927 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
929 j
= scm_n_heap_segs
- 1;
930 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
931 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
938 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
940 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
948 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
952 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
957 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
961 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
967 if ( !scm_heap_table
[seg_id
].valid
968 || scm_heap_table
[seg_id
].valid (ptr
,
969 &scm_heap_table
[seg_id
]))
970 scm_gc_mark (*(SCM
*) & x
[m
]);
979 /* The following is a C predicate which determines if an SCM value can be
980 regarded as a pointer to a cell on the heap. The code is duplicated
981 from scm_mark_locations. */
985 scm_cellp (SCM value
)
988 register SCM_CELLPTR ptr
;
990 if SCM_CELLP (*(SCM
**) & value
)
992 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
994 j
= scm_n_heap_segs
- 1;
995 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
996 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1003 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1005 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1013 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1017 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1022 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1026 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1032 if ( !scm_heap_table
[seg_id
].valid
1033 || scm_heap_table
[seg_id
].valid (ptr
,
1034 &scm_heap_table
[seg_id
]))
1046 scm_mark_weak_vector_spines ()
1050 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1052 if (SCM_IS_WHVEC_ANY (w
))
1060 ptr
= SCM_VELTS (w
);
1062 for (j
= 0; j
< n
; ++j
)
1067 while ( SCM_CONSP (alist
)
1068 && !SCM_GCMARKP (alist
)
1069 && SCM_CONSP (SCM_CAR (alist
)))
1071 SCM_SETGCMARK (alist
);
1072 SCM_SETGCMARK (SCM_CAR (alist
));
1073 alist
= SCM_GCCDR (alist
);
1085 register SCM_CELLPTR ptr
;
1086 #ifdef SCM_POINTERS_MUNGED
1087 register SCM scmptr
;
1090 #define scmptr (SCM)ptr
1092 register SCM nfreelist
;
1093 register SCM
*hp_freelist
;
1101 /* Reset all free list pointers. We'll reconstruct them completely
1103 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1104 *scm_heap_table
[i
].freelistp
= SCM_EOL
;
1106 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1108 register scm_sizet n
= 0;
1109 register scm_sizet j
;
1111 /* Unmarked cells go onto the front of the freelist this heap
1112 segment points to. Rather than updating the real freelist
1113 pointer as we go along, we accumulate the new head in
1114 nfreelist. Then, if it turns out that the entire segment is
1115 free, we free (i.e., malloc's free) the whole segment, and
1116 simply don't assign nfreelist back into the real freelist. */
1117 hp_freelist
= scm_heap_table
[i
].freelistp
;
1118 nfreelist
= *hp_freelist
;
1120 span
= scm_heap_table
[i
].ncells
;
1121 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1122 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1123 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1125 #ifdef SCM_POINTERS_MUNGED
1126 scmptr
= PTR2SCM (ptr
);
1128 switch SCM_TYP7 (scmptr
)
1130 case scm_tcs_cons_gloc
:
1131 if (SCM_GCMARKP (scmptr
))
1133 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1134 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1139 vcell
= SCM_CAR (scmptr
) - 1L;
1141 if ((SCM_CDR (vcell
) == 0) || (SCM_CDR (vcell
) == 1))
1143 scm_struct_free_t free
1144 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1145 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1149 case scm_tcs_cons_imcar
:
1150 case scm_tcs_cons_nimcar
:
1151 case scm_tcs_closures
:
1153 if (SCM_GCMARKP (scmptr
))
1157 if (SCM_GC8MARKP (scmptr
))
1163 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1164 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1168 case scm_tc7_vector
:
1169 case scm_tc7_lvector
:
1173 if (SCM_GC8MARKP (scmptr
))
1176 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1178 scm_must_free (SCM_CHARS (scmptr
));
1179 /* SCM_SETCHARS(scmptr, 0);*/
1183 if SCM_GC8MARKP (scmptr
)
1185 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1187 case scm_tc7_byvect
:
1188 if SCM_GC8MARKP (scmptr
)
1190 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1194 if SCM_GC8MARKP (scmptr
)
1196 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1199 if SCM_GC8MARKP (scmptr
)
1201 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1203 #ifdef HAVE_LONG_LONGS
1204 case scm_tc7_llvect
:
1205 if SCM_GC8MARKP (scmptr
)
1207 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1211 if SCM_GC8MARKP (scmptr
)
1213 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1216 if SCM_GC8MARKP (scmptr
)
1218 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1221 if SCM_GC8MARKP (scmptr
)
1223 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1226 case scm_tc7_substring
:
1227 if (SCM_GC8MARKP (scmptr
))
1230 case scm_tc7_string
:
1231 if (SCM_GC8MARKP (scmptr
))
1233 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1235 case scm_tc7_msymbol
:
1236 if (SCM_GC8MARKP (scmptr
))
1238 m
+= ( SCM_LENGTH (scmptr
)
1240 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1241 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1243 case scm_tc7_contin
:
1244 if SCM_GC8MARKP (scmptr
)
1246 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1247 if (SCM_VELTS (scmptr
))
1249 case scm_tc7_ssymbol
:
1250 if SCM_GC8MARKP(scmptr
)
1256 if SCM_GC8MARKP (scmptr
)
1258 if SCM_OPENP (scmptr
)
1260 int k
= SCM_PTOBNUM (scmptr
);
1261 if (!(k
< scm_numptob
))
1263 /* Keep "revealed" ports alive. */
1264 if (scm_revealed_count(scmptr
) > 0)
1266 /* Yes, I really do mean scm_ptobs[k].free */
1267 /* rather than ftobs[k].close. .close */
1268 /* is for explicit CLOSE-PORT by user */
1269 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1270 SCM_SETSTREAM (scmptr
, 0);
1271 scm_remove_from_port_table (scmptr
);
1272 scm_gc_ports_collected
++;
1273 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1277 switch SCM_GCTYP16 (scmptr
)
1279 case scm_tc_free_cell
:
1280 if SCM_GC8MARKP (scmptr
)
1284 case scm_tcs_bignums
:
1285 if SCM_GC8MARKP (scmptr
)
1287 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1289 #endif /* def SCM_BIGDIG */
1291 if SCM_GC8MARKP (scmptr
)
1293 switch ((int) (SCM_CAR (scmptr
) >> 16))
1295 case (SCM_IMAG_PART
| SCM_REAL_PART
) >> 16:
1296 m
+= sizeof (double);
1297 case SCM_REAL_PART
>> 16:
1298 case SCM_IMAG_PART
>> 16:
1299 m
+= sizeof (double);
1308 if SCM_GC8MARKP (scmptr
)
1313 k
= SCM_SMOBNUM (scmptr
);
1314 if (!(k
< scm_numsmob
))
1316 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1322 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1326 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1329 /* Stick the new cell on the front of nfreelist. It's
1330 critical that we mark this cell as freed; otherwise, the
1331 conservative collector might trace it as some other type
1333 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1334 SCM_SETCDR (scmptr
, nfreelist
);
1339 SCM_CLRGC8MARK (scmptr
);
1342 SCM_CLRGCMARK (scmptr
);
1344 #ifdef GC_FREE_SEGMENTS
1349 scm_heap_size
-= seg_size
;
1350 free ((char *) scm_heap_table
[i
].bounds
[0]);
1351 scm_heap_table
[i
].bounds
[0] = 0;
1352 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1353 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1354 scm_n_heap_segs
-= 1;
1355 i
--; /* We need to scan the segment just moved. */
1358 #endif /* ifdef GC_FREE_SEGMENTS */
1359 /* Update the real freelist pointer to point to the head of
1360 the list of free cells we've built for this segment. */
1361 *hp_freelist
= nfreelist
;
1363 #ifdef GUILE_DEBUG_FREELIST
1364 scm_check_freelist ();
1365 scm_map_free_list ();
1368 scm_gc_cells_collected
+= n
;
1370 /* Scan weak vectors. */
1373 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1375 if (!SCM_IS_WHVEC_ANY (w
))
1379 ptr
= SCM_VELTS (w
);
1381 for (j
= 0; j
< n
; ++j
)
1382 if (SCM_FREEP (ptr
[j
]))
1383 ptr
[j
] = SCM_BOOL_F
;
1385 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1388 register long n
= SCM_LENGTH (w
);
1391 ptr
= SCM_VELTS (w
);
1393 for (j
= 0; j
< n
; ++j
)
1400 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1401 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1406 while ( SCM_CONSP (alist
)
1407 && SCM_CONSP (SCM_CAR (alist
)))
1412 key
= SCM_CAAR (alist
);
1413 value
= SCM_CDAR (alist
);
1414 if ( (weak_keys
&& SCM_FREEP (key
))
1415 || (weak_values
&& SCM_FREEP (value
)))
1417 *fixup
= SCM_CDR (alist
);
1420 fixup
= SCM_CDRLOC (alist
);
1421 alist
= SCM_CDR (alist
);
1427 scm_cells_allocated
= (scm_heap_size
- scm_gc_cells_collected
);
1428 scm_mallocated
-= m
;
1429 scm_gc_malloc_collected
= m
;
1435 /* {Front end to malloc}
1437 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1439 * These functions provide services comperable to malloc, realloc, and
1440 * free. They are for allocating malloced parts of scheme objects.
1441 * The primary purpose of the front end is to impose calls to gc.
1445 * Return newly malloced storage or throw an error.
1447 * The parameter WHAT is a string for error reporting.
1448 * If the threshold scm_mtrigger will be passed by this
1449 * allocation, or if the first call to malloc fails,
1450 * garbage collect -- on the presumption that some objects
1451 * using malloced storage may be collected.
1453 * The limit scm_mtrigger may be raised by this allocation.
1456 scm_must_malloc (scm_sizet size
, const char *what
)
1459 unsigned long nm
= scm_mallocated
+ size
;
1461 if (nm
<= scm_mtrigger
)
1463 SCM_SYSCALL (ptr
= malloc (size
));
1466 scm_mallocated
= nm
;
1473 nm
= scm_mallocated
+ size
;
1474 SCM_SYSCALL (ptr
= malloc (size
));
1477 scm_mallocated
= nm
;
1478 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1479 if (nm
> scm_mtrigger
)
1480 scm_mtrigger
= nm
+ nm
/ 2;
1482 scm_mtrigger
+= scm_mtrigger
/ 2;
1487 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1488 return 0; /* never reached */
1493 * is similar to scm_must_malloc.
1496 scm_must_realloc (void *where
,
1502 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1504 if (nm
<= scm_mtrigger
)
1506 SCM_SYSCALL (ptr
= realloc (where
, size
));
1509 scm_mallocated
= nm
;
1516 nm
= scm_mallocated
+ size
- old_size
;
1517 SCM_SYSCALL (ptr
= realloc (where
, size
));
1520 scm_mallocated
= nm
;
1521 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1522 if (nm
> scm_mtrigger
)
1523 scm_mtrigger
= nm
+ nm
/ 2;
1525 scm_mtrigger
+= scm_mtrigger
/ 2;
1530 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1531 return 0; /* never reached */
1535 scm_must_free (void *obj
)
1540 scm_wta (SCM_INUM0
, "already free", "");
1543 /* Announce that there has been some malloc done that will be freed
1544 * during gc. A typical use is for a smob that uses some malloced
1545 * memory but can not get it from scm_must_malloc (for whatever
1546 * reason). When a new object of this smob is created you call
1547 * scm_done_malloc with the size of the object. When your smob free
1548 * function is called, be sure to include this size in the return
1552 scm_done_malloc (long size
)
1554 scm_mallocated
+= size
;
1556 if (scm_mallocated
> scm_mtrigger
)
1558 scm_igc ("foreign mallocs");
1559 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1561 if (scm_mallocated
> scm_mtrigger
)
1562 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1564 scm_mtrigger
+= scm_mtrigger
/ 2;
1574 * Each heap segment is an array of objects of a particular size.
1575 * Every segment has an associated (possibly shared) freelist.
1576 * A table of segment records is kept that records the upper and
1577 * lower extents of the segment; this is used during the conservative
1578 * phase of gc to identify probably gc roots (because they point
1579 * into valid segments at reasonable offsets). */
1582 * is true if the first segment was smaller than INIT_HEAP_SEG.
1583 * If scm_expmem is set to one, subsequent segment allocations will
1584 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1589 * is the lowest base address of any heap segment.
1591 SCM_CELLPTR scm_heap_org
;
1593 struct scm_heap_seg_data
* scm_heap_table
= 0;
1594 int scm_n_heap_segs
= 0;
1597 * is the total number of cells in heap segments.
1599 unsigned long scm_heap_size
= 0;
1602 * initializes a new heap segment and return the number of objects it contains.
1604 * The segment origin, segment size in bytes, and the span of objects
1605 * in cells are input parameters. The freelist is both input and output.
1607 * This function presume that the scm_heap_table has already been expanded
1608 * to accomodate a new segment record.
1613 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, int ncells
, SCM
*freelistp
)
1615 register SCM_CELLPTR ptr
;
1616 #ifdef SCM_POINTERS_MUNGED
1617 register SCM scmptr
;
1622 SCM_CELLPTR seg_end
;
1626 if (seg_org
== NULL
)
1631 /* Compute the ceiling on valid object pointers w/in this segment.
1633 seg_end
= CELL_DN ((char *) ptr
+ size
);
1635 /* Find the right place and insert the segment record.
1638 for (new_seg_index
= 0;
1639 ( (new_seg_index
< scm_n_heap_segs
)
1640 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1646 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1647 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1652 scm_heap_table
[new_seg_index
].valid
= 0;
1653 scm_heap_table
[new_seg_index
].ncells
= ncells
;
1654 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1655 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1656 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1659 /* Compute the least valid object pointer w/in this segment
1661 ptr
= CELL_UP (ptr
);
1664 n_new_objects
= seg_end
- ptr
;
1666 /* Prepend objects in this segment to the freelist.
1668 while (ptr
< seg_end
)
1670 #ifdef SCM_POINTERS_MUNGED
1671 scmptr
= PTR2SCM (ptr
);
1673 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1674 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ ncells
));
1680 /* Patch up the last freelist pointer in the segment
1681 * to join it to the input freelist.
1683 SCM_SETCDR (PTR2SCM (ptr
), *freelistp
);
1684 *freelistp
= PTR2SCM (CELL_UP (seg_org
));
1686 scm_heap_size
+= (ncells
* n_new_objects
);
1695 alloc_some_heap (int ncells
, SCM
*freelistp
)
1697 struct scm_heap_seg_data
* tmptable
;
1701 /* Critical code sections (such as the garbage collector)
1702 * aren't supposed to add heap segments.
1704 if (scm_gc_heap_lock
)
1705 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1707 /* Expand the heap tables to have room for the new segment.
1708 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1709 * only if the allocation of the segment itself succeeds.
1711 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
1713 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
1714 realloc ((char *)scm_heap_table
, len
)));
1716 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1718 scm_heap_table
= tmptable
;
1721 /* Pick a size for the new heap segment.
1722 * The rule for picking the size of a segment is explained in
1727 len
= (scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
));
1728 if ((scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
)) != len
)
1732 len
= SCM_HEAP_SEG_SIZE
;
1737 smallest
= (ncells
* sizeof (scm_cell
));
1739 len
= (ncells
* sizeof (scm_cell
));
1741 /* Allocate with decaying ambition. */
1742 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
1743 && (len
>= smallest
))
1745 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
1748 init_heap_seg (ptr
, len
, ncells
, freelistp
);
1755 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
1760 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
1763 #define FUNC_NAME s_scm_unhash_name
1767 SCM_VALIDATE_SYMBOL (1,name
);
1769 bound
= scm_n_heap_segs
;
1770 for (x
= 0; x
< bound
; ++x
)
1774 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
1775 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
1780 if (1 == (7 & (int)incar
))
1783 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
1784 && (SCM_CDR (incar
) != 0)
1785 && (SCM_CDR (incar
) != 1))
1800 /* {GC Protection Helper Functions}
1805 scm_remember (SCM
*ptr
)
1810 scm_return_first (SCM elt
, ...)
1817 scm_permanent_object (SCM obj
)
1820 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
1826 /* Protect OBJ from the garbage collector. OBJ will not be freed,
1827 even if all other references are dropped, until someone applies
1828 scm_unprotect_object to it. This function returns OBJ.
1830 Calls to scm_protect_object nest. For every object O, there is a
1831 counter which scm_protect_object(O) increments and
1832 scm_unprotect_object(O) decrements, if it is greater than zero. If
1833 an object's counter is greater than zero, the garbage collector
1836 Of course, that's not how it's implemented. scm_protect_object and
1837 scm_unprotect_object just maintain a list of references to things.
1838 Since the GC knows about this list, all objects it mentions stay
1839 alive. scm_protect_object adds its argument to the list;
1840 scm_unprotect_object removes the first occurrence of its argument
1843 scm_protect_object (SCM obj
)
1845 scm_protects
= scm_cons (obj
, scm_protects
);
1851 /* Remove any protection for OBJ established by a prior call to
1852 scm_protect_object. This function returns OBJ.
1854 See scm_protect_object for more information. */
1856 scm_unprotect_object (SCM obj
)
1858 SCM
*tail_ptr
= &scm_protects
;
1860 while (SCM_CONSP (*tail_ptr
))
1861 if (SCM_CAR (*tail_ptr
) == obj
)
1863 *tail_ptr
= SCM_CDR (*tail_ptr
);
1867 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
1874 /* called on process termination. */
1880 extern int on_exit (void (*procp
) (), int arg
);
1883 cleanup (int status
, void *arg
)
1885 #error Dont know how to setup a cleanup handler on your system.
1890 scm_flush_all_ports ();
1895 scm_init_storage (scm_sizet init_heap_size
)
1899 j
= SCM_NUM_PROTECTS
;
1901 scm_sys_protects
[--j
] = SCM_BOOL_F
;
1903 scm_freelist
= SCM_EOL
;
1906 j
= SCM_HEAP_SEG_SIZE
;
1907 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
1908 scm_heap_table
= ((struct scm_heap_seg_data
*)
1909 scm_must_malloc (sizeof (struct scm_heap_seg_data
), "hplims"));
1910 if (0L == init_heap_size
)
1911 init_heap_size
= SCM_INIT_HEAP_SIZE
;
1913 if ((init_heap_size
!= j
)
1914 || !init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1916 j
= SCM_HEAP_SEG_SIZE
;
1917 if (!init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1922 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
1923 /* scm_hplims[0] can change. do not remove scm_heap_org */
1924 scm_weak_vectors
= SCM_EOL
;
1926 /* Initialise the list of ports. */
1927 scm_port_table
= (scm_port
**)
1928 malloc (sizeof (scm_port
*) * scm_port_table_room
);
1929 if (!scm_port_table
)
1936 on_exit (cleanup
, 0);
1940 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
1941 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
1943 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
1944 scm_nullstr
= scm_makstr (0L, 0);
1945 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
1946 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1947 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
1948 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1949 scm_stand_in_procs
= SCM_EOL
;
1950 scm_permobjs
= SCM_EOL
;
1951 scm_protects
= SCM_EOL
;
1952 scm_asyncs
= SCM_EOL
;
1953 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
1954 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
1956 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));