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 GUILE_PROC (scm_map_free_list
, "map-free-list", 0, 0, 0,
249 #define FUNC_NAME s_scm_map_free_list
251 int last_seg
= -1, count
= 0;
254 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
255 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
257 int this_seg
= which_seg (f
);
259 if (this_seg
!= last_seg
)
262 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
269 fprintf (stderr
, " %5d cells in segment %d\n", count
, last_seg
);
273 return SCM_UNSPECIFIED
;
278 /* Number of calls to SCM_NEWCELL since startup. */
279 static unsigned long scm_newcell_count
;
281 /* Search freelist for anything that isn't marked as a free cell.
282 Abort if we find something. */
284 scm_check_freelist ()
289 for (f
= scm_freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
290 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
292 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
293 scm_newcell_count
, i
);
299 static int scm_debug_check_freelist
= 0;
301 GUILE_PROC (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
304 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
306 SCM_VALIDATE_BOOL_COPY(1,flag
,scm_debug_check_freelist
);
307 return SCM_UNSPECIFIED
;
313 scm_debug_newcell (void)
318 if (scm_debug_check_freelist
) {
319 scm_check_freelist ();
323 /* The rest of this is supposed to be identical to the SCM_NEWCELL
325 if (SCM_IMP (scm_freelist
))
326 new = scm_gc_for_newcell ();
330 scm_freelist
= SCM_CDR (scm_freelist
);
331 SCM_SETCAR (new, scm_tc16_allocated
);
332 ++scm_cells_allocated
;
338 #endif /* GUILE_DEBUG_FREELIST */
342 /* {Scheme Interface to GC}
345 GUILE_PROC (scm_gc_stats
, "gc-stats", 0, 0, 0,
347 "Returns an association list of statistics about Guile's current use of storage. ")
348 #define FUNC_NAME s_scm_gc_stats
353 SCM local_scm_mtrigger
;
354 SCM local_scm_mallocated
;
355 SCM local_scm_heap_size
;
356 SCM local_scm_cells_allocated
;
357 SCM local_scm_gc_time_taken
;
365 for (i
= scm_n_heap_segs
; i
--; )
366 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
367 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
369 if (scm_n_heap_segs
!= n
)
373 local_scm_mtrigger
= scm_mtrigger
;
374 local_scm_mallocated
= scm_mallocated
;
375 local_scm_heap_size
= scm_heap_size
;
376 local_scm_cells_allocated
= scm_cells_allocated
;
377 local_scm_gc_time_taken
= scm_gc_time_taken
;
379 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
380 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
381 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
382 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
383 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
384 scm_cons (sym_heap_segments
, heap_segs
),
393 scm_gc_start (const char *what
)
395 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
396 scm_gc_cells_collected
= 0;
397 scm_gc_malloc_collected
= 0;
398 scm_gc_ports_collected
= 0;
404 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
405 scm_gc_time_taken
= scm_gc_time_taken
+ scm_gc_rt
;
406 scm_system_async_mark (scm_gc_async
);
410 GUILE_PROC (scm_object_address
, "object-address", 1, 0, 0,
412 "Return an integer that for the lifetime of @var{obj} is uniquely
413 returned by this function for @var{obj}")
414 #define FUNC_NAME s_scm_object_address
416 return scm_ulong2num ((unsigned long)obj
);
421 GUILE_PROC(scm_gc
, "gc", 0, 0, 0,
423 "Scans all of SCM objects and reclaims for further use those that are
424 no longer accessible.")
425 #define FUNC_NAME s_scm_gc
430 return SCM_UNSPECIFIED
;
436 /* {C Interface For When GC is Triggered}
440 scm_gc_for_alloc (int ncells
, SCM
*freelistp
)
444 if ((scm_gc_cells_collected
< MIN_GC_YIELD
) || SCM_IMP (*freelistp
))
446 alloc_some_heap (ncells
, freelistp
);
453 scm_gc_for_newcell ()
456 scm_gc_for_alloc (1, &scm_freelist
);
458 scm_freelist
= SCM_CDR (fl
);
459 SCM_SETCAR(fl
, scm_tc16_allocated
);
464 scm_igc (const char *what
)
469 /* During the critical section, only the current thread may run. */
470 SCM_THREAD_CRITICAL_SECTION_START
;
473 /* fprintf (stderr, "gc: %s\n", what); */
477 if (!scm_stack_base
|| scm_block_gc
)
483 if (scm_mallocated
< 0)
484 /* The byte count of allocated objects has underflowed. This is
485 probably because you forgot to report the sizes of objects you
486 have allocated, by calling scm_done_malloc or some such. When
487 the GC freed them, it subtracted their size from
488 scm_mallocated, which underflowed. */
491 if (scm_gc_heap_lock
)
492 /* We've invoked the collector while a GC is already in progress.
493 That should never happen. */
498 scm_weak_vectors
= SCM_EOL
;
500 scm_guardian_gc_init ();
502 /* unprotect any struct types with no instances */
508 pos
= &scm_type_obj_list
;
509 type_list
= scm_type_obj_list
;
510 while (type_list
!= SCM_EOL
)
511 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
513 pos
= SCM_CDRLOC (type_list
);
514 type_list
= SCM_CDR (type_list
);
518 *pos
= SCM_CDR (type_list
);
519 type_list
= SCM_CDR (type_list
);
524 /* flush dead entries from the continuation stack */
529 elts
= SCM_VELTS (scm_continuation_stack
);
530 bound
= SCM_LENGTH (scm_continuation_stack
);
531 x
= SCM_INUM (scm_continuation_stack_ptr
);
534 elts
[x
] = SCM_BOOL_F
;
541 /* Protect from the C stack. This must be the first marking
542 * done because it provides information about what objects
543 * are "in-use" by the C code. "in-use" objects are those
544 * for which the values from SCM_LENGTH and SCM_CHARS must remain
545 * usable. This requirement is stricter than a liveness
546 * requirement -- in particular, it constrains the implementation
547 * of scm_vector_set_length_x.
549 SCM_FLUSH_REGISTER_WINDOWS
;
550 /* This assumes that all registers are saved into the jmp_buf */
551 setjmp (scm_save_regs_gc_mark
);
552 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
553 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
554 sizeof scm_save_regs_gc_mark
)
555 / sizeof (SCM_STACKITEM
)));
558 /* stack_len is long rather than scm_sizet in order to guarantee that
559 &stack_len is long aligned */
560 #ifdef SCM_STACK_GROWS_UP
562 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
564 long stack_len
= scm_stack_size (scm_stack_base
);
566 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
569 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
571 long stack_len
= scm_stack_size (scm_stack_base
);
573 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
577 #else /* USE_THREADS */
579 /* Mark every thread's stack and registers */
580 scm_threads_mark_stacks();
582 #endif /* USE_THREADS */
584 /* FIXME: insert a phase to un-protect string-data preserved
585 * in scm_vector_set_length_x.
588 j
= SCM_NUM_PROTECTS
;
590 scm_gc_mark (scm_sys_protects
[j
]);
592 /* FIXME: we should have a means to register C functions to be run
593 * in different phases of GC
595 scm_mark_subr_table ();
598 scm_gc_mark (scm_root
->handle
);
601 scm_mark_weak_vector_spines ();
603 scm_guardian_zombify ();
611 SCM_THREAD_CRITICAL_SECTION_END
;
621 /* Mark an object precisely.
636 if (SCM_NCELLP (ptr
))
637 scm_wta (ptr
, "rogue pointer in heap", NULL
);
639 switch (SCM_TYP7 (ptr
))
641 case scm_tcs_cons_nimcar
:
642 if (SCM_GCMARKP (ptr
))
645 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
650 scm_gc_mark (SCM_CAR (ptr
));
651 ptr
= SCM_GCCDR (ptr
);
653 case scm_tcs_cons_imcar
:
655 if (SCM_GCMARKP (ptr
))
658 ptr
= SCM_GCCDR (ptr
);
660 case scm_tcs_cons_gloc
:
661 if (SCM_GCMARKP (ptr
))
666 vcell
= SCM_CAR (ptr
) - 1L;
667 switch (SCM_CDR (vcell
))
671 ptr
= SCM_GCCDR (ptr
);
683 vtable_data
= (SCM
*)vcell
;
684 layout
= vtable_data
[scm_vtable_index_layout
];
685 len
= SCM_LENGTH (layout
);
686 fields_desc
= SCM_CHARS (layout
);
687 /* We're using SCM_GCCDR here like STRUCT_DATA, except
688 that it removes the mark */
689 mem
= (SCM
*)SCM_GCCDR (ptr
);
691 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
693 scm_gc_mark (mem
[scm_struct_i_procedure
]);
694 scm_gc_mark (mem
[scm_struct_i_setter
]);
698 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
699 if (fields_desc
[x
] == 'p')
701 if (fields_desc
[x
] == 'p')
703 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
704 for (x
= *mem
; x
; --x
)
705 scm_gc_mark (*++mem
);
710 if (!SCM_CDR (vcell
))
712 SCM_SETGCMARK (vcell
);
713 ptr
= vtable_data
[scm_vtable_index_vtable
];
720 case scm_tcs_closures
:
721 if (SCM_GCMARKP (ptr
))
724 if (SCM_IMP (SCM_CDR (ptr
)))
726 ptr
= SCM_CLOSCAR (ptr
);
729 scm_gc_mark (SCM_CLOSCAR (ptr
));
730 ptr
= SCM_GCCDR (ptr
);
733 case scm_tc7_lvector
:
737 if (SCM_GC8MARKP (ptr
))
739 SCM_SETGC8MARK (ptr
);
740 i
= SCM_LENGTH (ptr
);
744 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
745 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
746 ptr
= SCM_VELTS (ptr
)[0];
751 SCM_SETGC8MARK (ptr
);
753 scm_mark_locations (SCM_VELTS (ptr
),
756 (sizeof (SCM_STACKITEM
) + -1 +
757 sizeof (scm_contregs
)) /
758 sizeof (SCM_STACKITEM
)));
769 #ifdef HAVE_LONG_LONGS
774 SCM_SETGC8MARK (ptr
);
777 case scm_tc7_substring
:
778 if (SCM_GC8MARKP(ptr
))
780 SCM_SETGC8MARK (ptr
);
785 if (SCM_GC8MARKP(ptr
))
787 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
788 scm_weak_vectors
= ptr
;
789 SCM_SETGC8MARK (ptr
);
790 if (SCM_IS_WHVEC_ANY (ptr
))
797 len
= SCM_LENGTH (ptr
);
798 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
799 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
801 for (x
= 0; x
< len
; ++x
)
804 alist
= SCM_VELTS (ptr
)[x
];
806 /* mark everything on the alist except the keys or
807 * values, according to weak_values and weak_keys. */
808 while ( SCM_NIMP (alist
)
810 && !SCM_GCMARKP (alist
)
811 && SCM_NIMP (SCM_CAR (alist
))
812 && SCM_CONSP (SCM_CAR (alist
)))
817 kvpair
= SCM_CAR (alist
);
818 next_alist
= SCM_CDR (alist
);
821 * SCM_SETGCMARK (alist);
822 * SCM_SETGCMARK (kvpair);
824 * It may be that either the key or value is protected by
825 * an escaped reference to part of the spine of this alist.
826 * If we mark the spine here, and only mark one or neither of the
827 * key and value, they may never be properly marked.
828 * This leads to a horrible situation in which an alist containing
829 * freelist cells is exported.
831 * So only mark the spines of these arrays last of all marking.
832 * If somebody confuses us by constructing a weak vector
833 * with a circular alist then we are hosed, but at least we
834 * won't prematurely drop table entries.
837 scm_gc_mark (SCM_CAR (kvpair
));
839 scm_gc_mark (SCM_GCCDR (kvpair
));
842 if (SCM_NIMP (alist
))
848 case scm_tc7_msymbol
:
849 if (SCM_GC8MARKP(ptr
))
851 SCM_SETGC8MARK (ptr
);
852 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
853 ptr
= SCM_SYMBOL_PROPS (ptr
);
855 case scm_tc7_ssymbol
:
856 if (SCM_GC8MARKP(ptr
))
858 SCM_SETGC8MARK (ptr
);
863 i
= SCM_PTOBNUM (ptr
);
864 if (!(i
< scm_numptob
))
866 if (SCM_GC8MARKP (ptr
))
868 SCM_SETGC8MARK (ptr
);
869 if (SCM_PTAB_ENTRY(ptr
))
870 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
871 if (scm_ptobs
[i
].mark
)
873 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
880 if (SCM_GC8MARKP (ptr
))
882 SCM_SETGC8MARK (ptr
);
883 switch SCM_GCTYP16 (ptr
)
884 { /* should be faster than going through scm_smobs */
885 case scm_tc_free_cell
:
886 /* printf("found free_cell %X ", ptr); fflush(stdout); */
888 case scm_tc16_allocated
:
889 SCM_SETGC8MARK (ptr
);
891 case scm_tcs_bignums
:
895 i
= SCM_SMOBNUM (ptr
);
896 if (!(i
< scm_numsmob
))
898 if (scm_smobs
[i
].mark
)
900 ptr
= (scm_smobs
[i
].mark
) (ptr
);
908 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
913 /* Mark a Region Conservatively
917 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
921 register SCM_CELLPTR ptr
;
924 if SCM_CELLP (*(SCM
**) & x
[m
])
926 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
928 j
= scm_n_heap_segs
- 1;
929 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
930 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
937 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
939 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
947 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
951 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
956 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
960 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
966 if ( !scm_heap_table
[seg_id
].valid
967 || scm_heap_table
[seg_id
].valid (ptr
,
968 &scm_heap_table
[seg_id
]))
969 scm_gc_mark (*(SCM
*) & x
[m
]);
978 /* The following is a C predicate which determines if an SCM value can be
979 regarded as a pointer to a cell on the heap. The code is duplicated
980 from scm_mark_locations. */
984 scm_cellp (SCM value
)
987 register SCM_CELLPTR ptr
;
989 if SCM_CELLP (*(SCM
**) & value
)
991 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
993 j
= scm_n_heap_segs
- 1;
994 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
995 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1002 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1004 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1012 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1016 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1021 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1025 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1031 if ( !scm_heap_table
[seg_id
].valid
1032 || scm_heap_table
[seg_id
].valid (ptr
,
1033 &scm_heap_table
[seg_id
]))
1045 scm_mark_weak_vector_spines ()
1049 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1051 if (SCM_IS_WHVEC_ANY (w
))
1059 ptr
= SCM_VELTS (w
);
1061 for (j
= 0; j
< n
; ++j
)
1066 while ( SCM_NIMP (alist
)
1067 && SCM_CONSP (alist
)
1068 && !SCM_GCMARKP (alist
)
1069 && SCM_NIMP (SCM_CAR (alist
))
1070 && SCM_CONSP (SCM_CAR (alist
)))
1072 SCM_SETGCMARK (alist
);
1073 SCM_SETGCMARK (SCM_CAR (alist
));
1074 alist
= SCM_GCCDR (alist
);
1086 register SCM_CELLPTR ptr
;
1087 #ifdef SCM_POINTERS_MUNGED
1088 register SCM scmptr
;
1091 #define scmptr (SCM)ptr
1093 register SCM nfreelist
;
1094 register SCM
*hp_freelist
;
1102 /* Reset all free list pointers. We'll reconstruct them completely
1104 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1105 *scm_heap_table
[i
].freelistp
= SCM_EOL
;
1107 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1109 register scm_sizet n
= 0;
1110 register scm_sizet j
;
1112 /* Unmarked cells go onto the front of the freelist this heap
1113 segment points to. Rather than updating the real freelist
1114 pointer as we go along, we accumulate the new head in
1115 nfreelist. Then, if it turns out that the entire segment is
1116 free, we free (i.e., malloc's free) the whole segment, and
1117 simply don't assign nfreelist back into the real freelist. */
1118 hp_freelist
= scm_heap_table
[i
].freelistp
;
1119 nfreelist
= *hp_freelist
;
1121 span
= scm_heap_table
[i
].ncells
;
1122 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1123 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1124 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1126 #ifdef SCM_POINTERS_MUNGED
1127 scmptr
= PTR2SCM (ptr
);
1129 switch SCM_TYP7 (scmptr
)
1131 case scm_tcs_cons_gloc
:
1132 if (SCM_GCMARKP (scmptr
))
1134 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1135 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1140 vcell
= SCM_CAR (scmptr
) - 1L;
1142 if ((SCM_CDR (vcell
) == 0) || (SCM_CDR (vcell
) == 1))
1144 scm_struct_free_t free
1145 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1146 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1150 case scm_tcs_cons_imcar
:
1151 case scm_tcs_cons_nimcar
:
1152 case scm_tcs_closures
:
1154 if (SCM_GCMARKP (scmptr
))
1158 if (SCM_GC8MARKP (scmptr
))
1164 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1165 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1169 case scm_tc7_vector
:
1170 case scm_tc7_lvector
:
1174 if (SCM_GC8MARKP (scmptr
))
1177 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1179 scm_must_free (SCM_CHARS (scmptr
));
1180 /* SCM_SETCHARS(scmptr, 0);*/
1184 if SCM_GC8MARKP (scmptr
)
1186 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1188 case scm_tc7_byvect
:
1189 if SCM_GC8MARKP (scmptr
)
1191 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1195 if SCM_GC8MARKP (scmptr
)
1197 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1200 if SCM_GC8MARKP (scmptr
)
1202 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1204 #ifdef HAVE_LONG_LONGS
1205 case scm_tc7_llvect
:
1206 if SCM_GC8MARKP (scmptr
)
1208 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1212 if SCM_GC8MARKP (scmptr
)
1214 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1217 if SCM_GC8MARKP (scmptr
)
1219 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1222 if SCM_GC8MARKP (scmptr
)
1224 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1227 case scm_tc7_substring
:
1228 if (SCM_GC8MARKP (scmptr
))
1231 case scm_tc7_string
:
1232 if (SCM_GC8MARKP (scmptr
))
1234 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1236 case scm_tc7_msymbol
:
1237 if (SCM_GC8MARKP (scmptr
))
1239 m
+= ( SCM_LENGTH (scmptr
)
1241 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1242 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1244 case scm_tc7_contin
:
1245 if SCM_GC8MARKP (scmptr
)
1247 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1248 if (SCM_VELTS (scmptr
))
1250 case scm_tc7_ssymbol
:
1251 if SCM_GC8MARKP(scmptr
)
1257 if SCM_GC8MARKP (scmptr
)
1259 if SCM_OPENP (scmptr
)
1261 int k
= SCM_PTOBNUM (scmptr
);
1262 if (!(k
< scm_numptob
))
1264 /* Keep "revealed" ports alive. */
1265 if (scm_revealed_count(scmptr
) > 0)
1267 /* Yes, I really do mean scm_ptobs[k].free */
1268 /* rather than ftobs[k].close. .close */
1269 /* is for explicit CLOSE-PORT by user */
1270 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1271 SCM_SETSTREAM (scmptr
, 0);
1272 scm_remove_from_port_table (scmptr
);
1273 scm_gc_ports_collected
++;
1274 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1278 switch SCM_GCTYP16 (scmptr
)
1280 case scm_tc_free_cell
:
1281 if SCM_GC8MARKP (scmptr
)
1285 case scm_tcs_bignums
:
1286 if SCM_GC8MARKP (scmptr
)
1288 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1290 #endif /* def SCM_BIGDIG */
1292 if SCM_GC8MARKP (scmptr
)
1294 switch ((int) (SCM_CAR (scmptr
) >> 16))
1296 case (SCM_IMAG_PART
| SCM_REAL_PART
) >> 16:
1297 m
+= sizeof (double);
1298 case SCM_REAL_PART
>> 16:
1299 case SCM_IMAG_PART
>> 16:
1300 m
+= sizeof (double);
1309 if SCM_GC8MARKP (scmptr
)
1314 k
= SCM_SMOBNUM (scmptr
);
1315 if (!(k
< scm_numsmob
))
1317 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1323 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1327 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1330 /* Stick the new cell on the front of nfreelist. It's
1331 critical that we mark this cell as freed; otherwise, the
1332 conservative collector might trace it as some other type
1334 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1335 SCM_SETCDR (scmptr
, nfreelist
);
1340 SCM_CLRGC8MARK (scmptr
);
1343 SCM_CLRGCMARK (scmptr
);
1345 #ifdef GC_FREE_SEGMENTS
1350 scm_heap_size
-= seg_size
;
1351 free ((char *) scm_heap_table
[i
].bounds
[0]);
1352 scm_heap_table
[i
].bounds
[0] = 0;
1353 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1354 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1355 scm_n_heap_segs
-= 1;
1356 i
--; /* We need to scan the segment just moved. */
1359 #endif /* ifdef GC_FREE_SEGMENTS */
1360 /* Update the real freelist pointer to point to the head of
1361 the list of free cells we've built for this segment. */
1362 *hp_freelist
= nfreelist
;
1364 #ifdef GUILE_DEBUG_FREELIST
1365 scm_check_freelist ();
1366 scm_map_free_list ();
1369 scm_gc_cells_collected
+= n
;
1371 /* Scan weak vectors. */
1374 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1376 if (!SCM_IS_WHVEC_ANY (w
))
1380 ptr
= SCM_VELTS (w
);
1382 for (j
= 0; j
< n
; ++j
)
1383 if (SCM_FREEP (ptr
[j
]))
1384 ptr
[j
] = SCM_BOOL_F
;
1386 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1389 register long n
= SCM_LENGTH (w
);
1392 ptr
= SCM_VELTS (w
);
1394 for (j
= 0; j
< n
; ++j
)
1401 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1402 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1407 while (SCM_NIMP (alist
)
1408 && SCM_CONSP (alist
)
1409 && SCM_NIMP (SCM_CAR (alist
))
1410 && SCM_CONSP (SCM_CAR (alist
)))
1415 key
= SCM_CAAR (alist
);
1416 value
= SCM_CDAR (alist
);
1417 if ( (weak_keys
&& SCM_FREEP (key
))
1418 || (weak_values
&& SCM_FREEP (value
)))
1420 *fixup
= SCM_CDR (alist
);
1423 fixup
= SCM_CDRLOC (alist
);
1424 alist
= SCM_CDR (alist
);
1430 scm_cells_allocated
= (scm_heap_size
- scm_gc_cells_collected
);
1431 scm_mallocated
-= m
;
1432 scm_gc_malloc_collected
= m
;
1438 /* {Front end to malloc}
1440 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1442 * These functions provide services comperable to malloc, realloc, and
1443 * free. They are for allocating malloced parts of scheme objects.
1444 * The primary purpose of the front end is to impose calls to gc.
1448 * Return newly malloced storage or throw an error.
1450 * The parameter WHAT is a string for error reporting.
1451 * If the threshold scm_mtrigger will be passed by this
1452 * allocation, or if the first call to malloc fails,
1453 * garbage collect -- on the presumption that some objects
1454 * using malloced storage may be collected.
1456 * The limit scm_mtrigger may be raised by this allocation.
1459 scm_must_malloc (scm_sizet size
, const char *what
)
1462 unsigned long nm
= scm_mallocated
+ size
;
1464 if (nm
<= scm_mtrigger
)
1466 SCM_SYSCALL (ptr
= malloc (size
));
1469 scm_mallocated
= nm
;
1476 nm
= scm_mallocated
+ size
;
1477 SCM_SYSCALL (ptr
= malloc (size
));
1480 scm_mallocated
= nm
;
1481 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1482 if (nm
> scm_mtrigger
)
1483 scm_mtrigger
= nm
+ nm
/ 2;
1485 scm_mtrigger
+= scm_mtrigger
/ 2;
1490 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1491 return 0; /* never reached */
1496 * is similar to scm_must_malloc.
1499 scm_must_realloc (void *where
,
1505 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1507 if (nm
<= scm_mtrigger
)
1509 SCM_SYSCALL (ptr
= realloc (where
, size
));
1512 scm_mallocated
= nm
;
1519 nm
= scm_mallocated
+ size
- old_size
;
1520 SCM_SYSCALL (ptr
= realloc (where
, size
));
1523 scm_mallocated
= nm
;
1524 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1525 if (nm
> scm_mtrigger
)
1526 scm_mtrigger
= nm
+ nm
/ 2;
1528 scm_mtrigger
+= scm_mtrigger
/ 2;
1533 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1534 return 0; /* never reached */
1538 scm_must_free (void *obj
)
1543 scm_wta (SCM_INUM0
, "already free", "");
1546 /* Announce that there has been some malloc done that will be freed
1547 * during gc. A typical use is for a smob that uses some malloced
1548 * memory but can not get it from scm_must_malloc (for whatever
1549 * reason). When a new object of this smob is created you call
1550 * scm_done_malloc with the size of the object. When your smob free
1551 * function is called, be sure to include this size in the return
1555 scm_done_malloc (long size
)
1557 scm_mallocated
+= size
;
1559 if (scm_mallocated
> scm_mtrigger
)
1561 scm_igc ("foreign mallocs");
1562 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1564 if (scm_mallocated
> scm_mtrigger
)
1565 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1567 scm_mtrigger
+= scm_mtrigger
/ 2;
1577 * Each heap segment is an array of objects of a particular size.
1578 * Every segment has an associated (possibly shared) freelist.
1579 * A table of segment records is kept that records the upper and
1580 * lower extents of the segment; this is used during the conservative
1581 * phase of gc to identify probably gc roots (because they point
1582 * into valid segments at reasonable offsets). */
1585 * is true if the first segment was smaller than INIT_HEAP_SEG.
1586 * If scm_expmem is set to one, subsequent segment allocations will
1587 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1592 * is the lowest base address of any heap segment.
1594 SCM_CELLPTR scm_heap_org
;
1596 struct scm_heap_seg_data
* scm_heap_table
= 0;
1597 int scm_n_heap_segs
= 0;
1600 * is the total number of cells in heap segments.
1602 unsigned long scm_heap_size
= 0;
1605 * initializes a new heap segment and return the number of objects it contains.
1607 * The segment origin, segment size in bytes, and the span of objects
1608 * in cells are input parameters. The freelist is both input and output.
1610 * This function presume that the scm_heap_table has already been expanded
1611 * to accomodate a new segment record.
1616 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, int ncells
, SCM
*freelistp
)
1618 register SCM_CELLPTR ptr
;
1619 #ifdef SCM_POINTERS_MUNGED
1620 register SCM scmptr
;
1625 SCM_CELLPTR seg_end
;
1629 if (seg_org
== NULL
)
1634 /* Compute the ceiling on valid object pointers w/in this segment.
1636 seg_end
= CELL_DN ((char *) ptr
+ size
);
1638 /* Find the right place and insert the segment record.
1641 for (new_seg_index
= 0;
1642 ( (new_seg_index
< scm_n_heap_segs
)
1643 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1649 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1650 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1655 scm_heap_table
[new_seg_index
].valid
= 0;
1656 scm_heap_table
[new_seg_index
].ncells
= ncells
;
1657 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1658 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1659 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1662 /* Compute the least valid object pointer w/in this segment
1664 ptr
= CELL_UP (ptr
);
1667 n_new_objects
= seg_end
- ptr
;
1669 /* Prepend objects in this segment to the freelist.
1671 while (ptr
< seg_end
)
1673 #ifdef SCM_POINTERS_MUNGED
1674 scmptr
= PTR2SCM (ptr
);
1676 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1677 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ ncells
));
1683 /* Patch up the last freelist pointer in the segment
1684 * to join it to the input freelist.
1686 SCM_SETCDR (PTR2SCM (ptr
), *freelistp
);
1687 *freelistp
= PTR2SCM (CELL_UP (seg_org
));
1689 scm_heap_size
+= (ncells
* n_new_objects
);
1698 alloc_some_heap (int ncells
, SCM
*freelistp
)
1700 struct scm_heap_seg_data
* tmptable
;
1704 /* Critical code sections (such as the garbage collector)
1705 * aren't supposed to add heap segments.
1707 if (scm_gc_heap_lock
)
1708 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
1710 /* Expand the heap tables to have room for the new segment.
1711 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
1712 * only if the allocation of the segment itself succeeds.
1714 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
1716 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
1717 realloc ((char *)scm_heap_table
, len
)));
1719 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
1721 scm_heap_table
= tmptable
;
1724 /* Pick a size for the new heap segment.
1725 * The rule for picking the size of a segment is explained in
1730 len
= (scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
));
1731 if ((scm_sizet
) (SCM_EXPHEAP (scm_heap_size
) * sizeof (scm_cell
)) != len
)
1735 len
= SCM_HEAP_SEG_SIZE
;
1740 smallest
= (ncells
* sizeof (scm_cell
));
1742 len
= (ncells
* sizeof (scm_cell
));
1744 /* Allocate with decaying ambition. */
1745 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
1746 && (len
>= smallest
))
1748 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
1751 init_heap_seg (ptr
, len
, ncells
, freelistp
);
1758 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
1763 GUILE_PROC (scm_unhash_name
, "unhash-name", 1, 0, 0,
1766 #define FUNC_NAME s_scm_unhash_name
1770 SCM_VALIDATE_SYMBOL(1,name
);
1772 bound
= scm_n_heap_segs
;
1773 for (x
= 0; x
< bound
; ++x
)
1777 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
1778 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
1783 if (1 == (7 & (int)incar
))
1786 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
1787 && (SCM_CDR (incar
) != 0)
1788 && (SCM_CDR (incar
) != 1))
1803 /* {GC Protection Helper Functions}
1808 scm_remember (SCM
*ptr
)
1813 scm_return_first (SCM elt
, ...)
1820 scm_permanent_object (SCM obj
)
1823 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
1829 /* Protect OBJ from the garbage collector. OBJ will not be freed,
1830 even if all other references are dropped, until someone applies
1831 scm_unprotect_object to it. This function returns OBJ.
1833 Calls to scm_protect_object nest. For every object O, there is a
1834 counter which scm_protect_object(O) increments and
1835 scm_unprotect_object(O) decrements, if it is greater than zero. If
1836 an object's counter is greater than zero, the garbage collector
1839 Of course, that's not how it's implemented. scm_protect_object and
1840 scm_unprotect_object just maintain a list of references to things.
1841 Since the GC knows about this list, all objects it mentions stay
1842 alive. scm_protect_object adds its argument to the list;
1843 scm_unprotect_object removes the first occurrence of its argument
1846 scm_protect_object (SCM obj
)
1848 scm_protects
= scm_cons (obj
, scm_protects
);
1854 /* Remove any protection for OBJ established by a prior call to
1855 scm_protect_object. This function returns OBJ.
1857 See scm_protect_object for more information. */
1859 scm_unprotect_object (SCM obj
)
1861 SCM
*tail_ptr
= &scm_protects
;
1863 while (SCM_CONSP (*tail_ptr
))
1864 if (SCM_CAR (*tail_ptr
) == obj
)
1866 *tail_ptr
= SCM_CDR (*tail_ptr
);
1870 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
1877 /* called on process termination. */
1883 extern int on_exit (void (*procp
) (), int arg
);
1886 cleanup (int status
, void *arg
)
1888 #error Dont know how to setup a cleanup handler on your system.
1893 scm_flush_all_ports ();
1898 scm_init_storage (scm_sizet init_heap_size
)
1902 j
= SCM_NUM_PROTECTS
;
1904 scm_sys_protects
[--j
] = SCM_BOOL_F
;
1906 scm_freelist
= SCM_EOL
;
1909 j
= SCM_HEAP_SEG_SIZE
;
1910 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
1911 scm_heap_table
= ((struct scm_heap_seg_data
*)
1912 scm_must_malloc (sizeof (struct scm_heap_seg_data
), "hplims"));
1913 if (0L == init_heap_size
)
1914 init_heap_size
= SCM_INIT_HEAP_SIZE
;
1916 if ((init_heap_size
!= j
)
1917 || !init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1919 j
= SCM_HEAP_SEG_SIZE
;
1920 if (!init_heap_seg ((SCM_CELLPTR
) malloc (j
), j
, 1, &scm_freelist
))
1925 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
1926 /* scm_hplims[0] can change. do not remove scm_heap_org */
1927 scm_weak_vectors
= SCM_EOL
;
1929 /* Initialise the list of ports. */
1930 scm_port_table
= (scm_port
**)
1931 malloc (sizeof (scm_port
*) * scm_port_table_room
);
1932 if (!scm_port_table
)
1939 on_exit (cleanup
, 0);
1943 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
1944 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
1946 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
1947 scm_nullstr
= scm_makstr (0L, 0);
1948 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
1949 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1950 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
1951 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1952 scm_stand_in_procs
= SCM_EOL
;
1953 scm_permobjs
= SCM_EOL
;
1954 scm_protects
= SCM_EOL
;
1955 scm_asyncs
= SCM_EOL
;
1956 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
1957 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
1959 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));