1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000 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"
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 (40000L * 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 #define SCM_GC_TRIGGER 10000
128 #define SCM_GC_TRIGGER2 10000
130 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
131 bounds for allocated storage */
134 /*in 386 protected mode we must only adjust the offset */
135 # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
136 # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
139 # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
140 # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
142 # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
143 # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
152 #ifdef GUILE_NEW_GC_SCHEME
153 SCM scm_freelist
= SCM_EOL
;
154 scm_freelist_t scm_master_freelist
= {
155 SCM_EOL
, 0, SCM_EOL
, SCM_EOL
, 0, 0, 1, 0, 0
157 SCM scm_freelist2
= SCM_EOL
;
158 scm_freelist_t scm_master_freelist2
= {
159 SCM_EOL
, 0, SCM_EOL
, SCM_EOL
, 0, 0, 2, 0, 0
162 scm_freelist_t scm_freelist
= { SCM_EOL
, 1, 0, 0 };
163 scm_freelist_t scm_freelist2
= { SCM_EOL
, 2, 0, 0 };
167 * is the number of bytes of must_malloc allocation needed to trigger gc.
169 unsigned long scm_mtrigger
;
173 * If set, don't expand the heap. Set only during gc, during which no allocation
174 * is supposed to take place anyway.
176 int scm_gc_heap_lock
= 0;
179 * Don't pause for collection if this is set -- just
183 int scm_block_gc
= 1;
185 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
186 * collection (GC) more space is allocated for the heap.
188 #define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
190 /* During collection, this accumulates objects holding
193 SCM scm_weak_vectors
;
195 /* GC Statistics Keeping
197 unsigned long scm_cells_allocated
= 0;
198 long scm_mallocated
= 0;
199 /* unsigned long scm_gc_cells_collected; */
200 unsigned long scm_gc_malloc_collected
;
201 unsigned long scm_gc_ports_collected
;
202 unsigned long scm_gc_rt
;
203 unsigned long scm_gc_time_taken
= 0;
205 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
206 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
207 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
208 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
209 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
210 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
213 struct scm_heap_seg_data
215 /* lower and upper bounds of the segment */
216 SCM_CELLPTR bounds
[2];
218 /* address of the head-of-freelist pointer for this segment's cells.
219 All segments usually point to the same one, scm_freelist. */
220 scm_freelist_t
*freelistp
;
222 /* number of SCM words per object in this segment */
225 /* If SEG_DATA->valid is non-zero, the conservative marking
226 functions will apply SEG_DATA->valid to the purported pointer and
227 SEG_DATA, and mark the object iff the function returns non-zero.
228 At the moment, I don't think anyone uses this. */
235 static void scm_mark_weak_vector_spines (void);
236 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
237 static void alloc_some_heap (scm_freelist_t
*);
241 /* Debugging functions. */
243 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
245 /* Return the number of the heap segment containing CELL. */
251 for (i
= 0; i
< scm_n_heap_segs
; i
++)
252 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
253 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
255 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
261 #ifdef GUILE_NEW_GC_SCHEME
263 map_free_list (scm_freelist_t
*master
, SCM freelist
)
265 int last_seg
= -1, count
= 0;
268 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
270 int this_seg
= which_seg (f
);
272 if (this_seg
!= last_seg
)
275 fprintf (stderr
, " %5d %d-cells in segment %d\n",
276 count
, master
->span
, last_seg
);
283 fprintf (stderr
, " %5d %d-cells in segment %d\n",
284 count
, master
->span
, last_seg
);
288 map_free_list (scm_freelist_t
*freelistp
)
290 int last_seg
= -1, count
= 0;
293 for (f
= freelistp
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
))
295 int this_seg
= which_seg (f
);
297 if (this_seg
!= last_seg
)
300 fprintf (stderr
, " %5d %d-cells in segment %d\n",
301 count
, freelistp
->span
, last_seg
);
308 fprintf (stderr
, " %5d %d-cells in segment %d\n",
309 count
, freelistp
->span
, last_seg
);
313 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
315 "Print debugging information about the free-list.\n"
316 "`map-free-list' is only included in GUILE_DEBUG_FREELIST builds of Guile.")
317 #define FUNC_NAME s_scm_map_free_list
319 fprintf (stderr
, "%d segments total\n", scm_n_heap_segs
);
320 #ifdef GUILE_NEW_GC_SCHEME
321 map_free_list (&scm_master_freelist
, scm_freelist
);
322 map_free_list (&scm_master_freelist2
, scm_freelist2
);
324 map_free_list (&scm_freelist
);
325 map_free_list (&scm_freelist2
);
329 return SCM_UNSPECIFIED
;
335 #ifdef GUILE_DEBUG_FREELIST
337 /* Number of calls to SCM_NEWCELL since startup. */
338 static unsigned long scm_newcell_count
;
339 static unsigned long scm_newcell2_count
;
341 /* Search freelist for anything that isn't marked as a free cell.
342 Abort if we find something. */
343 #ifdef GUILE_NEW_GC_SCHEME
345 scm_check_freelist (SCM freelist
)
350 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
351 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
353 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
354 scm_newcell_count
, i
);
361 scm_check_freelist (scm_freelist_t
*freelistp
)
366 for (f
= freelistp
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
367 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
369 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
370 scm_newcell_count
, i
);
377 static int scm_debug_check_freelist
= 0;
379 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
381 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
382 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
383 "compile-time flag was selected.\n")
384 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
386 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
387 return SCM_UNSPECIFIED
;
392 #ifdef GUILE_NEW_GC_SCHEME
395 scm_debug_newcell (void)
400 if (scm_debug_check_freelist
)
402 scm_check_freelist (scm_freelist
);
406 /* The rest of this is supposed to be identical to the SCM_NEWCELL
408 if (SCM_IMP (scm_freelist
))
409 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
413 scm_freelist
= SCM_CDR (scm_freelist
);
414 SCM_SETCAR (new, scm_tc16_allocated
);
421 scm_debug_newcell2 (void)
425 scm_newcell2_count
++;
426 if (scm_debug_check_freelist
)
428 scm_check_freelist (scm_freelist2
);
432 /* The rest of this is supposed to be identical to the SCM_NEWCELL
434 if (SCM_IMP (scm_freelist2
))
435 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
439 scm_freelist2
= SCM_CDR (scm_freelist2
);
440 SCM_SETCAR (new, scm_tc16_allocated
);
446 #else /* GUILE_NEW_GC_SCHEME */
449 scm_debug_newcell (void)
454 if (scm_debug_check_freelist
)
456 scm_check_freelist (&scm_freelist
);
460 /* The rest of this is supposed to be identical to the SCM_NEWCELL
462 if (SCM_IMP (scm_freelist
.cells
))
463 new = scm_gc_for_newcell (&scm_freelist
);
466 new = scm_freelist
.cells
;
467 scm_freelist
.cells
= SCM_CDR (scm_freelist
.cells
);
468 SCM_SETCAR (new, scm_tc16_allocated
);
469 ++scm_cells_allocated
;
476 scm_debug_newcell2 (void)
480 scm_newcell2_count
++;
481 if (scm_debug_check_freelist
) {
482 scm_check_freelist (&scm_freelist2
);
486 /* The rest of this is supposed to be identical to the SCM_NEWCELL2
488 if (SCM_IMP (scm_freelist2
.cells
))
489 new = scm_gc_for_newcell (&scm_freelist2
);
492 new = scm_freelist2
.cells
;
493 scm_freelist2
.cells
= SCM_CDR (scm_freelist2
.cells
);
494 SCM_SETCAR (new, scm_tc16_allocated
);
495 scm_cells_allocated
+= 2;
501 #endif /* GUILE_NEW_GC_SCHEME */
502 #endif /* GUILE_DEBUG_FREELIST */
506 /* {Scheme Interface to GC}
509 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
511 "Returns an association list of statistics about Guile's current use of storage. ")
512 #define FUNC_NAME s_scm_gc_stats
517 long int local_scm_mtrigger
;
518 long int local_scm_mallocated
;
519 long int local_scm_heap_size
;
520 long int local_scm_cells_allocated
;
521 long int local_scm_gc_time_taken
;
529 for (i
= scm_n_heap_segs
; i
--; )
530 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
531 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
533 if (scm_n_heap_segs
!= n
)
538 local_scm_mtrigger
= scm_mtrigger
;
539 local_scm_mallocated
= scm_mallocated
;
540 #ifdef GUILE_NEW_GC_SCHEME
541 local_scm_heap_size
= scm_master_freelist
.heap_size
; /*fixme*/
543 local_scm_heap_size
= scm_freelist
.heap_size
; /*fixme*/
545 local_scm_cells_allocated
= scm_cells_allocated
;
546 local_scm_gc_time_taken
= scm_gc_time_taken
;
548 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
549 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
550 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
551 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
552 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
553 scm_cons (sym_heap_segments
, heap_segs
),
562 scm_gc_start (const char *what
)
564 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
565 /* scm_gc_cells_collected = 0; */
566 scm_gc_malloc_collected
= 0;
567 scm_gc_ports_collected
= 0;
573 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
574 scm_gc_time_taken
+= scm_gc_rt
;
575 scm_system_async_mark (scm_gc_async
);
579 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
581 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
582 "returned by this function for @var{obj}")
583 #define FUNC_NAME s_scm_object_address
585 return scm_ulong2num ((unsigned long) obj
);
590 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
592 "Scans all of SCM objects and reclaims for further use those that are\n"
593 "no longer accessible.")
594 #define FUNC_NAME s_scm_gc
599 return SCM_UNSPECIFIED
;
605 /* {C Interface For When GC is Triggered}
608 #ifdef GUILE_NEW_GC_SCHEME
610 /* When we get POSIX threads support, the master will be global and
611 common while the freelist will be individual for each thread. */
614 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
618 if (master
->triggeredp
)
620 else if (SCM_NULLP (master
->clusters
))
621 alloc_some_heap (master
);
622 else if (SCM_NULLP (SCM_CDR (master
->clusters
)))
623 /* we are satisfied; GC instead of alloc next time around */
624 master
->triggeredp
= 1;
626 cell
= SCM_CAR (master
->clusters
);
627 master
->clusters
= SCM_CDR (master
->clusters
);
628 *freelist
= SCM_CDR (cell
);
629 SCM_SETCAR (cell
, scm_tc16_allocated
);
633 #else /* GUILE_NEW_GC_SCHEME */
636 scm_gc_for_alloc (scm_freelist_t
*freelistp
)
640 #ifdef GUILE_DEBUG_FREELIST
641 fprintf (stderr
, "Collected: %d, min_yield: %d\n",
642 freelistp
->collected
, MIN_GC_YIELD (freelistp
));
644 if ((freelistp
->collected
< MIN_GC_YIELD (freelistp
))
645 || SCM_IMP (freelistp
->cells
))
646 alloc_some_heap (freelistp
);
652 scm_gc_for_newcell (scm_freelist_t
*freelistp
)
655 scm_gc_for_alloc (freelistp
);
656 fl
= freelistp
->cells
;
657 freelistp
->cells
= SCM_CDR (fl
);
658 SCM_SETCAR (fl
, scm_tc16_allocated
);
662 #endif /* GUILE_NEW_GC_SCHEME */
665 scm_igc (const char *what
)
670 /* During the critical section, only the current thread may run. */
671 SCM_THREAD_CRITICAL_SECTION_START
;
674 /* fprintf (stderr, "gc: %s\n", what); */
678 if (!scm_stack_base
|| scm_block_gc
)
684 if (scm_mallocated
< 0)
685 /* The byte count of allocated objects has underflowed. This is
686 probably because you forgot to report the sizes of objects you
687 have allocated, by calling scm_done_malloc or some such. When
688 the GC freed them, it subtracted their size from
689 scm_mallocated, which underflowed. */
692 if (scm_gc_heap_lock
)
693 /* We've invoked the collector while a GC is already in progress.
694 That should never happen. */
699 scm_weak_vectors
= SCM_EOL
;
701 scm_guardian_gc_init ();
703 /* unprotect any struct types with no instances */
709 pos
= &scm_type_obj_list
;
710 type_list
= scm_type_obj_list
;
711 while (type_list
!= SCM_EOL
)
712 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
714 pos
= SCM_CDRLOC (type_list
);
715 type_list
= SCM_CDR (type_list
);
719 *pos
= SCM_CDR (type_list
);
720 type_list
= SCM_CDR (type_list
);
725 /* flush dead entries from the continuation stack */
730 elts
= SCM_VELTS (scm_continuation_stack
);
731 bound
= SCM_LENGTH (scm_continuation_stack
);
732 x
= SCM_INUM (scm_continuation_stack_ptr
);
735 elts
[x
] = SCM_BOOL_F
;
742 /* Protect from the C stack. This must be the first marking
743 * done because it provides information about what objects
744 * are "in-use" by the C code. "in-use" objects are those
745 * for which the values from SCM_LENGTH and SCM_CHARS must remain
746 * usable. This requirement is stricter than a liveness
747 * requirement -- in particular, it constrains the implementation
748 * of scm_vector_set_length_x.
750 SCM_FLUSH_REGISTER_WINDOWS
;
751 /* This assumes that all registers are saved into the jmp_buf */
752 setjmp (scm_save_regs_gc_mark
);
753 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
754 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
755 sizeof scm_save_regs_gc_mark
)
756 / sizeof (SCM_STACKITEM
)));
759 /* stack_len is long rather than scm_sizet in order to guarantee that
760 &stack_len is long aligned */
761 #ifdef SCM_STACK_GROWS_UP
763 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
765 long stack_len
= scm_stack_size (scm_stack_base
);
767 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
770 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
772 long stack_len
= scm_stack_size (scm_stack_base
);
774 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
778 #else /* USE_THREADS */
780 /* Mark every thread's stack and registers */
781 scm_threads_mark_stacks ();
783 #endif /* USE_THREADS */
785 /* FIXME: insert a phase to un-protect string-data preserved
786 * in scm_vector_set_length_x.
789 j
= SCM_NUM_PROTECTS
;
791 scm_gc_mark (scm_sys_protects
[j
]);
793 /* FIXME: we should have a means to register C functions to be run
794 * in different phases of GC
796 scm_mark_subr_table ();
799 scm_gc_mark (scm_root
->handle
);
802 scm_mark_weak_vector_spines ();
804 scm_guardian_zombify ();
812 SCM_THREAD_CRITICAL_SECTION_END
;
822 /* Mark an object precisely.
837 if (SCM_NCELLP (ptr
))
838 scm_wta (ptr
, "rogue pointer in heap", NULL
);
840 switch (SCM_TYP7 (ptr
))
842 case scm_tcs_cons_nimcar
:
843 if (SCM_GCMARKP (ptr
))
846 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
851 scm_gc_mark (SCM_CAR (ptr
));
852 ptr
= SCM_GCCDR (ptr
);
854 case scm_tcs_cons_imcar
:
855 if (SCM_GCMARKP (ptr
))
858 ptr
= SCM_GCCDR (ptr
);
861 if (SCM_GCMARKP (ptr
))
864 scm_gc_mark (SCM_CELL_WORD (ptr
, 2));
865 ptr
= SCM_GCCDR (ptr
);
867 case scm_tcs_cons_gloc
:
868 if (SCM_GCMARKP (ptr
))
873 vcell
= SCM_CAR (ptr
) - 1L;
874 switch (SCM_UNPACK (SCM_CDR (vcell
)))
878 ptr
= SCM_GCCDR (ptr
);
890 vtable_data
= (SCM
*)vcell
;
891 layout
= vtable_data
[scm_vtable_index_layout
];
892 len
= SCM_LENGTH (layout
);
893 fields_desc
= SCM_CHARS (layout
);
894 /* We're using SCM_GCCDR here like STRUCT_DATA, except
895 that it removes the mark */
896 mem
= (SCM
*)SCM_GCCDR (ptr
);
898 if (SCM_UNPACK (vtable_data
[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
900 scm_gc_mark (mem
[scm_struct_i_procedure
]);
901 scm_gc_mark (mem
[scm_struct_i_setter
]);
905 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
906 if (fields_desc
[x
] == 'p')
908 if (fields_desc
[x
] == 'p')
911 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
912 for (j
= (long int) *mem
; x
; --x
)
913 scm_gc_mark (*++mem
);
918 if (!SCM_CDR (vcell
))
920 SCM_SETGCMARK (vcell
);
921 ptr
= vtable_data
[scm_vtable_index_vtable
];
928 case scm_tcs_closures
:
929 if (SCM_GCMARKP (ptr
))
932 if (SCM_IMP (SCM_CDR (ptr
)))
934 ptr
= SCM_CLOSCAR (ptr
);
937 scm_gc_mark (SCM_CLOSCAR (ptr
));
938 ptr
= SCM_GCCDR (ptr
);
941 case scm_tc7_lvector
:
945 if (SCM_GC8MARKP (ptr
))
947 SCM_SETGC8MARK (ptr
);
948 i
= SCM_LENGTH (ptr
);
952 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
953 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
954 ptr
= SCM_VELTS (ptr
)[0];
959 SCM_SETGC8MARK (ptr
);
961 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
964 (sizeof (SCM_STACKITEM
) + -1 +
965 sizeof (scm_contregs
)) /
966 sizeof (SCM_STACKITEM
)));
977 #ifdef HAVE_LONG_LONGS
982 SCM_SETGC8MARK (ptr
);
985 case scm_tc7_substring
:
986 if (SCM_GC8MARKP(ptr
))
988 SCM_SETGC8MARK (ptr
);
993 if (SCM_GC8MARKP(ptr
))
995 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
996 scm_weak_vectors
= ptr
;
997 SCM_SETGC8MARK (ptr
);
998 if (SCM_IS_WHVEC_ANY (ptr
))
1005 len
= SCM_LENGTH (ptr
);
1006 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1007 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1009 for (x
= 0; x
< len
; ++x
)
1012 alist
= SCM_VELTS (ptr
)[x
];
1014 /* mark everything on the alist except the keys or
1015 * values, according to weak_values and weak_keys. */
1016 while ( SCM_CONSP (alist
)
1017 && !SCM_GCMARKP (alist
)
1018 && SCM_CONSP (SCM_CAR (alist
)))
1023 kvpair
= SCM_CAR (alist
);
1024 next_alist
= SCM_CDR (alist
);
1027 * SCM_SETGCMARK (alist);
1028 * SCM_SETGCMARK (kvpair);
1030 * It may be that either the key or value is protected by
1031 * an escaped reference to part of the spine of this alist.
1032 * If we mark the spine here, and only mark one or neither of the
1033 * key and value, they may never be properly marked.
1034 * This leads to a horrible situation in which an alist containing
1035 * freelist cells is exported.
1037 * So only mark the spines of these arrays last of all marking.
1038 * If somebody confuses us by constructing a weak vector
1039 * with a circular alist then we are hosed, but at least we
1040 * won't prematurely drop table entries.
1043 scm_gc_mark (SCM_CAR (kvpair
));
1045 scm_gc_mark (SCM_GCCDR (kvpair
));
1048 if (SCM_NIMP (alist
))
1049 scm_gc_mark (alist
);
1054 case scm_tc7_msymbol
:
1055 if (SCM_GC8MARKP(ptr
))
1057 SCM_SETGC8MARK (ptr
);
1058 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1059 ptr
= SCM_SYMBOL_PROPS (ptr
);
1061 case scm_tc7_ssymbol
:
1062 if (SCM_GC8MARKP(ptr
))
1064 SCM_SETGC8MARK (ptr
);
1069 i
= SCM_PTOBNUM (ptr
);
1070 if (!(i
< scm_numptob
))
1072 if (SCM_GC8MARKP (ptr
))
1074 SCM_SETGC8MARK (ptr
);
1075 if (SCM_PTAB_ENTRY(ptr
))
1076 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1077 if (scm_ptobs
[i
].mark
)
1079 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1086 if (SCM_GC8MARKP (ptr
))
1088 SCM_SETGC8MARK (ptr
);
1089 switch (SCM_GCTYP16 (ptr
))
1090 { /* should be faster than going through scm_smobs */
1091 case scm_tc_free_cell
:
1092 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1093 case scm_tc16_allocated
:
1096 case scm_tc16_complex
:
1099 i
= SCM_SMOBNUM (ptr
);
1100 if (!(i
< scm_numsmob
))
1102 if (scm_smobs
[i
].mark
)
1104 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1112 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1117 /* Mark a Region Conservatively
1121 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1123 register long m
= n
;
1125 register SCM_CELLPTR ptr
;
1128 if (SCM_CELLP (*(SCM
**) (& x
[m
])))
1130 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
1132 j
= scm_n_heap_segs
- 1;
1133 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1134 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1141 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1143 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1151 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1155 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1160 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1164 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1170 if ( !scm_heap_table
[seg_id
].valid
1171 || scm_heap_table
[seg_id
].valid (ptr
,
1172 &scm_heap_table
[seg_id
]))
1173 scm_gc_mark (*(SCM
*) & x
[m
]);
1182 /* The following is a C predicate which determines if an SCM value can be
1183 regarded as a pointer to a cell on the heap. The code is duplicated
1184 from scm_mark_locations. */
1188 scm_cellp (SCM value
)
1191 register SCM_CELLPTR ptr
;
1193 if SCM_CELLP (*(SCM
**) (& value
))
1195 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
1197 j
= scm_n_heap_segs
- 1;
1198 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1199 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1206 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1208 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1216 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1220 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1225 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1229 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1235 if ( !scm_heap_table
[seg_id
].valid
1236 || scm_heap_table
[seg_id
].valid (ptr
,
1237 &scm_heap_table
[seg_id
]))
1249 scm_mark_weak_vector_spines ()
1253 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1255 if (SCM_IS_WHVEC_ANY (w
))
1263 ptr
= SCM_VELTS (w
);
1265 for (j
= 0; j
< n
; ++j
)
1270 while ( SCM_CONSP (alist
)
1271 && !SCM_GCMARKP (alist
)
1272 && SCM_CONSP (SCM_CAR (alist
)))
1274 SCM_SETGCMARK (alist
);
1275 SCM_SETGCMARK (SCM_CAR (alist
));
1276 alist
= SCM_GCCDR (alist
);
1288 register SCM_CELLPTR ptr
;
1289 #ifdef SCM_POINTERS_MUNGED
1290 register SCM scmptr
;
1293 #define scmptr (SCM)ptr
1295 register SCM nfreelist
;
1296 register scm_freelist_t
*hp_freelist
;
1304 #ifdef GUILE_NEW_GC_SCHEME
1305 /* Reset all free list pointers. We'll reconstruct them completely
1307 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1309 scm_heap_table
[i
].freelistp
->cells
= SCM_EOL
;
1310 scm_heap_table
[i
].freelistp
->n_objects
1311 = scm_heap_table
[i
].freelistp
->gc_trigger
;
1312 scm_heap_table
[i
].freelistp
->clusters
= SCM_EOL
;
1313 scm_heap_table
[i
].freelistp
->clustertail
1314 = &scm_heap_table
[i
].freelistp
->clusters
;
1315 scm_heap_table
[i
].freelistp
->triggeredp
= 0;
1318 /* Reset all free list pointers. We'll reconstruct them completely
1320 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1321 scm_heap_table
[i
].freelistp
->cells
= SCM_EOL
;
1324 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1326 register scm_sizet n
= 0;
1327 register scm_sizet j
;
1328 #ifdef GUILE_NEW_GC_SCHEME
1329 register scm_sizet n_objects
;
1332 /* Unmarked cells go onto the front of the freelist this heap
1333 segment points to. Rather than updating the real freelist
1334 pointer as we go along, we accumulate the new head in
1335 nfreelist. Then, if it turns out that the entire segment is
1336 free, we free (i.e., malloc's free) the whole segment, and
1337 simply don't assign nfreelist back into the real freelist. */
1338 hp_freelist
= scm_heap_table
[i
].freelistp
;
1339 nfreelist
= hp_freelist
->cells
;
1340 #ifdef GUILE_NEW_GC_SCHEME
1341 n_objects
= hp_freelist
->n_objects
;
1343 span
= scm_heap_table
[i
].span
;
1344 hp_freelist
->collected
= 0;
1346 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1347 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1348 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1350 #ifdef SCM_POINTERS_MUNGED
1351 scmptr
= PTR2SCM (ptr
);
1353 switch SCM_TYP7 (scmptr
)
1355 case scm_tcs_cons_gloc
:
1356 if (SCM_GCMARKP (scmptr
))
1358 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1359 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1364 vcell
= SCM_CAR (scmptr
) - 1L;
1366 if ((SCM_CDR (vcell
) == 0) || (SCM_UNPACK (SCM_CDR (vcell
)) == 1))
1368 scm_struct_free_t free
1369 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1370 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1374 case scm_tcs_cons_imcar
:
1375 case scm_tcs_cons_nimcar
:
1376 case scm_tcs_closures
:
1378 if (SCM_GCMARKP (scmptr
))
1382 if (SCM_GC8MARKP (scmptr
))
1388 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1389 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1393 case scm_tc7_vector
:
1394 case scm_tc7_lvector
:
1398 if (SCM_GC8MARKP (scmptr
))
1401 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1403 scm_must_free (SCM_CHARS (scmptr
));
1404 /* SCM_SETCHARS(scmptr, 0);*/
1408 if SCM_GC8MARKP (scmptr
)
1410 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1412 case scm_tc7_byvect
:
1413 if SCM_GC8MARKP (scmptr
)
1415 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1419 if SCM_GC8MARKP (scmptr
)
1421 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1424 if SCM_GC8MARKP (scmptr
)
1426 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1428 #ifdef HAVE_LONG_LONGS
1429 case scm_tc7_llvect
:
1430 if SCM_GC8MARKP (scmptr
)
1432 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1436 if SCM_GC8MARKP (scmptr
)
1438 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1441 if SCM_GC8MARKP (scmptr
)
1443 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1446 if SCM_GC8MARKP (scmptr
)
1448 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1451 case scm_tc7_substring
:
1452 if (SCM_GC8MARKP (scmptr
))
1455 case scm_tc7_string
:
1456 if (SCM_GC8MARKP (scmptr
))
1458 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1460 case scm_tc7_msymbol
:
1461 if (SCM_GC8MARKP (scmptr
))
1463 m
+= ( SCM_LENGTH (scmptr
)
1465 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1466 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1468 case scm_tc7_contin
:
1469 if SCM_GC8MARKP (scmptr
)
1471 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1472 if (SCM_VELTS (scmptr
))
1474 case scm_tc7_ssymbol
:
1475 if SCM_GC8MARKP(scmptr
)
1481 if SCM_GC8MARKP (scmptr
)
1483 if SCM_OPENP (scmptr
)
1485 int k
= SCM_PTOBNUM (scmptr
);
1486 if (!(k
< scm_numptob
))
1488 /* Keep "revealed" ports alive. */
1489 if (scm_revealed_count (scmptr
) > 0)
1491 /* Yes, I really do mean scm_ptobs[k].free */
1492 /* rather than ftobs[k].close. .close */
1493 /* is for explicit CLOSE-PORT by user */
1494 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1495 SCM_SETSTREAM (scmptr
, 0);
1496 scm_remove_from_port_table (scmptr
);
1497 scm_gc_ports_collected
++;
1498 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1502 switch SCM_GCTYP16 (scmptr
)
1504 case scm_tc_free_cell
:
1506 if SCM_GC8MARKP (scmptr
)
1511 if SCM_GC8MARKP (scmptr
)
1513 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1515 #endif /* def SCM_BIGDIG */
1516 case scm_tc16_complex
:
1517 if SCM_GC8MARKP (scmptr
)
1519 m
+= 2 * sizeof (double);
1522 if SCM_GC8MARKP (scmptr
)
1527 k
= SCM_SMOBNUM (scmptr
);
1528 if (!(k
< scm_numsmob
))
1530 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1536 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1539 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1542 #ifndef GUILE_NEW_GC_SCHEME
1545 if (--n_objects
< 0)
1547 SCM_SETCAR (scmptr
, nfreelist
);
1548 *hp_freelist
->clustertail
= scmptr
;
1549 hp_freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1551 nfreelist
= SCM_EOL
;
1552 n
+= span
* (hp_freelist
->gc_trigger
- n_objects
+ 1);
1553 n_objects
= hp_freelist
->gc_trigger
;
1558 /* Stick the new cell on the front of nfreelist. It's
1559 critical that we mark this cell as freed; otherwise, the
1560 conservative collector might trace it as some other type
1562 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
1563 SCM_SETCDR (scmptr
, nfreelist
);
1569 SCM_CLRGC8MARK (scmptr
);
1572 SCM_CLRGCMARK (scmptr
);
1574 #ifdef GC_FREE_SEGMENTS
1579 hp_freelist
->heap_size
-= seg_size
;
1580 free ((char *) scm_heap_table
[i
].bounds
[0]);
1581 scm_heap_table
[i
].bounds
[0] = 0;
1582 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1583 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1584 scm_n_heap_segs
-= 1;
1585 i
--; /* We need to scan the segment just moved. */
1588 #endif /* ifdef GC_FREE_SEGMENTS */
1590 /* Update the real freelist pointer to point to the head of
1591 the list of free cells we've built for this segment. */
1592 hp_freelist
->cells
= nfreelist
;
1593 #ifdef GUILE_NEW_GC_SCHEME
1594 hp_freelist
->n_objects
= n_objects
;
1598 #ifdef GUILE_NEW_GC_SCHEME
1599 j
= span
* (hp_freelist
->gc_trigger
- n_objects
);
1600 /* sum up---if this is last turn for this freelist */
1601 hp_freelist
->collected
+= n
+ j
;
1602 n
-= j
; /* compensate for the sum up */
1604 hp_freelist
->collected
+= n
;
1606 scm_cells_allocated
+= hp_freelist
->heap_size
- hp_freelist
->collected
;
1608 #ifdef GUILE_DEBUG_FREELIST
1609 #ifdef GUILE_NEW_GC_SCHEME
1610 scm_check_freelist (hp_freelist
== &scm_master_freelist
1614 scm_check_freelist (hp_freelist
);
1616 scm_map_free_list ();
1620 #ifdef GUILE_NEW_GC_SCHEME
1621 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1622 if (scm_heap_table
[i
].freelistp
->clustertail
!= NULL
)
1624 scm_freelist_t
*hp_freelist
= scm_heap_table
[i
].freelistp
;
1625 if (hp_freelist
->gc_trigger
- hp_freelist
->n_objects
> 1)
1627 SCM c
= hp_freelist
->cells
;
1628 hp_freelist
->n_objects
= hp_freelist
->gc_trigger
;
1629 SCM_SETCAR (c
, SCM_CDR (c
));
1630 SCM_SETCDR (c
, SCM_EOL
);
1631 *hp_freelist
->clustertail
= c
;
1634 *hp_freelist
->clustertail
= SCM_EOL
;
1635 hp_freelist
->clustertail
= NULL
;
1638 /* When we move to POSIX threads private freelists should probably
1639 be GC-protected instead. */
1640 scm_freelist
= SCM_EOL
;
1641 scm_freelist2
= SCM_EOL
;
1644 /* Scan weak vectors. */
1647 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1649 if (!SCM_IS_WHVEC_ANY (w
))
1653 ptr
= SCM_VELTS (w
);
1655 for (j
= 0; j
< n
; ++j
)
1656 if (SCM_FREEP (ptr
[j
]))
1657 ptr
[j
] = SCM_BOOL_F
;
1659 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1662 register long n
= SCM_LENGTH (w
);
1665 ptr
= SCM_VELTS (w
);
1667 for (j
= 0; j
< n
; ++j
)
1674 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1675 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1680 while ( SCM_CONSP (alist
)
1681 && SCM_CONSP (SCM_CAR (alist
)))
1686 key
= SCM_CAAR (alist
);
1687 value
= SCM_CDAR (alist
);
1688 if ( (weak_keys
&& SCM_FREEP (key
))
1689 || (weak_values
&& SCM_FREEP (value
)))
1691 *fixup
= SCM_CDR (alist
);
1694 fixup
= SCM_CDRLOC (alist
);
1695 alist
= SCM_CDR (alist
);
1701 scm_mallocated
-= m
;
1702 scm_gc_malloc_collected
= m
;
1708 /* {Front end to malloc}
1710 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1712 * These functions provide services comperable to malloc, realloc, and
1713 * free. They are for allocating malloced parts of scheme objects.
1714 * The primary purpose of the front end is to impose calls to gc.
1718 * Return newly malloced storage or throw an error.
1720 * The parameter WHAT is a string for error reporting.
1721 * If the threshold scm_mtrigger will be passed by this
1722 * allocation, or if the first call to malloc fails,
1723 * garbage collect -- on the presumption that some objects
1724 * using malloced storage may be collected.
1726 * The limit scm_mtrigger may be raised by this allocation.
1729 scm_must_malloc (scm_sizet size
, const char *what
)
1732 unsigned long nm
= scm_mallocated
+ size
;
1734 if (nm
<= scm_mtrigger
)
1736 SCM_SYSCALL (ptr
= malloc (size
));
1739 scm_mallocated
= nm
;
1746 nm
= scm_mallocated
+ size
;
1747 SCM_SYSCALL (ptr
= malloc (size
));
1750 scm_mallocated
= nm
;
1751 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1752 if (nm
> scm_mtrigger
)
1753 scm_mtrigger
= nm
+ nm
/ 2;
1755 scm_mtrigger
+= scm_mtrigger
/ 2;
1760 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1761 return 0; /* never reached */
1766 * is similar to scm_must_malloc.
1769 scm_must_realloc (void *where
,
1775 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1777 if (nm
<= scm_mtrigger
)
1779 SCM_SYSCALL (ptr
= realloc (where
, size
));
1782 scm_mallocated
= nm
;
1789 nm
= scm_mallocated
+ size
- old_size
;
1790 SCM_SYSCALL (ptr
= realloc (where
, size
));
1793 scm_mallocated
= nm
;
1794 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1795 if (nm
> scm_mtrigger
)
1796 scm_mtrigger
= nm
+ nm
/ 2;
1798 scm_mtrigger
+= scm_mtrigger
/ 2;
1803 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1804 return 0; /* never reached */
1808 scm_must_free (void *obj
)
1813 scm_wta (SCM_INUM0
, "already free", "");
1816 /* Announce that there has been some malloc done that will be freed
1817 * during gc. A typical use is for a smob that uses some malloced
1818 * memory but can not get it from scm_must_malloc (for whatever
1819 * reason). When a new object of this smob is created you call
1820 * scm_done_malloc with the size of the object. When your smob free
1821 * function is called, be sure to include this size in the return
1825 scm_done_malloc (long size
)
1827 scm_mallocated
+= size
;
1829 if (scm_mallocated
> scm_mtrigger
)
1831 scm_igc ("foreign mallocs");
1832 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1834 if (scm_mallocated
> scm_mtrigger
)
1835 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1837 scm_mtrigger
+= scm_mtrigger
/ 2;
1847 * Each heap segment is an array of objects of a particular size.
1848 * Every segment has an associated (possibly shared) freelist.
1849 * A table of segment records is kept that records the upper and
1850 * lower extents of the segment; this is used during the conservative
1851 * phase of gc to identify probably gc roots (because they point
1852 * into valid segments at reasonable offsets). */
1855 * is true if the first segment was smaller than INIT_HEAP_SEG.
1856 * If scm_expmem is set to one, subsequent segment allocations will
1857 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1862 * is the lowest base address of any heap segment.
1864 SCM_CELLPTR scm_heap_org
;
1866 struct scm_heap_seg_data
* scm_heap_table
= 0;
1867 int scm_n_heap_segs
= 0;
1870 * initializes a new heap segment and return the number of objects it contains.
1872 * The segment origin, segment size in bytes, and the span of objects
1873 * in cells are input parameters. The freelist is both input and output.
1875 * This function presume that the scm_heap_table has already been expanded
1876 * to accomodate a new segment record.
1881 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelistp
)
1883 register SCM_CELLPTR ptr
;
1884 #ifdef SCM_POINTERS_MUNGED
1885 register SCM scmptr
;
1890 SCM_CELLPTR seg_end
;
1893 int span
= freelistp
->span
;
1895 if (seg_org
== NULL
)
1900 size
= (size
/ sizeof (scm_cell
) / span
) * span
* sizeof (scm_cell
);
1902 /* Compute the ceiling on valid object pointers w/in this segment.
1904 seg_end
= CELL_DN ((char *) ptr
+ size
);
1906 /* Find the right place and insert the segment record.
1909 for (new_seg_index
= 0;
1910 ( (new_seg_index
< scm_n_heap_segs
)
1911 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
1917 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
1918 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
1923 scm_heap_table
[new_seg_index
].valid
= 0;
1924 scm_heap_table
[new_seg_index
].span
= span
;
1925 scm_heap_table
[new_seg_index
].freelistp
= freelistp
;
1926 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
1927 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
1930 /* Compute the least valid object pointer w/in this segment
1932 ptr
= CELL_UP (ptr
);
1936 n_new_cells
= seg_end
- ptr
;
1938 #ifdef GUILE_NEW_GC_SCHEME
1940 freelistp
->heap_size
+= n_new_cells
;
1942 /* Partition objects in this segment into clusters
1946 SCM
*clusterp
= &clusters
;
1947 int trigger
= span
* freelistp
->gc_trigger
;
1950 while (n_new_cells
> span
)
1952 if (n_new_cells
> trigger
)
1960 *clusterp
= PTR2SCM (ptr
);
1961 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
1962 clusterp
= SCM_CDRLOC (*clusterp
);
1966 while (ptr
< seg_end
)
1968 #ifdef SCM_POINTERS_MUNGED
1969 scmptr
= PTR2SCM (ptr
);
1971 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
1972 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
1975 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
1978 /* Correction for cluster cells + spill */
1979 freelistp
->heap_size
-= c
+ n_new_cells
;
1981 /* Patch up the last cluster pointer in the segment
1982 * to join it to the input freelist.
1984 *clusterp
= freelistp
->clusters
;
1985 freelistp
->clusters
= clusters
;
1988 #else /* GUILE_NEW_GC_SCHEME */
1990 /* Prepend objects in this segment to the freelist.
1992 while (ptr
< seg_end
)
1994 #ifdef SCM_POINTERS_MUNGED
1995 scmptr
= PTR2SCM (ptr
);
1997 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
1998 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2004 /* Patch up the last freelist pointer in the segment
2005 * to join it to the input freelist.
2007 SCM_SETCDR (PTR2SCM (ptr
), freelistp
->cells
);
2008 freelistp
->cells
= PTR2SCM (CELL_UP (seg_org
));
2010 freelistp
->heap_size
+= n_new_cells
;
2012 #endif /* GUILE_NEW_GC_SCHEME */
2022 alloc_some_heap (scm_freelist_t
*freelistp
)
2024 struct scm_heap_seg_data
* tmptable
;
2028 /* Critical code sections (such as the garbage collector)
2029 * aren't supposed to add heap segments.
2031 if (scm_gc_heap_lock
)
2032 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
2034 /* Expand the heap tables to have room for the new segment.
2035 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
2036 * only if the allocation of the segment itself succeeds.
2038 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
2040 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
2041 realloc ((char *)scm_heap_table
, len
)));
2043 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
2045 scm_heap_table
= tmptable
;
2048 /* Pick a size for the new heap segment.
2049 * The rule for picking the size of a segment is explained in
2054 len
= (scm_sizet
) SCM_EXPHEAP (freelistp
->heap_size
* sizeof (scm_cell
));
2055 if ((scm_sizet
) SCM_EXPHEAP (freelistp
->heap_size
* sizeof (scm_cell
))
2060 len
= SCM_HEAP_SEG_SIZE
;
2065 smallest
= (freelistp
->span
* sizeof (scm_cell
));
2067 len
= (freelistp
->span
* sizeof (scm_cell
));
2069 /* Allocate with decaying ambition. */
2070 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2071 && (len
>= smallest
))
2073 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
2076 init_heap_seg (ptr
, len
, freelistp
);
2083 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2088 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2091 #define FUNC_NAME s_scm_unhash_name
2095 SCM_VALIDATE_SYMBOL (1,name
);
2097 bound
= scm_n_heap_segs
;
2098 for (x
= 0; x
< bound
; ++x
)
2102 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
2103 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
2108 if (1 == (7 & (int)incar
))
2111 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
2112 && (SCM_CDR (incar
) != 0)
2113 && (SCM_UNPACK (SCM_CDR (incar
)) != 1))
2128 /* {GC Protection Helper Functions}
2133 scm_remember (SCM
*ptr
)
2138 These crazy functions prevent garbage collection
2139 of arguments after the first argument by
2140 ensuring they remain live throughout the
2141 function because they are used in the last
2142 line of the code block.
2143 It'd be better to have a nice compiler hint to
2144 aid the conservative stack-scanning GC. --03/09/00 gjb */
2146 scm_return_first (SCM elt
, ...)
2152 scm_return_first_int (int i
, ...)
2159 scm_permanent_object (SCM obj
)
2162 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2168 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2169 even if all other references are dropped, until someone applies
2170 scm_unprotect_object to it. This function returns OBJ.
2172 Calls to scm_protect_object nest. For every object OBJ, there is a
2173 counter which scm_protect_object(OBJ) increments and
2174 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2175 an object's counter is greater than zero, the garbage collector
2178 Of course, that's not how it's implemented. scm_protect_object and
2179 scm_unprotect_object just maintain a list of references to things.
2180 Since the GC knows about this list, all objects it mentions stay
2181 alive. scm_protect_object adds its argument to the list;
2182 scm_unprotect_object removes the first occurrence of its argument
2185 scm_protect_object (SCM obj
)
2187 scm_protects
= scm_cons (obj
, scm_protects
);
2193 /* Remove any protection for OBJ established by a prior call to
2194 scm_protect_object. This function returns OBJ.
2196 See scm_protect_object for more information. */
2198 scm_unprotect_object (SCM obj
)
2200 SCM
*tail_ptr
= &scm_protects
;
2202 while (SCM_CONSP (*tail_ptr
))
2203 if (SCM_CAR (*tail_ptr
) == obj
)
2205 *tail_ptr
= SCM_CDR (*tail_ptr
);
2209 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
2216 /* called on process termination. */
2222 extern int on_exit (void (*procp
) (), int arg
);
2225 cleanup (int status
, void *arg
)
2227 #error Dont know how to setup a cleanup handler on your system.
2232 scm_flush_all_ports ();
2237 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelistp
)
2239 if (0L == init_heap_size
)
2240 init_heap_size
= SCM_INIT_HEAP_SIZE
;
2241 if (!init_heap_seg ((SCM_CELLPTR
) malloc (init_heap_size
),
2245 init_heap_size
= SCM_HEAP_SEG_SIZE
;
2246 if (!init_heap_seg ((SCM_CELLPTR
) malloc (init_heap_size
),
2258 #ifdef GUILE_NEW_GC_SCHEME
2260 scm_init_storage (scm_sizet init_heap_size
, int gc_trigger
,
2261 scm_sizet init_heap2_size
, int gc_trigger2
)
2264 scm_init_storage (scm_sizet init_heap_size
, scm_sizet init_heap2_size
)
2269 j
= SCM_NUM_PROTECTS
;
2271 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2274 #ifdef GUILE_NEW_GC_SCHEME
2275 scm_freelist
= SCM_EOL
;
2276 scm_master_freelist
.clusters
= SCM_EOL
;
2277 scm_master_freelist
.triggeredp
= 0;
2278 scm_master_freelist
.gc_trigger
2279 = gc_trigger
? gc_trigger
: SCM_GC_TRIGGER
;
2280 scm_master_freelist
.span
= 1;
2281 scm_master_freelist
.collected
= 0;
2282 scm_master_freelist
.heap_size
= 0;
2284 scm_freelist
.cells
= SCM_EOL
;
2285 scm_freelist
.span
= 1;
2286 scm_freelist
.collected
= 0;
2287 scm_freelist
.heap_size
= 0;
2290 #ifdef GUILE_NEW_GC_SCHEME
2291 scm_freelist2
= SCM_EOL
;
2292 scm_master_freelist2
.clusters
= SCM_EOL
;
2293 scm_master_freelist2
.triggeredp
= 0;
2294 scm_master_freelist2
.gc_trigger
2295 = gc_trigger2
? gc_trigger2
: SCM_GC_TRIGGER2
;
2296 scm_master_freelist2
.span
= 2;
2297 scm_master_freelist2
.collected
= 0;
2298 scm_master_freelist2
.heap_size
= 0;
2300 scm_freelist2
.cells
= SCM_EOL
;
2301 scm_freelist2
.span
= 2;
2302 scm_freelist2
.collected
= 0;
2303 scm_freelist2
.heap_size
= 0;
2308 j
= SCM_HEAP_SEG_SIZE
;
2309 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2310 scm_heap_table
= ((struct scm_heap_seg_data
*)
2311 scm_must_malloc (sizeof (struct scm_heap_seg_data
) * 2, "hplims"));
2313 #ifdef GUILE_NEW_GC_SCHEME
2314 if (make_initial_segment (init_heap_size
, &scm_master_freelist
) ||
2315 make_initial_segment (init_heap2_size
, &scm_master_freelist2
))
2318 if (make_initial_segment (init_heap_size
, &scm_freelist
) ||
2319 make_initial_segment (init_heap2_size
, &scm_freelist2
))
2323 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
2325 /* scm_hplims[0] can change. do not remove scm_heap_org */
2326 scm_weak_vectors
= SCM_EOL
;
2328 /* Initialise the list of ports. */
2329 scm_port_table
= (scm_port
**)
2330 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2331 if (!scm_port_table
)
2338 on_exit (cleanup
, 0);
2342 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2343 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2345 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2346 scm_nullstr
= scm_makstr (0L, 0);
2347 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2348 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2349 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
2350 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2351 scm_stand_in_procs
= SCM_EOL
;
2352 scm_permobjs
= SCM_EOL
;
2353 scm_protects
= SCM_EOL
;
2354 scm_asyncs
= SCM_EOL
;
2355 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2356 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2358 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));