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 */
52 #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_1 (40000L * sizeof (scm_cell))
113 #define SCM_CLUSTER_SIZE_1 2000L
114 #define SCM_GC_TRIGGER_1 -50
116 #define SCM_INIT_HEAP_SIZE_2 (2500L * 2 * sizeof (scm_cell))
117 #define SCM_CLUSTER_SIZE_2 1000L
118 /* The following value may seem large, but note that if we get to GC at
119 * all, this means that we have a numerically intensive application
121 #define SCM_GC_TRIGGER_2 -50
123 #define SCM_MAX_SEGMENT_SIZE 2097000L /* a little less (adm) than 2 Mb */
125 #define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell))
127 # define SCM_HEAP_SEG_SIZE 32768L
130 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
132 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
135 /* Make heap grow with factor 1.5 */
136 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
137 #define SCM_INIT_MALLOC_LIMIT 100000
138 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
140 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
141 bounds for allocated storage */
144 /*in 386 protected mode we must only adjust the offset */
145 # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
146 # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
149 # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
150 # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
152 # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
153 # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
162 #ifdef GUILE_NEW_GC_SCHEME
163 SCM scm_freelist
= SCM_EOL
;
164 scm_freelist_t scm_master_freelist
= {
165 SCM_EOL
, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
167 SCM scm_freelist2
= SCM_EOL
;
168 scm_freelist_t scm_master_freelist2
= {
169 SCM_EOL
, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
172 scm_freelist_t scm_freelist
= { SCM_EOL
, 1, 0, 0 };
173 scm_freelist_t scm_freelist2
= { SCM_EOL
, 2, 0, 0 };
177 * is the number of bytes of must_malloc allocation needed to trigger gc.
179 unsigned long scm_mtrigger
;
183 * If set, don't expand the heap. Set only during gc, during which no allocation
184 * is supposed to take place anyway.
186 int scm_gc_heap_lock
= 0;
189 * Don't pause for collection if this is set -- just
193 int scm_block_gc
= 1;
195 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
196 * collection (GC) more space is allocated for the heap.
198 #define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
200 /* During collection, this accumulates objects holding
203 SCM scm_weak_vectors
;
205 /* GC Statistics Keeping
207 unsigned long scm_cells_allocated
= 0;
208 long scm_mallocated
= 0;
209 /* unsigned long scm_gc_cells_collected; */
210 unsigned long scm_gc_malloc_collected
;
211 unsigned long scm_gc_ports_collected
;
212 unsigned long scm_gc_rt
;
213 unsigned long scm_gc_time_taken
= 0;
215 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
216 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
217 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
218 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
219 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
220 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
223 struct scm_heap_seg_data
225 /* lower and upper bounds of the segment */
226 SCM_CELLPTR bounds
[2];
228 /* address of the head-of-freelist pointer for this segment's cells.
229 All segments usually point to the same one, scm_freelist. */
230 scm_freelist_t
*freelist
;
232 /* number of SCM words per object in this segment */
235 /* If SEG_DATA->valid is non-zero, the conservative marking
236 functions will apply SEG_DATA->valid to the purported pointer and
237 SEG_DATA, and mark the object iff the function returns non-zero.
238 At the moment, I don't think anyone uses this. */
245 static void scm_mark_weak_vector_spines (void);
246 static scm_sizet
init_heap_seg (SCM_CELLPTR
, scm_sizet
, scm_freelist_t
*);
247 static void alloc_some_heap (scm_freelist_t
*);
251 /* Debugging functions. */
253 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
255 /* Return the number of the heap segment containing CELL. */
261 for (i
= 0; i
< scm_n_heap_segs
; i
++)
262 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], (SCM_CELLPTR
) cell
)
263 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], (SCM_CELLPTR
) cell
))
265 fprintf (stderr
, "which_seg: can't find segment containing cell %lx\n",
271 #ifdef GUILE_NEW_GC_SCHEME
273 map_free_list (scm_freelist_t
*master
, SCM freelist
)
275 int last_seg
= -1, count
= 0;
278 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
))
280 int this_seg
= which_seg (f
);
282 if (this_seg
!= last_seg
)
285 fprintf (stderr
, " %5d %d-cells in segment %d\n",
286 count
, master
->span
, last_seg
);
293 fprintf (stderr
, " %5d %d-cells in segment %d\n",
294 count
, master
->span
, last_seg
);
298 map_free_list (scm_freelist_t
*freelist
)
300 int last_seg
= -1, count
= 0;
303 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
))
305 int this_seg
= which_seg (f
);
307 if (this_seg
!= last_seg
)
310 fprintf (stderr
, " %5d %d-cells in segment %d\n",
311 count
, freelist
->span
, last_seg
);
318 fprintf (stderr
, " %5d %d-cells in segment %d\n",
319 count
, freelist
->span
, last_seg
);
323 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
325 "Print debugging information about the free-list.\n"
326 "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
327 #define FUNC_NAME s_scm_map_free_list
330 fprintf (stderr
, "%d segments total (%d:%d",
332 scm_heap_table
[0].span
,
333 scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]);
334 for (i
= 1; i
< scm_n_heap_segs
; i
++)
335 fprintf (stderr
, ", %d:%d",
336 scm_heap_table
[i
].span
,
337 scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]);
338 fprintf (stderr
, ")\n");
339 #ifdef GUILE_NEW_GC_SCHEME
340 map_free_list (&scm_master_freelist
, scm_freelist
);
341 map_free_list (&scm_master_freelist2
, scm_freelist2
);
343 map_free_list (&scm_freelist
);
344 map_free_list (&scm_freelist2
);
348 return SCM_UNSPECIFIED
;
352 #ifdef GUILE_NEW_GC_SCHEME
353 static int last_cluster
;
354 static int last_size
;
357 free_list_length (char *title
, int i
, SCM freelist
)
361 for (ls
= freelist
; SCM_NNULLP (ls
); ls
= SCM_CDR (ls
))
362 if (SCM_UNPACK_CAR (ls
) == scm_tc_free_cell
)
366 fprintf (stderr
, "bad cell in %s at position %d\n", title
, n
);
373 if (last_cluster
== i
- 1)
374 fprintf (stderr
, "\t%d\n", last_size
);
376 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
379 fprintf (stderr
, "%s %d", title
, i
);
381 fprintf (stderr
, "%s\t%d\n", title
, n
);
389 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
392 int i
= 0, len
, n
= 0;
393 fprintf (stderr
, "%s\n\n", title
);
394 n
+= free_list_length ("free list", -1, freelist
);
395 for (clusters
= master
->clusters
;
396 SCM_NNULLP (clusters
);
397 clusters
= SCM_CDR (clusters
))
399 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
402 if (last_cluster
== i
- 1)
403 fprintf (stderr
, "\t%d\n", last_size
);
405 fprintf (stderr
, "-%d\t%d\n", i
- 1, last_size
);
406 fprintf (stderr
, "\ntotal %d objects\n\n", n
);
409 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
411 "Print debugging information about the free-list.\n"
412 "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
413 #define FUNC_NAME s_scm_free_list_length
415 free_list_lengths ("1-words", &scm_master_freelist
, scm_freelist
);
416 free_list_lengths ("2-words", &scm_master_freelist2
, scm_freelist2
);
417 return SCM_UNSPECIFIED
;
424 #ifdef GUILE_DEBUG_FREELIST
426 /* Number of calls to SCM_NEWCELL since startup. */
427 static unsigned long scm_newcell_count
;
428 static unsigned long scm_newcell2_count
;
430 /* Search freelist for anything that isn't marked as a free cell.
431 Abort if we find something. */
432 #ifdef GUILE_NEW_GC_SCHEME
434 scm_check_freelist (SCM freelist
)
439 for (f
= freelist
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
440 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
442 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
443 scm_newcell_count
, i
);
450 scm_check_freelist (scm_freelist_t
*freelist
)
455 for (f
= freelist
->cells
; SCM_NIMP (f
); f
= SCM_CDR (f
), i
++)
456 if (SCM_CAR (f
) != (SCM
) scm_tc_free_cell
)
458 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %d'th elt\n",
459 scm_newcell_count
, i
);
466 static int scm_debug_check_freelist
= 0;
468 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
470 "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
471 "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
472 "compile-time flag was selected.\n")
473 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
475 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
476 return SCM_UNSPECIFIED
;
481 #ifdef GUILE_NEW_GC_SCHEME
484 scm_debug_newcell (void)
489 if (scm_debug_check_freelist
)
491 scm_check_freelist (scm_freelist
);
495 /* The rest of this is supposed to be identical to the SCM_NEWCELL
497 if (SCM_IMP (scm_freelist
))
498 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
502 scm_freelist
= SCM_CDR (scm_freelist
);
503 SCM_SETCAR (new, scm_tc16_allocated
);
510 scm_debug_newcell2 (void)
514 scm_newcell2_count
++;
515 if (scm_debug_check_freelist
)
517 scm_check_freelist (scm_freelist2
);
521 /* The rest of this is supposed to be identical to the SCM_NEWCELL
523 if (SCM_IMP (scm_freelist2
))
524 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
528 scm_freelist2
= SCM_CDR (scm_freelist2
);
529 SCM_SETCAR (new, scm_tc16_allocated
);
535 #else /* GUILE_NEW_GC_SCHEME */
538 scm_debug_newcell (void)
543 if (scm_debug_check_freelist
)
545 scm_check_freelist (&scm_freelist
);
549 /* The rest of this is supposed to be identical to the SCM_NEWCELL
551 if (SCM_IMP (scm_freelist
.cells
))
552 new = scm_gc_for_newcell (&scm_freelist
);
555 new = scm_freelist
.cells
;
556 scm_freelist
.cells
= SCM_CDR (scm_freelist
.cells
);
557 SCM_SETCAR (new, scm_tc16_allocated
);
558 ++scm_cells_allocated
;
565 scm_debug_newcell2 (void)
569 scm_newcell2_count
++;
570 if (scm_debug_check_freelist
) {
571 scm_check_freelist (&scm_freelist2
);
575 /* The rest of this is supposed to be identical to the SCM_NEWCELL2
577 if (SCM_IMP (scm_freelist2
.cells
))
578 new = scm_gc_for_newcell (&scm_freelist2
);
581 new = scm_freelist2
.cells
;
582 scm_freelist2
.cells
= SCM_CDR (scm_freelist2
.cells
);
583 SCM_SETCAR (new, scm_tc16_allocated
);
584 scm_cells_allocated
+= 2;
590 #endif /* GUILE_NEW_GC_SCHEME */
591 #endif /* GUILE_DEBUG_FREELIST */
595 /* {Scheme Interface to GC}
598 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
600 "Returns an association list of statistics about Guile's current use of storage. ")
601 #define FUNC_NAME s_scm_gc_stats
606 long int local_scm_mtrigger
;
607 long int local_scm_mallocated
;
608 long int local_scm_heap_size
;
609 long int local_scm_cells_allocated
;
610 long int local_scm_gc_time_taken
;
618 for (i
= scm_n_heap_segs
; i
--; )
619 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
620 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
622 if (scm_n_heap_segs
!= n
)
627 local_scm_mtrigger
= scm_mtrigger
;
628 local_scm_mallocated
= scm_mallocated
;
629 #ifdef GUILE_NEW_GC_SCHEME
630 local_scm_heap_size
= scm_master_freelist
.heap_size
; /*fixme*/
632 local_scm_heap_size
= scm_freelist
.heap_size
; /*fixme*/
634 local_scm_cells_allocated
= scm_cells_allocated
;
635 local_scm_gc_time_taken
= scm_gc_time_taken
;
637 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
638 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
639 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
640 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
641 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
642 scm_cons (sym_heap_segments
, heap_segs
),
651 scm_gc_start (const char *what
)
653 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ());
654 /* scm_gc_cells_collected = 0; */
655 scm_gc_malloc_collected
= 0;
656 scm_gc_ports_collected
= 0;
662 scm_gc_rt
= SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt
;
663 scm_gc_time_taken
+= scm_gc_rt
;
664 scm_system_async_mark (scm_gc_async
);
668 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
670 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
671 "returned by this function for @var{obj}")
672 #define FUNC_NAME s_scm_object_address
674 return scm_ulong2num ((unsigned long) obj
);
679 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
681 "Scans all of SCM objects and reclaims for further use those that are\n"
682 "no longer accessible.")
683 #define FUNC_NAME s_scm_gc
688 return SCM_UNSPECIFIED
;
694 /* {C Interface For When GC is Triggered}
697 #ifdef GUILE_NEW_GC_SCHEME
699 /* When we get POSIX threads support, the master will be global and
700 * common while the freelist will be individual for each thread.
704 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
710 if (SCM_NULLP (master
->clusters
))
712 if (master
->grow_heap_p
)
714 master
->grow_heap_p
= 0;
715 alloc_some_heap (master
);
720 cell
= SCM_CAR (master
->clusters
);
721 master
->clusters
= SCM_CDR (master
->clusters
);
723 while (SCM_NULLP (cell
));
725 *freelist
= SCM_CDR (cell
);
726 SCM_SETCAR (cell
, scm_tc16_allocated
);
731 /* This is a support routine which can be used to reserve a cluster
732 * for some special use, such as debugging. It won't be useful until
733 * free cells are preserved between garbage collections.
737 scm_alloc_cluster (scm_freelist_t
*master
)
740 cell
= scm_gc_for_newcell (master
, &freelist
);
741 SCM_SETCDR (cell
, freelist
);
746 #else /* GUILE_NEW_GC_SCHEME */
749 scm_gc_for_alloc (scm_freelist_t
*freelist
)
753 #ifdef GUILE_DEBUG_FREELIST
754 fprintf (stderr
, "Collected: %d, min_yield: %d\n",
755 freelist
->collected
, MIN_GC_YIELD (freelist
));
757 if ((freelist
->collected
< MIN_GC_YIELD (freelist
))
758 || SCM_IMP (freelist
->cells
))
759 alloc_some_heap (freelist
);
765 scm_gc_for_newcell (scm_freelist_t
*freelist
)
768 scm_gc_for_alloc (freelist
);
769 fl
= freelist
->cells
;
770 freelist
->cells
= SCM_CDR (fl
);
771 SCM_SETCAR (fl
, scm_tc16_allocated
);
775 #endif /* GUILE_NEW_GC_SCHEME */
778 scm_igc (const char *what
)
784 SCM_NULLP (scm_freelist
)
786 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
789 /* During the critical section, only the current thread may run. */
790 SCM_THREAD_CRITICAL_SECTION_START
;
793 /* fprintf (stderr, "gc: %s\n", what); */
797 if (!scm_stack_base
|| scm_block_gc
)
803 if (scm_mallocated
< 0)
804 /* The byte count of allocated objects has underflowed. This is
805 probably because you forgot to report the sizes of objects you
806 have allocated, by calling scm_done_malloc or some such. When
807 the GC freed them, it subtracted their size from
808 scm_mallocated, which underflowed. */
811 if (scm_gc_heap_lock
)
812 /* We've invoked the collector while a GC is already in progress.
813 That should never happen. */
818 scm_weak_vectors
= SCM_EOL
;
820 scm_guardian_gc_init ();
822 /* unprotect any struct types with no instances */
828 pos
= &scm_type_obj_list
;
829 type_list
= scm_type_obj_list
;
830 while (type_list
!= SCM_EOL
)
831 if (SCM_VELTS (SCM_CAR (type_list
))[scm_struct_i_refcnt
])
833 pos
= SCM_CDRLOC (type_list
);
834 type_list
= SCM_CDR (type_list
);
838 *pos
= SCM_CDR (type_list
);
839 type_list
= SCM_CDR (type_list
);
844 /* flush dead entries from the continuation stack */
849 elts
= SCM_VELTS (scm_continuation_stack
);
850 bound
= SCM_LENGTH (scm_continuation_stack
);
851 x
= SCM_INUM (scm_continuation_stack_ptr
);
854 elts
[x
] = SCM_BOOL_F
;
861 /* Protect from the C stack. This must be the first marking
862 * done because it provides information about what objects
863 * are "in-use" by the C code. "in-use" objects are those
864 * for which the values from SCM_LENGTH and SCM_CHARS must remain
865 * usable. This requirement is stricter than a liveness
866 * requirement -- in particular, it constrains the implementation
867 * of scm_vector_set_length_x.
869 SCM_FLUSH_REGISTER_WINDOWS
;
870 /* This assumes that all registers are saved into the jmp_buf */
871 setjmp (scm_save_regs_gc_mark
);
872 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
873 ( (scm_sizet
) (sizeof (SCM_STACKITEM
) - 1 +
874 sizeof scm_save_regs_gc_mark
)
875 / sizeof (SCM_STACKITEM
)));
878 /* stack_len is long rather than scm_sizet in order to guarantee that
879 &stack_len is long aligned */
880 #ifdef SCM_STACK_GROWS_UP
882 long stack_len
= (SCM_STACKITEM
*) (&stack_len
) - scm_stack_base
;
884 long stack_len
= scm_stack_size (scm_stack_base
);
886 scm_mark_locations (scm_stack_base
, (scm_sizet
) stack_len
);
889 long stack_len
= scm_stack_base
- (SCM_STACKITEM
*) (&stack_len
);
891 long stack_len
= scm_stack_size (scm_stack_base
);
893 scm_mark_locations ((scm_stack_base
- stack_len
), (scm_sizet
) stack_len
);
897 #else /* USE_THREADS */
899 /* Mark every thread's stack and registers */
900 scm_threads_mark_stacks ();
902 #endif /* USE_THREADS */
904 /* FIXME: insert a phase to un-protect string-data preserved
905 * in scm_vector_set_length_x.
908 j
= SCM_NUM_PROTECTS
;
910 scm_gc_mark (scm_sys_protects
[j
]);
912 /* FIXME: we should have a means to register C functions to be run
913 * in different phases of GC
915 scm_mark_subr_table ();
918 scm_gc_mark (scm_root
->handle
);
921 scm_mark_weak_vector_spines ();
923 scm_guardian_zombify ();
931 SCM_THREAD_CRITICAL_SECTION_END
;
941 /* Mark an object precisely.
956 if (SCM_NCELLP (ptr
))
957 scm_wta (ptr
, "rogue pointer in heap", NULL
);
959 switch (SCM_TYP7 (ptr
))
961 case scm_tcs_cons_nimcar
:
962 if (SCM_GCMARKP (ptr
))
965 if (SCM_IMP (SCM_CDR (ptr
))) /* SCM_IMP works even with a GC mark */
970 scm_gc_mark (SCM_CAR (ptr
));
971 ptr
= SCM_GCCDR (ptr
);
973 case scm_tcs_cons_imcar
:
974 if (SCM_GCMARKP (ptr
))
977 ptr
= SCM_GCCDR (ptr
);
980 if (SCM_GCMARKP (ptr
))
983 scm_gc_mark (SCM_CELL_WORD (ptr
, 2));
984 ptr
= SCM_GCCDR (ptr
);
986 case scm_tcs_cons_gloc
:
987 if (SCM_GCMARKP (ptr
))
992 vcell
= SCM_CAR (ptr
) - 1L;
993 switch (SCM_UNPACK (SCM_CDR (vcell
)))
997 ptr
= SCM_GCCDR (ptr
);
1009 vtable_data
= (SCM
*)vcell
;
1010 layout
= vtable_data
[scm_vtable_index_layout
];
1011 len
= SCM_LENGTH (layout
);
1012 fields_desc
= SCM_CHARS (layout
);
1013 /* We're using SCM_GCCDR here like STRUCT_DATA, except
1014 that it removes the mark */
1015 mem
= (SCM
*)SCM_GCCDR (ptr
);
1017 if (SCM_UNPACK (vtable_data
[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
1019 scm_gc_mark (mem
[scm_struct_i_procedure
]);
1020 scm_gc_mark (mem
[scm_struct_i_setter
]);
1024 for (x
= 0; x
< len
- 2; x
+= 2, ++mem
)
1025 if (fields_desc
[x
] == 'p')
1027 if (fields_desc
[x
] == 'p')
1030 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1031 for (j
= (long int) *mem
; x
; --x
)
1032 scm_gc_mark (*++mem
);
1037 if (!SCM_CDR (vcell
))
1039 SCM_SETGCMARK (vcell
);
1040 ptr
= vtable_data
[scm_vtable_index_vtable
];
1047 case scm_tcs_closures
:
1048 if (SCM_GCMARKP (ptr
))
1050 SCM_SETGCMARK (ptr
);
1051 if (SCM_IMP (SCM_CDR (ptr
)))
1053 ptr
= SCM_CLOSCAR (ptr
);
1056 scm_gc_mark (SCM_CLOSCAR (ptr
));
1057 ptr
= SCM_GCCDR (ptr
);
1059 case scm_tc7_vector
:
1060 case scm_tc7_lvector
:
1064 if (SCM_GC8MARKP (ptr
))
1066 SCM_SETGC8MARK (ptr
);
1067 i
= SCM_LENGTH (ptr
);
1071 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1072 scm_gc_mark (SCM_VELTS (ptr
)[i
]);
1073 ptr
= SCM_VELTS (ptr
)[0];
1075 case scm_tc7_contin
:
1078 SCM_SETGC8MARK (ptr
);
1079 if (SCM_VELTS (ptr
))
1080 scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr
),
1083 (sizeof (SCM_STACKITEM
) + -1 +
1084 sizeof (scm_contregs
)) /
1085 sizeof (SCM_STACKITEM
)));
1089 case scm_tc7_byvect
:
1096 #ifdef HAVE_LONG_LONGS
1097 case scm_tc7_llvect
:
1100 case scm_tc7_string
:
1101 SCM_SETGC8MARK (ptr
);
1104 case scm_tc7_substring
:
1105 if (SCM_GC8MARKP(ptr
))
1107 SCM_SETGC8MARK (ptr
);
1108 ptr
= SCM_CDR (ptr
);
1112 if (SCM_GC8MARKP(ptr
))
1114 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1115 scm_weak_vectors
= ptr
;
1116 SCM_SETGC8MARK (ptr
);
1117 if (SCM_IS_WHVEC_ANY (ptr
))
1124 len
= SCM_LENGTH (ptr
);
1125 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1126 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1128 for (x
= 0; x
< len
; ++x
)
1131 alist
= SCM_VELTS (ptr
)[x
];
1133 /* mark everything on the alist except the keys or
1134 * values, according to weak_values and weak_keys. */
1135 while ( SCM_CONSP (alist
)
1136 && !SCM_GCMARKP (alist
)
1137 && SCM_CONSP (SCM_CAR (alist
)))
1142 kvpair
= SCM_CAR (alist
);
1143 next_alist
= SCM_CDR (alist
);
1146 * SCM_SETGCMARK (alist);
1147 * SCM_SETGCMARK (kvpair);
1149 * It may be that either the key or value is protected by
1150 * an escaped reference to part of the spine of this alist.
1151 * If we mark the spine here, and only mark one or neither of the
1152 * key and value, they may never be properly marked.
1153 * This leads to a horrible situation in which an alist containing
1154 * freelist cells is exported.
1156 * So only mark the spines of these arrays last of all marking.
1157 * If somebody confuses us by constructing a weak vector
1158 * with a circular alist then we are hosed, but at least we
1159 * won't prematurely drop table entries.
1162 scm_gc_mark (SCM_CAR (kvpair
));
1164 scm_gc_mark (SCM_GCCDR (kvpair
));
1167 if (SCM_NIMP (alist
))
1168 scm_gc_mark (alist
);
1173 case scm_tc7_msymbol
:
1174 if (SCM_GC8MARKP(ptr
))
1176 SCM_SETGC8MARK (ptr
);
1177 scm_gc_mark (SCM_SYMBOL_FUNC (ptr
));
1178 ptr
= SCM_SYMBOL_PROPS (ptr
);
1180 case scm_tc7_ssymbol
:
1181 if (SCM_GC8MARKP(ptr
))
1183 SCM_SETGC8MARK (ptr
);
1188 i
= SCM_PTOBNUM (ptr
);
1189 if (!(i
< scm_numptob
))
1191 if (SCM_GC8MARKP (ptr
))
1193 SCM_SETGC8MARK (ptr
);
1194 if (SCM_PTAB_ENTRY(ptr
))
1195 scm_gc_mark (SCM_PTAB_ENTRY(ptr
)->file_name
);
1196 if (scm_ptobs
[i
].mark
)
1198 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1205 if (SCM_GC8MARKP (ptr
))
1207 SCM_SETGC8MARK (ptr
);
1208 switch (SCM_GCTYP16 (ptr
))
1209 { /* should be faster than going through scm_smobs */
1210 case scm_tc_free_cell
:
1211 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1212 case scm_tc16_allocated
:
1215 case scm_tc16_complex
:
1218 i
= SCM_SMOBNUM (ptr
);
1219 if (!(i
< scm_numsmob
))
1221 if (scm_smobs
[i
].mark
)
1223 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1231 def
:scm_wta (ptr
, "unknown type in ", "gc_mark");
1236 /* Mark a Region Conservatively
1240 scm_mark_locations (SCM_STACKITEM x
[], scm_sizet n
)
1242 register long m
= n
;
1244 register SCM_CELLPTR ptr
;
1247 if (SCM_CELLP (*(SCM
**) (& x
[m
])))
1249 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & x
[m
]));
1251 j
= scm_n_heap_segs
- 1;
1252 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1253 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1260 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1262 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1270 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1274 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1279 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1283 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1289 if ( !scm_heap_table
[seg_id
].valid
1290 || scm_heap_table
[seg_id
].valid (ptr
,
1291 &scm_heap_table
[seg_id
]))
1292 scm_gc_mark (*(SCM
*) & x
[m
]);
1301 /* The following is a C predicate which determines if an SCM value can be
1302 regarded as a pointer to a cell on the heap. The code is duplicated
1303 from scm_mark_locations. */
1307 scm_cellp (SCM value
)
1310 register SCM_CELLPTR ptr
;
1312 if SCM_CELLP (*(SCM
**) (& value
))
1314 ptr
= (SCM_CELLPTR
) SCM2PTR ((*(SCM
**) & value
));
1316 j
= scm_n_heap_segs
- 1;
1317 if ( SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1318 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1325 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1327 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1335 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1339 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1344 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1348 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1354 if ( !scm_heap_table
[seg_id
].valid
1355 || scm_heap_table
[seg_id
].valid (ptr
,
1356 &scm_heap_table
[seg_id
]))
1368 scm_mark_weak_vector_spines ()
1372 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1374 if (SCM_IS_WHVEC_ANY (w
))
1382 ptr
= SCM_VELTS (w
);
1384 for (j
= 0; j
< n
; ++j
)
1389 while ( SCM_CONSP (alist
)
1390 && !SCM_GCMARKP (alist
)
1391 && SCM_CONSP (SCM_CAR (alist
)))
1393 SCM_SETGCMARK (alist
);
1394 SCM_SETGCMARK (SCM_CAR (alist
));
1395 alist
= SCM_GCCDR (alist
);
1403 #ifdef GUILE_NEW_GC_SCHEME
1405 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1407 freelist
->cells
= SCM_EOL
;
1408 freelist
->left_to_collect
= freelist
->cluster_size
;
1409 freelist
->clusters
= SCM_EOL
;
1410 freelist
->clustertail
= &freelist
->clusters
;
1411 freelist
->collected
= 0;
1415 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1417 *freelist
->clustertail
= freelist
->cells
;
1418 if (SCM_NNULLP (freelist
->cells
))
1420 SCM c
= freelist
->cells
;
1421 SCM_SETCAR (c
, SCM_CDR (c
));
1422 SCM_SETCDR (c
, SCM_EOL
);
1423 freelist
->collected
+=
1424 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1427 freelist
->grow_heap_p
= (freelist
->collected
< freelist
->gc_trigger
);
1434 register SCM_CELLPTR ptr
;
1435 #ifdef SCM_POINTERS_MUNGED
1436 register SCM scmptr
;
1439 #define scmptr (SCM)ptr
1441 register SCM nfreelist
;
1442 register scm_freelist_t
*freelist
;
1450 #ifdef GUILE_NEW_GC_SCHEME
1451 gc_sweep_freelist_start (&scm_master_freelist
);
1452 gc_sweep_freelist_start (&scm_master_freelist2
);
1454 /* Reset all free list pointers. We'll reconstruct them completely
1456 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1457 scm_heap_table
[i
].freelist
->cells
= SCM_EOL
;
1460 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1462 #ifdef GUILE_NEW_GC_SCHEME
1463 register unsigned int left_to_collect
;
1465 register scm_sizet n
= 0;
1467 register scm_sizet j
;
1469 /* Unmarked cells go onto the front of the freelist this heap
1470 segment points to. Rather than updating the real freelist
1471 pointer as we go along, we accumulate the new head in
1472 nfreelist. Then, if it turns out that the entire segment is
1473 free, we free (i.e., malloc's free) the whole segment, and
1474 simply don't assign nfreelist back into the real freelist. */
1475 freelist
= scm_heap_table
[i
].freelist
;
1476 nfreelist
= freelist
->cells
;
1477 #ifdef GUILE_NEW_GC_SCHEME
1478 left_to_collect
= freelist
->left_to_collect
;
1480 span
= scm_heap_table
[i
].span
;
1482 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0]);
1483 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1]) - ptr
;
1484 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1486 #ifdef SCM_POINTERS_MUNGED
1487 scmptr
= PTR2SCM (ptr
);
1489 switch SCM_TYP7 (scmptr
)
1491 case scm_tcs_cons_gloc
:
1492 if (SCM_GCMARKP (scmptr
))
1494 if (SCM_CDR (SCM_CAR (scmptr
) - 1) == (SCM
)1)
1495 SCM_SETCDR (SCM_CAR (scmptr
) - 1, (SCM
) 0);
1500 vcell
= SCM_CAR (scmptr
) - 1L;
1502 if ((SCM_CDR (vcell
) == 0) || (SCM_UNPACK (SCM_CDR (vcell
)) == 1))
1504 scm_struct_free_t free
1505 = (scm_struct_free_t
) ((SCM
*) vcell
)[scm_struct_i_free
];
1506 m
+= free ((SCM
*) vcell
, (SCM
*) SCM_GCCDR (scmptr
));
1510 case scm_tcs_cons_imcar
:
1511 case scm_tcs_cons_nimcar
:
1512 case scm_tcs_closures
:
1514 if (SCM_GCMARKP (scmptr
))
1518 if (SCM_GC8MARKP (scmptr
))
1524 m
+= (2 + SCM_LENGTH (scmptr
)) * sizeof (SCM
);
1525 scm_must_free ((char *)(SCM_VELTS (scmptr
) - 2));
1529 case scm_tc7_vector
:
1530 case scm_tc7_lvector
:
1534 if (SCM_GC8MARKP (scmptr
))
1537 m
+= (SCM_LENGTH (scmptr
) * sizeof (SCM
));
1539 scm_must_free (SCM_CHARS (scmptr
));
1540 /* SCM_SETCHARS(scmptr, 0);*/
1544 if SCM_GC8MARKP (scmptr
)
1546 m
+= sizeof (long) * ((SCM_HUGE_LENGTH (scmptr
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1548 case scm_tc7_byvect
:
1549 if SCM_GC8MARKP (scmptr
)
1551 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (char);
1555 if SCM_GC8MARKP (scmptr
)
1557 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long);
1560 if SCM_GC8MARKP (scmptr
)
1562 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (short);
1564 #ifdef HAVE_LONG_LONGS
1565 case scm_tc7_llvect
:
1566 if SCM_GC8MARKP (scmptr
)
1568 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (long_long
);
1572 if SCM_GC8MARKP (scmptr
)
1574 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (float);
1577 if SCM_GC8MARKP (scmptr
)
1579 m
+= SCM_HUGE_LENGTH (scmptr
) * sizeof (double);
1582 if SCM_GC8MARKP (scmptr
)
1584 m
+= SCM_HUGE_LENGTH (scmptr
) * 2 * sizeof (double);
1587 case scm_tc7_substring
:
1588 if (SCM_GC8MARKP (scmptr
))
1591 case scm_tc7_string
:
1592 if (SCM_GC8MARKP (scmptr
))
1594 m
+= SCM_HUGE_LENGTH (scmptr
) + 1;
1596 case scm_tc7_msymbol
:
1597 if (SCM_GC8MARKP (scmptr
))
1599 m
+= ( SCM_LENGTH (scmptr
)
1601 + sizeof (SCM
) * ((SCM
*)SCM_CHARS (scmptr
) - SCM_SLOTS(scmptr
)));
1602 scm_must_free ((char *)SCM_SLOTS (scmptr
));
1604 case scm_tc7_contin
:
1605 if SCM_GC8MARKP (scmptr
)
1607 m
+= SCM_LENGTH (scmptr
) * sizeof (SCM_STACKITEM
) + sizeof (scm_contregs
);
1608 if (SCM_VELTS (scmptr
))
1610 case scm_tc7_ssymbol
:
1611 if SCM_GC8MARKP(scmptr
)
1617 if SCM_GC8MARKP (scmptr
)
1619 if SCM_OPENP (scmptr
)
1621 int k
= SCM_PTOBNUM (scmptr
);
1622 if (!(k
< scm_numptob
))
1624 /* Keep "revealed" ports alive. */
1625 if (scm_revealed_count (scmptr
) > 0)
1627 /* Yes, I really do mean scm_ptobs[k].free */
1628 /* rather than ftobs[k].close. .close */
1629 /* is for explicit CLOSE-PORT by user */
1630 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1631 SCM_SETSTREAM (scmptr
, 0);
1632 scm_remove_from_port_table (scmptr
);
1633 scm_gc_ports_collected
++;
1634 SCM_SETAND_CAR (scmptr
, ~SCM_OPN
);
1638 switch SCM_GCTYP16 (scmptr
)
1640 case scm_tc_free_cell
:
1642 if SCM_GC8MARKP (scmptr
)
1647 if SCM_GC8MARKP (scmptr
)
1649 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1651 #endif /* def SCM_BIGDIG */
1652 case scm_tc16_complex
:
1653 if SCM_GC8MARKP (scmptr
)
1655 m
+= 2 * sizeof (double);
1658 if SCM_GC8MARKP (scmptr
)
1663 k
= SCM_SMOBNUM (scmptr
);
1664 if (!(k
< scm_numsmob
))
1666 m
+= (scm_smobs
[k
].free
) ((SCM
) scmptr
);
1672 sweeperr
:scm_wta (scmptr
, "unknown type in ", "gc_sweep");
1675 if (SCM_CAR (scmptr
) == (SCM
) scm_tc_free_cell
)
1678 #ifndef GUILE_NEW_GC_SCHEME
1681 if (!--left_to_collect
)
1683 SCM_SETCAR (scmptr
, nfreelist
);
1684 *freelist
->clustertail
= scmptr
;
1685 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1687 nfreelist
= SCM_EOL
;
1688 freelist
->collected
+= span
* freelist
->cluster_size
;
1689 left_to_collect
= freelist
->cluster_size
;
1694 /* Stick the new cell on the front of nfreelist. It's
1695 critical that we mark this cell as freed; otherwise, the
1696 conservative collector might trace it as some other type
1698 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
1699 SCM_SETCDR (scmptr
, nfreelist
);
1705 SCM_CLRGC8MARK (scmptr
);
1708 SCM_CLRGCMARK (scmptr
);
1710 #ifdef GC_FREE_SEGMENTS
1715 freelist
->heap_size
-= seg_size
;
1716 free ((char *) scm_heap_table
[i
].bounds
[0]);
1717 scm_heap_table
[i
].bounds
[0] = 0;
1718 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1719 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1720 scm_n_heap_segs
-= 1;
1721 i
--; /* We need to scan the segment just moved. */
1724 #endif /* ifdef GC_FREE_SEGMENTS */
1726 /* Update the real freelist pointer to point to the head of
1727 the list of free cells we've built for this segment. */
1728 freelist
->cells
= nfreelist
;
1729 #ifdef GUILE_NEW_GC_SCHEME
1730 freelist
->left_to_collect
= left_to_collect
;
1734 #ifndef GUILE_NEW_GC_SCHEME
1735 freelist
->collected
+= n
;
1736 scm_cells_allocated
+= freelist
->heap_size
- freelist
->collected
;
1739 #ifdef GUILE_DEBUG_FREELIST
1740 #ifdef GUILE_NEW_GC_SCHEME
1741 scm_check_freelist (freelist
== &scm_master_freelist
1745 scm_check_freelist (freelist
);
1747 scm_map_free_list ();
1751 #ifdef GUILE_NEW_GC_SCHEME
1752 gc_sweep_freelist_finish (&scm_master_freelist
);
1753 gc_sweep_freelist_finish (&scm_master_freelist2
);
1755 /* When we move to POSIX threads private freelists should probably
1756 be GC-protected instead. */
1757 scm_freelist
= SCM_EOL
;
1758 scm_freelist2
= SCM_EOL
;
1761 /* Scan weak vectors. */
1764 for (w
= scm_weak_vectors
; w
!= SCM_EOL
; w
= SCM_WVECT_GC_CHAIN (w
))
1766 if (!SCM_IS_WHVEC_ANY (w
))
1770 ptr
= SCM_VELTS (w
);
1772 for (j
= 0; j
< n
; ++j
)
1773 if (SCM_FREEP (ptr
[j
]))
1774 ptr
[j
] = SCM_BOOL_F
;
1776 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
1779 register long n
= SCM_LENGTH (w
);
1782 ptr
= SCM_VELTS (w
);
1784 for (j
= 0; j
< n
; ++j
)
1791 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
1792 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
1797 while ( SCM_CONSP (alist
)
1798 && SCM_CONSP (SCM_CAR (alist
)))
1803 key
= SCM_CAAR (alist
);
1804 value
= SCM_CDAR (alist
);
1805 if ( (weak_keys
&& SCM_FREEP (key
))
1806 || (weak_values
&& SCM_FREEP (value
)))
1808 *fixup
= SCM_CDR (alist
);
1811 fixup
= SCM_CDRLOC (alist
);
1812 alist
= SCM_CDR (alist
);
1818 scm_mallocated
-= m
;
1819 scm_gc_malloc_collected
= m
;
1825 /* {Front end to malloc}
1827 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc
1829 * These functions provide services comperable to malloc, realloc, and
1830 * free. They are for allocating malloced parts of scheme objects.
1831 * The primary purpose of the front end is to impose calls to gc.
1835 * Return newly malloced storage or throw an error.
1837 * The parameter WHAT is a string for error reporting.
1838 * If the threshold scm_mtrigger will be passed by this
1839 * allocation, or if the first call to malloc fails,
1840 * garbage collect -- on the presumption that some objects
1841 * using malloced storage may be collected.
1843 * The limit scm_mtrigger may be raised by this allocation.
1846 scm_must_malloc (scm_sizet size
, const char *what
)
1849 unsigned long nm
= scm_mallocated
+ size
;
1851 if (nm
<= scm_mtrigger
)
1853 SCM_SYSCALL (ptr
= malloc (size
));
1856 scm_mallocated
= nm
;
1863 nm
= scm_mallocated
+ size
;
1864 SCM_SYSCALL (ptr
= malloc (size
));
1867 scm_mallocated
= nm
;
1868 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1869 if (nm
> scm_mtrigger
)
1870 scm_mtrigger
= nm
+ nm
/ 2;
1872 scm_mtrigger
+= scm_mtrigger
/ 2;
1877 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1878 return 0; /* never reached */
1883 * is similar to scm_must_malloc.
1886 scm_must_realloc (void *where
,
1892 scm_sizet nm
= scm_mallocated
+ size
- old_size
;
1894 if (nm
<= scm_mtrigger
)
1896 SCM_SYSCALL (ptr
= realloc (where
, size
));
1899 scm_mallocated
= nm
;
1906 nm
= scm_mallocated
+ size
- old_size
;
1907 SCM_SYSCALL (ptr
= realloc (where
, size
));
1910 scm_mallocated
= nm
;
1911 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1912 if (nm
> scm_mtrigger
)
1913 scm_mtrigger
= nm
+ nm
/ 2;
1915 scm_mtrigger
+= scm_mtrigger
/ 2;
1920 scm_wta (SCM_MAKINUM (size
), (char *) SCM_NALLOC
, what
);
1921 return 0; /* never reached */
1925 scm_must_free (void *obj
)
1930 scm_wta (SCM_INUM0
, "already free", "");
1933 /* Announce that there has been some malloc done that will be freed
1934 * during gc. A typical use is for a smob that uses some malloced
1935 * memory but can not get it from scm_must_malloc (for whatever
1936 * reason). When a new object of this smob is created you call
1937 * scm_done_malloc with the size of the object. When your smob free
1938 * function is called, be sure to include this size in the return
1942 scm_done_malloc (long size
)
1944 scm_mallocated
+= size
;
1946 if (scm_mallocated
> scm_mtrigger
)
1948 scm_igc ("foreign mallocs");
1949 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
1951 if (scm_mallocated
> scm_mtrigger
)
1952 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
1954 scm_mtrigger
+= scm_mtrigger
/ 2;
1960 #ifdef GUILE_NEW_GC_SCHEME
1962 adjust_gc_trigger (scm_freelist_t
*freelist
)
1964 /* Adjust GC trigger based on total heap size */
1965 if (freelist
->gc_trigger_fraction
)
1966 freelist
->gc_trigger
= ((scm_master_freelist
.heap_size
1967 + scm_master_freelist2
.heap_size
)
1968 * freelist
->gc_trigger_fraction
1978 * Each heap segment is an array of objects of a particular size.
1979 * Every segment has an associated (possibly shared) freelist.
1980 * A table of segment records is kept that records the upper and
1981 * lower extents of the segment; this is used during the conservative
1982 * phase of gc to identify probably gc roots (because they point
1983 * into valid segments at reasonable offsets). */
1986 * is true if the first segment was smaller than INIT_HEAP_SEG.
1987 * If scm_expmem is set to one, subsequent segment allocations will
1988 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
1992 scm_sizet scm_max_segment_size
;
1995 * is the lowest base address of any heap segment.
1997 SCM_CELLPTR scm_heap_org
;
1999 struct scm_heap_seg_data
* scm_heap_table
= 0;
2000 int scm_n_heap_segs
= 0;
2003 * initializes a new heap segment and return the number of objects it contains.
2005 * The segment origin, segment size in bytes, and the span of objects
2006 * in cells are input parameters. The freelist is both input and output.
2008 * This function presume that the scm_heap_table has already been expanded
2009 * to accomodate a new segment record.
2014 init_heap_seg (SCM_CELLPTR seg_org
, scm_sizet size
, scm_freelist_t
*freelist
)
2016 register SCM_CELLPTR ptr
;
2017 #ifdef SCM_POINTERS_MUNGED
2018 register SCM scmptr
;
2023 SCM_CELLPTR seg_end
;
2026 int span
= freelist
->span
;
2028 if (seg_org
== NULL
)
2033 size
= (size
/ sizeof (scm_cell
) / span
) * span
* sizeof (scm_cell
);
2035 /* Compute the ceiling on valid object pointers w/in this segment.
2037 seg_end
= CELL_DN ((char *) ptr
+ size
);
2039 /* Find the right place and insert the segment record.
2042 for (new_seg_index
= 0;
2043 ( (new_seg_index
< scm_n_heap_segs
)
2044 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2050 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2051 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2056 scm_heap_table
[new_seg_index
].valid
= 0;
2057 scm_heap_table
[new_seg_index
].span
= span
;
2058 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2059 scm_heap_table
[new_seg_index
].bounds
[0] = (SCM_CELLPTR
)ptr
;
2060 scm_heap_table
[new_seg_index
].bounds
[1] = (SCM_CELLPTR
)seg_end
;
2063 /* Compute the least valid object pointer w/in this segment
2065 ptr
= CELL_UP (ptr
);
2069 n_new_cells
= seg_end
- ptr
;
2071 #ifdef GUILE_NEW_GC_SCHEME
2073 freelist
->heap_size
+= n_new_cells
;
2075 /* Partition objects in this segment into clusters
2079 SCM
*clusterp
= &clusters
;
2080 int n_cluster_cells
= span
* freelist
->cluster_size
;
2082 while (n_new_cells
> span
) /* at least one spine + one freecell */
2084 /* Determine end of cluster
2086 if (n_new_cells
>= n_cluster_cells
)
2088 seg_end
= ptr
+ n_cluster_cells
;
2089 n_new_cells
-= n_cluster_cells
;
2093 seg_end
= ptr
+ n_new_cells
;
2097 /* Allocate cluster spine
2099 *clusterp
= PTR2SCM (ptr
);
2100 SCM_SETCAR (*clusterp
, PTR2SCM (ptr
+ span
));
2101 clusterp
= SCM_CDRLOC (*clusterp
);
2104 while (ptr
< seg_end
)
2106 #ifdef SCM_POINTERS_MUNGED
2107 scmptr
= PTR2SCM (ptr
);
2109 SCM_SETCAR (scmptr
, scm_tc_free_cell
);
2110 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2114 SCM_SETCDR (PTR2SCM (ptr
- span
), SCM_EOL
);
2117 /* Patch up the last cluster pointer in the segment
2118 * to join it to the input freelist.
2120 *clusterp
= freelist
->clusters
;
2121 freelist
->clusters
= clusters
;
2124 adjust_gc_trigger (&scm_master_freelist
);
2125 adjust_gc_trigger (&scm_master_freelist2
);
2127 #else /* GUILE_NEW_GC_SCHEME */
2129 /* Prepend objects in this segment to the freelist.
2131 while (ptr
< seg_end
)
2133 #ifdef SCM_POINTERS_MUNGED
2134 scmptr
= PTR2SCM (ptr
);
2136 SCM_SETCAR (scmptr
, (SCM
) scm_tc_free_cell
);
2137 SCM_SETCDR (scmptr
, PTR2SCM (ptr
+ span
));
2143 /* Patch up the last freelist pointer in the segment
2144 * to join it to the input freelist.
2146 SCM_SETCDR (PTR2SCM (ptr
), freelist
->cells
);
2147 freelist
->cells
= PTR2SCM (CELL_UP (seg_org
));
2149 freelist
->heap_size
+= n_new_cells
;
2151 #endif /* GUILE_NEW_GC_SCHEME */
2154 fprintf (stderr
, "H");
2164 alloc_some_heap (scm_freelist_t
*freelist
)
2166 struct scm_heap_seg_data
* tmptable
;
2170 /* Critical code sections (such as the garbage collector)
2171 * aren't supposed to add heap segments.
2173 if (scm_gc_heap_lock
)
2174 scm_wta (SCM_UNDEFINED
, "need larger initial", "heap");
2176 /* Expand the heap tables to have room for the new segment.
2177 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
2178 * only if the allocation of the segment itself succeeds.
2180 len
= (1 + scm_n_heap_segs
) * sizeof (struct scm_heap_seg_data
);
2182 SCM_SYSCALL (tmptable
= ((struct scm_heap_seg_data
*)
2183 realloc ((char *)scm_heap_table
, len
)));
2185 scm_wta (SCM_UNDEFINED
, "could not grow", "hplims");
2187 scm_heap_table
= tmptable
;
2190 /* Pick a size for the new heap segment.
2191 * The rule for picking the size of a segment is explained in
2194 #ifdef GUILE_NEW_GC_SCHEME
2196 /* Assure that the new segment is large enough for the new trigger */
2197 int slack
= freelist
->gc_trigger
- freelist
->collected
;
2198 int min_cells
= 100 * slack
/ (99 - freelist
->gc_trigger_fraction
);
2199 len
= SCM_EXPHEAP (freelist
->heap_size
);
2201 fprintf (stderr
, "(%d < %d)", len
, min_cells
);
2203 if (len
< min_cells
)
2204 len
= min_cells
+ 1;
2205 len
*= sizeof (scm_cell
);
2208 if (len
> scm_max_segment_size
)
2209 len
= scm_max_segment_size
;
2213 len
= (scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
));
2214 if ((scm_sizet
) SCM_EXPHEAP (freelist
->heap_size
* sizeof (scm_cell
))
2219 len
= SCM_HEAP_SEG_SIZE
;
2220 #endif /* GUILE_NEW_GC_SCHEME */
2225 smallest
= (freelist
->span
* sizeof (scm_cell
));
2227 len
= (freelist
->span
* sizeof (scm_cell
));
2229 /* Allocate with decaying ambition. */
2230 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2231 && (len
>= smallest
))
2233 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (len
));
2236 init_heap_seg (ptr
, len
, freelist
);
2243 scm_wta (SCM_UNDEFINED
, "could not grow", "heap");
2248 SCM_DEFINE (scm_unhash_name
, "unhash-name", 1, 0, 0,
2251 #define FUNC_NAME s_scm_unhash_name
2255 SCM_VALIDATE_SYMBOL (1,name
);
2257 bound
= scm_n_heap_segs
;
2258 for (x
= 0; x
< bound
; ++x
)
2262 p
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[0];
2263 pbound
= (SCM_CELLPTR
)scm_heap_table
[x
].bounds
[1];
2268 if (1 == (7 & (int)incar
))
2271 if ( ((name
== SCM_BOOL_T
) || (SCM_CAR (incar
) == name
))
2272 && (SCM_CDR (incar
) != 0)
2273 && (SCM_UNPACK (SCM_CDR (incar
)) != 1))
2288 /* {GC Protection Helper Functions}
2293 scm_remember (SCM
*ptr
)
2298 These crazy functions prevent garbage collection
2299 of arguments after the first argument by
2300 ensuring they remain live throughout the
2301 function because they are used in the last
2302 line of the code block.
2303 It'd be better to have a nice compiler hint to
2304 aid the conservative stack-scanning GC. --03/09/00 gjb */
2306 scm_return_first (SCM elt
, ...)
2312 scm_return_first_int (int i
, ...)
2319 scm_permanent_object (SCM obj
)
2322 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2328 /* Protect OBJ from the garbage collector. OBJ will not be freed,
2329 even if all other references are dropped, until someone applies
2330 scm_unprotect_object to it. This function returns OBJ.
2332 Calls to scm_protect_object nest. For every object OBJ, there is a
2333 counter which scm_protect_object(OBJ) increments and
2334 scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
2335 an object's counter is greater than zero, the garbage collector
2338 Of course, that's not how it's implemented. scm_protect_object and
2339 scm_unprotect_object just maintain a list of references to things.
2340 Since the GC knows about this list, all objects it mentions stay
2341 alive. scm_protect_object adds its argument to the list;
2342 scm_unprotect_object removes the first occurrence of its argument
2345 scm_protect_object (SCM obj
)
2347 scm_protects
= scm_cons (obj
, scm_protects
);
2353 /* Remove any protection for OBJ established by a prior call to
2354 scm_protect_object. This function returns OBJ.
2356 See scm_protect_object for more information. */
2358 scm_unprotect_object (SCM obj
)
2360 SCM
*tail_ptr
= &scm_protects
;
2362 while (SCM_CONSP (*tail_ptr
))
2363 if (SCM_CAR (*tail_ptr
) == obj
)
2365 *tail_ptr
= SCM_CDR (*tail_ptr
);
2369 tail_ptr
= SCM_CDRLOC (*tail_ptr
);
2376 /* called on process termination. */
2382 extern int on_exit (void (*procp
) (), int arg
);
2385 cleanup (int status
, void *arg
)
2387 #error Dont know how to setup a cleanup handler on your system.
2392 scm_flush_all_ports ();
2397 make_initial_segment (scm_sizet init_heap_size
, scm_freelist_t
*freelist
)
2399 if (!init_heap_seg ((SCM_CELLPTR
) malloc (init_heap_size
),
2403 init_heap_size
= SCM_HEAP_SEG_SIZE
;
2404 if (!init_heap_seg ((SCM_CELLPTR
) malloc (init_heap_size
),
2412 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->gc_trigger
);
2418 #ifdef GUILE_NEW_GC_SCHEME
2420 init_freelist (scm_freelist_t
*freelist
,
2425 freelist
->clusters
= SCM_EOL
;
2426 freelist
->cluster_size
= cluster_size
+ 1;
2428 freelist
->gc_trigger_fraction
= - gc_trigger
;
2431 freelist
->gc_trigger
= gc_trigger
;
2432 freelist
->gc_trigger_fraction
= 0;
2434 freelist
->span
= span
;
2435 freelist
->collected
= 0;
2436 freelist
->heap_size
= 0;
2440 scm_init_storage (scm_sizet init_heap_size_1
, int gc_trigger_1
,
2441 scm_sizet init_heap_size_2
, int gc_trigger_2
,
2442 scm_sizet max_segment_size
)
2445 scm_init_storage (scm_sizet init_heap_size
, scm_sizet init_heap2_size
)
2450 if (!init_heap_size_1
)
2451 init_heap_size_1
= SCM_INIT_HEAP_SIZE_1
;
2452 if (!init_heap_size_2
)
2453 init_heap_size_2
= SCM_INIT_HEAP_SIZE_2
;
2455 j
= SCM_NUM_PROTECTS
;
2457 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2460 #ifdef GUILE_NEW_GC_SCHEME
2461 scm_freelist
= SCM_EOL
;
2462 scm_freelist2
= SCM_EOL
;
2463 init_freelist (&scm_master_freelist
,
2464 1, SCM_CLUSTER_SIZE_1
,
2465 gc_trigger_1
? gc_trigger_1
: SCM_GC_TRIGGER_1
);
2466 init_freelist (&scm_master_freelist2
,
2467 2, SCM_CLUSTER_SIZE_2
,
2468 gc_trigger_2
? gc_trigger_2
: SCM_GC_TRIGGER_2
);
2469 scm_max_segment_size
2470 = max_segment_size
? max_segment_size
: SCM_MAX_SEGMENT_SIZE
;
2472 scm_freelist
.cells
= SCM_EOL
;
2473 scm_freelist
.span
= 1;
2474 scm_freelist
.collected
= 0;
2475 scm_freelist
.heap_size
= 0;
2477 scm_freelist2
.cells
= SCM_EOL
;
2478 scm_freelist2
.span
= 2;
2479 scm_freelist2
.collected
= 0;
2480 scm_freelist2
.heap_size
= 0;
2485 j
= SCM_HEAP_SEG_SIZE
;
2486 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2487 scm_heap_table
= ((struct scm_heap_seg_data
*)
2488 scm_must_malloc (sizeof (struct scm_heap_seg_data
) * 2, "hplims"));
2490 #ifdef GUILE_NEW_GC_SCHEME
2491 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2492 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2495 if (make_initial_segment (init_heap_size_1
, &scm_freelist
) ||
2496 make_initial_segment (init_heap_size_2
, &scm_freelist2
))
2500 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0]);
2502 /* scm_hplims[0] can change. do not remove scm_heap_org */
2503 scm_weak_vectors
= SCM_EOL
;
2505 /* Initialise the list of ports. */
2506 scm_port_table
= (scm_port
**)
2507 malloc (sizeof (scm_port
*) * scm_port_table_room
);
2508 if (!scm_port_table
)
2515 on_exit (cleanup
, 0);
2519 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
2520 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
2522 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
2523 scm_nullstr
= scm_makstr (0L, 0);
2524 scm_nullvect
= scm_make_vector (SCM_INUM0
, SCM_UNDEFINED
);
2525 scm_symhash
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2526 scm_weak_symhash
= scm_make_weak_key_hash_table ((SCM
) SCM_MAKINUM (scm_symhash_dim
));
2527 scm_symhash_vars
= scm_make_vector ((SCM
) SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
2528 scm_stand_in_procs
= SCM_EOL
;
2529 scm_permobjs
= SCM_EOL
;
2530 scm_protects
= SCM_EOL
;
2531 scm_asyncs
= SCM_EOL
;
2532 scm_sysintern ("most-positive-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
2533 scm_sysintern ("most-negative-fixnum", (SCM
) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
2535 scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD
));