1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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 */
45 /* #define DEBUGINFO */
47 /* SECTION: This code is compiled once.
50 #ifndef MARK_DEPENDENCIES
57 #include "libguile/_scm.h"
58 #include "libguile/eval.h"
59 #include "libguile/stime.h"
60 #include "libguile/stackchk.h"
61 #include "libguile/struct.h"
62 #include "libguile/smob.h"
63 #include "libguile/unif.h"
64 #include "libguile/async.h"
65 #include "libguile/ports.h"
66 #include "libguile/root.h"
67 #include "libguile/strings.h"
68 #include "libguile/vectors.h"
69 #include "libguile/weaks.h"
70 #include "libguile/hashtab.h"
71 #include "libguile/tags.h"
73 #include "libguile/validate.h"
74 #include "libguile/deprecation.h"
75 #include "libguile/gc.h"
77 #ifdef GUILE_DEBUG_MALLOC
78 #include "libguile/debug-malloc.h"
91 #define var_start(x, y) va_start(x, y)
94 #define var_start(x, y) va_start(x)
99 unsigned int scm_gc_running_p
= 0;
103 #if (SCM_DEBUG_CELL_ACCESSES == 1)
105 scm_bits_t scm_tc16_allocated
;
107 /* Set this to != 0 if every cell that is accessed shall be checked:
109 unsigned int scm_debug_cell_accesses_p
= 1;
112 /* Assert that the given object is a valid reference to a valid cell. This
113 * test involves to determine whether the object is a cell pointer, whether
114 * this pointer actually points into a heap segment and whether the cell
115 * pointed to is not a free cell.
118 scm_assert_cell_valid (SCM cell
)
120 static unsigned int already_running
= 0;
122 if (scm_debug_cell_accesses_p
&& !already_running
)
124 already_running
= 1; /* set to avoid recursion */
126 if (!scm_cellp (cell
))
128 fprintf (stderr
, "scm_assert_cell_valid: Not a cell object: %lux\n",
129 (unsigned long) SCM_UNPACK (cell
));
132 else if (!scm_gc_running_p
)
134 /* Dirk::FIXME:: During garbage collection there occur references to
135 free cells. This is allright during conservative marking, but
136 should not happen otherwise (I think). The case of free cells
137 accessed during conservative marking is handled in function
138 scm_mark_locations. However, there still occur accesses to free
139 cells during gc. I don't understand why this happens. If it is
140 a bug and gets fixed, the following test should also work while
143 if (SCM_FREE_CELL_P (cell
))
145 fprintf (stderr
, "scm_assert_cell_valid: Accessing free cell: %lux\n",
146 (unsigned long) SCM_UNPACK (cell
));
150 already_running
= 0; /* re-enable */
155 SCM_DEFINE (scm_set_debug_cell_accesses_x
, "set-debug-cell-accesses!", 1, 0, 0,
157 "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
158 "If @var{flag} is @code{#t}, cell access checking is enabled.\n"
159 "This procedure only exists when the compile-time flag\n"
160 "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
161 #define FUNC_NAME s_scm_set_debug_cell_accesses_x
163 if (SCM_FALSEP (flag
)) {
164 scm_debug_cell_accesses_p
= 0;
165 } else if (SCM_EQ_P (flag
, SCM_BOOL_T
)) {
166 scm_debug_cell_accesses_p
= 1;
168 SCM_WRONG_TYPE_ARG (1, flag
);
170 return SCM_UNSPECIFIED
;
174 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
178 /* {heap tuning parameters}
180 * These are parameters for controlling memory allocation. The heap
181 * is the area out of which scm_cons, and object headers are allocated.
183 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
184 * 64 bit machine. The units of the _SIZE parameters are bytes.
185 * Cons pairs and object headers occupy one heap cell.
187 * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
188 * allocated initially the heap will grow by half its current size
189 * each subsequent time more heap is needed.
191 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
192 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
193 * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code
194 * is in scm_init_storage() and alloc_some_heap() in sys.c
196 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
197 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
199 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
202 * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
205 * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
206 * reclaimed by a GC triggered by must_malloc. If less than this is
207 * reclaimed, the trigger threshold is raised. [I don't know what a
208 * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
209 * work around a oscillation that caused almost constant GC.]
213 * Heap size 45000 and 40% min yield gives quick startup and no extra
214 * heap allocation. Having higher values on min yield may lead to
215 * large heaps, especially if code behaviour is varying its
216 * maximum consumption between different freelists.
219 #define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS)
220 #define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L)
221 #define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS)
222 size_t scm_default_init_heap_size_1
= (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER
- 1)
223 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
224 int scm_default_min_yield_1
= 40;
226 #define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2))
227 size_t scm_default_init_heap_size_2
= (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER
- 1)
228 / SCM_CARDS_PER_CLUSTER
) * SCM_GC_CARD_SIZE
);
229 /* The following value may seem large, but note that if we get to GC at
230 * all, this means that we have a numerically intensive application
232 int scm_default_min_yield_2
= 40;
234 size_t scm_default_max_segment_size
= 2097000L;/* a little less (adm) than 2 Mb */
236 #define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE)
238 # define SCM_HEAP_SEG_SIZE 32768L
241 # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell))
243 # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell))
246 /* Make heap grow with factor 1.5 */
247 #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2)
248 #define SCM_INIT_MALLOC_LIMIT 100000
249 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
251 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span)
252 aligned inner bounds for allocated storage */
255 /*in 386 protected mode we must only adjust the offset */
256 # define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
257 # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
260 # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
261 # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
263 # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
264 # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
268 #define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
270 #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1)
271 #define CLUSTER_SIZE_IN_BYTES(freelist) \
272 (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE)
278 typedef struct scm_freelist_t
{
279 /* collected cells */
281 /* number of cells left to collect before cluster is full */
282 unsigned int left_to_collect
;
283 /* number of clusters which have been allocated */
284 unsigned int clusters_allocated
;
285 /* a list of freelists, each of size cluster_size,
286 * except the last one which may be shorter
290 /* this is the number of objects in each cluster, including the spine cell */
291 unsigned int cluster_size
;
292 /* indicates that we should grow heap instead of GC:ing
295 /* minimum yield on this list in order not to grow the heap
298 /* defines min_yield as percent of total heap size
300 int min_yield_fraction
;
301 /* number of cells per object on this list */
303 /* number of collected cells during last GC */
304 unsigned long collected
;
305 /* number of collected cells during penultimate GC */
306 unsigned long collected_1
;
307 /* total number of cells in heap segments
308 * belonging to this list.
310 unsigned long heap_size
;
313 SCM scm_freelist
= SCM_EOL
;
314 scm_freelist_t scm_master_freelist
= {
315 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_1
, 0, 0, 0, 1, 0, 0
317 SCM scm_freelist2
= SCM_EOL
;
318 scm_freelist_t scm_master_freelist2
= {
319 SCM_EOL
, 0, 0, SCM_EOL
, 0, SCM_CLUSTER_SIZE_2
, 0, 0, 0, 2, 0, 0
323 * is the number of bytes of must_malloc allocation needed to trigger gc.
325 unsigned long scm_mtrigger
;
328 * If set, don't expand the heap. Set only during gc, during which no allocation
329 * is supposed to take place anyway.
331 int scm_gc_heap_lock
= 0;
334 * Don't pause for collection if this is set -- just
337 int scm_block_gc
= 1;
339 /* During collection, this accumulates objects holding
342 SCM scm_weak_vectors
;
344 /* During collection, this accumulates structures which are to be freed.
346 SCM scm_structs_to_free
;
348 /* GC Statistics Keeping
350 unsigned long scm_cells_allocated
= 0;
351 unsigned long scm_mallocated
= 0;
352 unsigned long scm_gc_cells_collected
;
353 unsigned long scm_gc_yield
;
354 static unsigned long scm_gc_yield_1
= 0; /* previous GC yield */
355 unsigned long scm_gc_malloc_collected
;
356 unsigned long scm_gc_ports_collected
;
357 unsigned long scm_gc_time_taken
= 0;
358 static unsigned long t_before_gc
;
359 static unsigned long t_before_sweep
;
360 unsigned long scm_gc_mark_time_taken
= 0;
361 unsigned long scm_gc_sweep_time_taken
= 0;
362 unsigned long scm_gc_times
= 0;
363 unsigned long scm_gc_cells_swept
= 0;
364 double scm_gc_cells_marked_acc
= 0.;
365 double scm_gc_cells_swept_acc
= 0.;
367 SCM_SYMBOL (sym_cells_allocated
, "cells-allocated");
368 SCM_SYMBOL (sym_heap_size
, "cell-heap-size");
369 SCM_SYMBOL (sym_mallocated
, "bytes-malloced");
370 SCM_SYMBOL (sym_mtrigger
, "gc-malloc-threshold");
371 SCM_SYMBOL (sym_heap_segments
, "cell-heap-segments");
372 SCM_SYMBOL (sym_gc_time_taken
, "gc-time-taken");
373 SCM_SYMBOL (sym_gc_mark_time_taken
, "gc-mark-time-taken");
374 SCM_SYMBOL (sym_gc_sweep_time_taken
, "gc-sweep-time-taken");
375 SCM_SYMBOL (sym_times
, "gc-times");
376 SCM_SYMBOL (sym_cells_marked
, "cells-marked");
377 SCM_SYMBOL (sym_cells_swept
, "cells-swept");
379 typedef struct scm_heap_seg_data_t
381 /* lower and upper bounds of the segment */
382 SCM_CELLPTR bounds
[2];
384 /* address of the head-of-freelist pointer for this segment's cells.
385 All segments usually point to the same one, scm_freelist. */
386 scm_freelist_t
*freelist
;
388 /* number of cells per object in this segment */
390 } scm_heap_seg_data_t
;
394 static size_t init_heap_seg (SCM_CELLPTR
, size_t, scm_freelist_t
*);
396 typedef enum { return_on_error
, abort_on_error
} policy_on_error
;
397 static void alloc_some_heap (scm_freelist_t
*, policy_on_error
);
400 #define SCM_HEAP_SIZE \
401 (scm_master_freelist.heap_size + scm_master_freelist2.heap_size)
402 #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
404 #define BVEC_GROW_SIZE 256
405 #define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE)
406 #define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_c_bvec_limb_t))
408 /* mark space allocation */
410 typedef struct scm_mark_space_t
412 scm_c_bvec_limb_t
*bvec_space
;
413 struct scm_mark_space_t
*next
;
416 static scm_mark_space_t
*current_mark_space
;
417 static scm_mark_space_t
**mark_space_ptr
;
418 static ptrdiff_t current_mark_space_offset
;
419 static scm_mark_space_t
*mark_space_head
;
421 static scm_c_bvec_limb_t
*
423 #define FUNC_NAME "get_bvec"
425 scm_c_bvec_limb_t
*res
;
427 if (!current_mark_space
)
429 SCM_SYSCALL (current_mark_space
= (scm_mark_space_t
*) malloc (sizeof (scm_mark_space_t
)));
430 if (!current_mark_space
)
431 SCM_MISC_ERROR ("could not grow heap", SCM_EOL
);
433 current_mark_space
->bvec_space
= NULL
;
434 current_mark_space
->next
= NULL
;
436 *mark_space_ptr
= current_mark_space
;
437 mark_space_ptr
= &(current_mark_space
->next
);
442 if (!(current_mark_space
->bvec_space
))
444 SCM_SYSCALL (current_mark_space
->bvec_space
=
445 (scm_c_bvec_limb_t
*) calloc (BVEC_GROW_SIZE_IN_BYTES
, 1));
446 if (!(current_mark_space
->bvec_space
))
447 SCM_MISC_ERROR ("could not grow heap", SCM_EOL
);
449 current_mark_space_offset
= 0;
454 if (current_mark_space_offset
== BVEC_GROW_SIZE_IN_LIMBS
)
456 current_mark_space
= NULL
;
461 res
= current_mark_space
->bvec_space
+ current_mark_space_offset
;
462 current_mark_space_offset
+= SCM_GC_CARD_BVEC_SIZE_IN_LIMBS
;
472 scm_mark_space_t
*ms
;
474 for (ms
= mark_space_head
; ms
; ms
= ms
->next
)
475 memset (ms
->bvec_space
, 0, BVEC_GROW_SIZE_IN_BYTES
);
480 /* Debugging functions. */
482 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
484 /* Return the number of the heap segment containing CELL. */
490 for (i
= 0; i
< scm_n_heap_segs
; i
++)
491 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], SCM2PTR (cell
))
492 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], SCM2PTR (cell
)))
494 fprintf (stderr
, "which_seg: can't find segment containing cell %lux\n",
495 (unsigned long) SCM_UNPACK (cell
));
501 map_free_list (scm_freelist_t
*master
, SCM freelist
)
503 long last_seg
= -1, count
= 0;
506 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
))
508 long this_seg
= which_seg (f
);
510 if (this_seg
!= last_seg
)
513 fprintf (stderr
, " %5ld %d-cells in segment %ld\n",
514 (long) count
, master
->span
, (long) last_seg
);
521 fprintf (stderr
, " %5ld %d-cells in segment %ld\n",
522 (long) count
, master
->span
, (long) last_seg
);
525 SCM_DEFINE (scm_map_free_list
, "map-free-list", 0, 0, 0,
527 "Print debugging information about the free-list.\n"
528 "@code{map-free-list} is only included in\n"
529 "@code{--enable-guile-debug} builds of Guile.")
530 #define FUNC_NAME s_scm_map_free_list
533 fprintf (stderr
, "%ld segments total (%d:%ld",
534 (long) scm_n_heap_segs
,
535 scm_heap_table
[0].span
,
536 (long) (scm_heap_table
[0].bounds
[1] - scm_heap_table
[0].bounds
[0]));
537 for (i
= 1; i
< scm_n_heap_segs
; i
++)
538 fprintf (stderr
, ", %d:%ld",
539 scm_heap_table
[i
].span
,
540 (long) (scm_heap_table
[i
].bounds
[1] - scm_heap_table
[i
].bounds
[0]));
541 fprintf (stderr
, ")\n");
542 map_free_list (&scm_master_freelist
, scm_freelist
);
543 map_free_list (&scm_master_freelist2
, scm_freelist2
);
546 return SCM_UNSPECIFIED
;
550 static long last_cluster
;
551 static long last_size
;
554 free_list_length (char *title
, long i
, SCM freelist
)
558 for (ls
= freelist
; !SCM_NULLP (ls
); ls
= SCM_FREE_CELL_CDR (ls
))
559 if (SCM_FREE_CELL_P (ls
))
563 fprintf (stderr
, "bad cell in %s at position %ld\n", title
, (long) n
);
570 if (last_cluster
== i
- 1)
571 fprintf (stderr
, "\t%ld\n", (long) last_size
);
573 fprintf (stderr
, "-%ld\t%ld\n", (long) (i
- 1), (long) last_size
);
576 fprintf (stderr
, "%s %ld", title
, (long) i
);
578 fprintf (stderr
, "%s\t%ld\n", title
, (long) n
);
586 free_list_lengths (char *title
, scm_freelist_t
*master
, SCM freelist
)
589 long i
= 0, len
, n
= 0;
590 fprintf (stderr
, "%s\n\n", title
);
591 n
+= free_list_length ("free list", -1, freelist
);
592 for (clusters
= master
->clusters
;
593 SCM_NNULLP (clusters
);
594 clusters
= SCM_CDR (clusters
))
596 len
= free_list_length ("cluster", i
++, SCM_CAR (clusters
));
599 if (last_cluster
== i
- 1)
600 fprintf (stderr
, "\t%ld\n", (long) last_size
);
602 fprintf (stderr
, "-%ld\t%ld\n", (long) (i
- 1), (long) last_size
);
603 fprintf (stderr
, "\ntotal %ld objects\n\n", (long) n
);
606 SCM_DEFINE (scm_free_list_length
, "free-list-length", 0, 0, 0,
608 "Print debugging information about the free-list.\n"
609 "@code{free-list-length} is only included in\n"
610 "@code{--enable-guile-debug} builds of Guile.")
611 #define FUNC_NAME s_scm_free_list_length
613 free_list_lengths ("1-cells", &scm_master_freelist
, scm_freelist
);
614 free_list_lengths ("2-cells", &scm_master_freelist2
, scm_freelist2
);
615 return SCM_UNSPECIFIED
;
621 #ifdef GUILE_DEBUG_FREELIST
623 /* Non-zero if freelist debugging is in effect. Set this via
624 `gc-set-debug-check-freelist!'. */
625 static int scm_debug_check_freelist
= 0;
627 /* Number of calls to SCM_NEWCELL since startup. */
628 static unsigned long scm_newcell_count
;
629 static unsigned long scm_newcell2_count
;
631 /* Search freelist for anything that isn't marked as a free cell.
632 Abort if we find something. */
634 scm_check_freelist (SCM freelist
)
639 for (f
= freelist
; !SCM_NULLP (f
); f
= SCM_FREE_CELL_CDR (f
), i
++)
640 if (!SCM_FREE_CELL_P (f
))
642 fprintf (stderr
, "Bad cell in freelist on newcell %lu: %lu'th elt\n",
643 (long) scm_newcell_count
, (long) i
);
648 SCM_DEFINE (scm_gc_set_debug_check_freelist_x
, "gc-set-debug-check-freelist!", 1, 0, 0,
650 "If @var{flag} is @code{#t}, check the freelist for consistency\n"
651 "on each cell allocation. This procedure only exists when the\n"
652 "@code{GUILE_DEBUG_FREELIST} compile-time flag was selected.")
653 #define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
655 /* [cmm] I did a double-take when I read this code the first time.
657 SCM_VALIDATE_BOOL_COPY (1, flag
, scm_debug_check_freelist
);
658 return SCM_UNSPECIFIED
;
664 scm_debug_newcell (void)
669 if (scm_debug_check_freelist
)
671 scm_check_freelist (scm_freelist
);
675 /* The rest of this is supposed to be identical to the SCM_NEWCELL
677 if (SCM_NULLP (scm_freelist
))
679 new = scm_gc_for_newcell (&scm_master_freelist
, &scm_freelist
);
680 SCM_GC_SET_ALLOCATED (new);
685 scm_freelist
= SCM_FREE_CELL_CDR (scm_freelist
);
686 SCM_GC_SET_ALLOCATED (new);
693 scm_debug_newcell2 (void)
697 scm_newcell2_count
++;
698 if (scm_debug_check_freelist
)
700 scm_check_freelist (scm_freelist2
);
704 /* The rest of this is supposed to be identical to the SCM_NEWCELL
706 if (SCM_NULLP (scm_freelist2
))
708 new = scm_gc_for_newcell (&scm_master_freelist2
, &scm_freelist2
);
709 SCM_GC_SET_ALLOCATED (new);
714 scm_freelist2
= SCM_FREE_CELL_CDR (scm_freelist2
);
715 SCM_GC_SET_ALLOCATED (new);
721 #endif /* GUILE_DEBUG_FREELIST */
726 master_cells_allocated (scm_freelist_t
*master
)
728 /* the '- 1' below is to ignore the cluster spine cells. */
729 long objects
= master
->clusters_allocated
* (master
->cluster_size
- 1);
730 if (SCM_NULLP (master
->clusters
))
731 objects
-= master
->left_to_collect
;
732 return master
->span
* objects
;
736 freelist_length (SCM freelist
)
739 for (n
= 0; !SCM_NULLP (freelist
); freelist
= SCM_FREE_CELL_CDR (freelist
))
745 compute_cells_allocated ()
747 return (scm_cells_allocated
748 + master_cells_allocated (&scm_master_freelist
)
749 + master_cells_allocated (&scm_master_freelist2
)
750 - scm_master_freelist
.span
* freelist_length (scm_freelist
)
751 - scm_master_freelist2
.span
* freelist_length (scm_freelist2
));
754 /* {Scheme Interface to GC}
757 SCM_DEFINE (scm_gc_stats
, "gc-stats", 0, 0, 0,
759 "Return an association list of statistics about Guile's current\n"
761 #define FUNC_NAME s_scm_gc_stats
766 unsigned long int local_scm_mtrigger
;
767 unsigned long int local_scm_mallocated
;
768 unsigned long int local_scm_heap_size
;
769 unsigned long int local_scm_cells_allocated
;
770 unsigned long int local_scm_gc_time_taken
;
771 unsigned long int local_scm_gc_times
;
772 unsigned long int local_scm_gc_mark_time_taken
;
773 unsigned long int local_scm_gc_sweep_time_taken
;
774 double local_scm_gc_cells_swept
;
775 double local_scm_gc_cells_marked
;
785 for (i
= scm_n_heap_segs
; i
--; )
786 heap_segs
= scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[1]),
787 scm_ulong2num ((unsigned long)scm_heap_table
[i
].bounds
[0])),
789 if (scm_n_heap_segs
!= n
)
794 /* Below, we cons to produce the resulting list. We want a snapshot of
795 * the heap situation before consing.
797 local_scm_mtrigger
= scm_mtrigger
;
798 local_scm_mallocated
= scm_mallocated
;
799 local_scm_heap_size
= SCM_HEAP_SIZE
;
800 local_scm_cells_allocated
= compute_cells_allocated ();
801 local_scm_gc_time_taken
= scm_gc_time_taken
;
802 local_scm_gc_mark_time_taken
= scm_gc_mark_time_taken
;
803 local_scm_gc_sweep_time_taken
= scm_gc_sweep_time_taken
;
804 local_scm_gc_times
= scm_gc_times
;
805 local_scm_gc_cells_swept
= scm_gc_cells_swept_acc
;
806 local_scm_gc_cells_marked
= scm_gc_cells_marked_acc
;
808 answer
= scm_listify (scm_cons (sym_gc_time_taken
, scm_ulong2num (local_scm_gc_time_taken
)),
809 scm_cons (sym_cells_allocated
, scm_ulong2num (local_scm_cells_allocated
)),
810 scm_cons (sym_heap_size
, scm_ulong2num (local_scm_heap_size
)),
811 scm_cons (sym_mallocated
, scm_ulong2num (local_scm_mallocated
)),
812 scm_cons (sym_mtrigger
, scm_ulong2num (local_scm_mtrigger
)),
813 scm_cons (sym_times
, scm_ulong2num (local_scm_gc_times
)),
814 scm_cons (sym_gc_mark_time_taken
, scm_ulong2num (local_scm_gc_mark_time_taken
)),
815 scm_cons (sym_gc_sweep_time_taken
, scm_ulong2num (local_scm_gc_sweep_time_taken
)),
816 scm_cons (sym_cells_marked
, scm_i_dbl2big (local_scm_gc_cells_marked
)),
817 scm_cons (sym_cells_swept
, scm_i_dbl2big (local_scm_gc_cells_swept
)),
818 scm_cons (sym_heap_segments
, heap_segs
),
827 gc_start_stats (const char *what
)
829 t_before_gc
= scm_c_get_internal_run_time ();
830 scm_gc_cells_swept
= 0;
831 scm_gc_cells_collected
= 0;
832 scm_gc_yield_1
= scm_gc_yield
;
833 scm_gc_yield
= (scm_cells_allocated
834 + master_cells_allocated (&scm_master_freelist
)
835 + master_cells_allocated (&scm_master_freelist2
));
836 scm_gc_malloc_collected
= 0;
837 scm_gc_ports_collected
= 0;
844 unsigned long t
= scm_c_get_internal_run_time ();
845 scm_gc_time_taken
+= (t
- t_before_gc
);
846 scm_gc_sweep_time_taken
+= (t
- t_before_sweep
);
849 scm_gc_cells_marked_acc
+= scm_gc_cells_swept
- scm_gc_cells_collected
;
850 scm_gc_cells_swept_acc
+= scm_gc_cells_swept
;
854 SCM_DEFINE (scm_object_address
, "object-address", 1, 0, 0,
856 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
857 "returned by this function for @var{obj}")
858 #define FUNC_NAME s_scm_object_address
860 return scm_ulong2num ((unsigned long) SCM_UNPACK (obj
));
865 SCM_DEFINE (scm_gc
, "gc", 0, 0, 0,
867 "Scans all of SCM objects and reclaims for further use those that are\n"
868 "no longer accessible.")
869 #define FUNC_NAME s_scm_gc
874 return SCM_UNSPECIFIED
;
880 /* {C Interface For When GC is Triggered}
884 adjust_min_yield (scm_freelist_t
*freelist
)
886 /* min yield is adjusted upwards so that next predicted total yield
887 * (allocated cells actually freed by GC) becomes
888 * `min_yield_fraction' of total heap size. Note, however, that
889 * the absolute value of min_yield will correspond to `collected'
890 * on one master (the one which currently is triggering GC).
892 * The reason why we look at total yield instead of cells collected
893 * on one list is that we want to take other freelists into account.
894 * On this freelist, we know that (local) yield = collected cells,
895 * but that's probably not the case on the other lists.
897 * (We might consider computing a better prediction, for example
898 * by computing an average over multiple GC:s.)
900 if (freelist
->min_yield_fraction
)
902 /* Pick largest of last two yields. */
903 long delta
= ((SCM_HEAP_SIZE
* freelist
->min_yield_fraction
/ 100)
904 - (long) SCM_MAX (scm_gc_yield_1
, scm_gc_yield
));
906 fprintf (stderr
, " after GC = %lu, delta = %ld\n",
907 (long) scm_cells_allocated
,
911 freelist
->min_yield
+= delta
;
916 /* When we get POSIX threads support, the master will be global and
917 * common while the freelist will be individual for each thread.
921 scm_gc_for_newcell (scm_freelist_t
*master
, SCM
*freelist
)
927 if (SCM_NULLP (master
->clusters
))
929 if (master
->grow_heap_p
|| scm_block_gc
)
931 /* In order to reduce gc frequency, try to allocate a new heap
932 * segment first, even if gc might find some free cells. If we
933 * can't obtain a new heap segment, we will try gc later.
935 master
->grow_heap_p
= 0;
936 alloc_some_heap (master
, return_on_error
);
938 if (SCM_NULLP (master
->clusters
))
940 /* The heap was not grown, either because it wasn't scheduled to
941 * grow, or because there was not enough memory available. In
942 * both cases we have to try gc to get some free cells.
945 fprintf (stderr
, "allocated = %lu, ",
946 (long) (scm_cells_allocated
947 + master_cells_allocated (&scm_master_freelist
)
948 + master_cells_allocated (&scm_master_freelist2
)));
951 adjust_min_yield (master
);
952 if (SCM_NULLP (master
->clusters
))
954 /* gc could not free any cells. Now, we _must_ allocate a
955 * new heap segment, because there is no other possibility
956 * to provide a new cell for the caller.
958 alloc_some_heap (master
, abort_on_error
);
962 cell
= SCM_CAR (master
->clusters
);
963 master
->clusters
= SCM_CDR (master
->clusters
);
964 ++master
->clusters_allocated
;
966 while (SCM_NULLP (cell
));
968 #ifdef GUILE_DEBUG_FREELIST
969 scm_check_freelist (cell
);
973 *freelist
= SCM_FREE_CELL_CDR (cell
);
979 /* This is a support routine which can be used to reserve a cluster
980 * for some special use, such as debugging. It won't be useful until
981 * free cells are preserved between garbage collections.
985 scm_alloc_cluster (scm_freelist_t
*master
)
988 cell
= scm_gc_for_newcell (master
, &freelist
);
989 SCM_SETCDR (cell
, freelist
);
995 scm_c_hook_t scm_before_gc_c_hook
;
996 scm_c_hook_t scm_before_mark_c_hook
;
997 scm_c_hook_t scm_before_sweep_c_hook
;
998 scm_c_hook_t scm_after_sweep_c_hook
;
999 scm_c_hook_t scm_after_gc_c_hook
;
1003 scm_igc (const char *what
)
1008 scm_c_hook_run (&scm_before_gc_c_hook
, 0);
1011 SCM_NULLP (scm_freelist
)
1013 : (SCM_NULLP (scm_freelist2
) ? "o" : "m"));
1015 /* During the critical section, only the current thread may run. */
1016 SCM_CRITICAL_SECTION_START
;
1018 /* fprintf (stderr, "gc: %s\n", what); */
1020 if (!scm_stack_base
|| scm_block_gc
)
1026 gc_start_stats (what
);
1028 if (scm_gc_heap_lock
)
1029 /* We've invoked the collector while a GC is already in progress.
1030 That should never happen. */
1035 /* flush dead entries from the continuation stack */
1040 elts
= SCM_VELTS (scm_continuation_stack
);
1041 bound
= SCM_VECTOR_LENGTH (scm_continuation_stack
);
1042 x
= SCM_INUM (scm_continuation_stack_ptr
);
1045 elts
[x
] = SCM_BOOL_F
;
1050 scm_c_hook_run (&scm_before_mark_c_hook
, 0);
1052 clear_mark_space ();
1056 /* Mark objects on the C stack. */
1057 SCM_FLUSH_REGISTER_WINDOWS
;
1058 /* This assumes that all registers are saved into the jmp_buf */
1059 setjmp (scm_save_regs_gc_mark
);
1060 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1061 ( (size_t) (sizeof (SCM_STACKITEM
) - 1 +
1062 sizeof scm_save_regs_gc_mark
)
1063 / sizeof (SCM_STACKITEM
)));
1066 unsigned long stack_len
= scm_stack_size (scm_stack_base
);
1067 #ifdef SCM_STACK_GROWS_UP
1068 scm_mark_locations (scm_stack_base
, stack_len
);
1070 scm_mark_locations (scm_stack_base
- stack_len
, stack_len
);
1074 #else /* USE_THREADS */
1076 /* Mark every thread's stack and registers */
1077 scm_threads_mark_stacks ();
1079 #endif /* USE_THREADS */
1081 j
= SCM_NUM_PROTECTS
;
1083 scm_gc_mark (scm_sys_protects
[j
]);
1085 /* mark the registered roots */
1088 for (i
= 0; i
< SCM_VECTOR_LENGTH (scm_gc_registered_roots
); ++i
) {
1089 SCM l
= SCM_VELTS (scm_gc_registered_roots
)[i
];
1090 for (; ! SCM_NULLP (l
); l
= SCM_CDR (l
)) {
1091 SCM
*p
= (SCM
*) (scm_num2long (SCM_CAAR (l
), 0, NULL
));
1097 /* FIXME: we should have a means to register C functions to be run
1098 * in different phases of GC
1100 scm_mark_subr_table ();
1103 scm_gc_mark (scm_root
->handle
);
1106 t_before_sweep
= scm_c_get_internal_run_time ();
1107 scm_gc_mark_time_taken
+= (t_before_sweep
- t_before_gc
);
1109 scm_c_hook_run (&scm_before_sweep_c_hook
, 0);
1113 scm_c_hook_run (&scm_after_sweep_c_hook
, 0);
1118 SCM_CRITICAL_SECTION_END
;
1119 scm_c_hook_run (&scm_after_gc_c_hook
, 0);
1128 #define MARK scm_gc_mark
1129 #define FNAME "scm_gc_mark"
1131 #endif /*!MARK_DEPENDENCIES*/
1133 /* Mark an object precisely.
1137 #define FUNC_NAME FNAME
1141 scm_bits_t cell_type
;
1143 #ifndef MARK_DEPENDENCIES
1144 # define RECURSE scm_gc_mark
1146 /* go through the usual marking, but not for self-cycles. */
1147 # define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0)
1151 #ifdef MARK_DEPENDENCIES
1152 goto gc_mark_loop_first_time
;
1155 /* A simple hack for debugging. Chose the second branch to get a
1156 meaningful backtrace for crashes inside the GC.
1159 #define goto_gc_mark_loop goto gc_mark_loop
1160 #define goto_gc_mark_nimp goto gc_mark_nimp
1162 #define goto_gc_mark_loop RECURSE(ptr); return
1163 #define goto_gc_mark_nimp RECURSE(ptr); return
1172 #ifdef MARK_DEPENDENCIES
1173 if (SCM_EQ_P (ptr
, p
))
1179 gc_mark_loop_first_time
:
1182 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1183 /* We are in debug mode. Check the ptr exhaustively. */
1184 if (!scm_cellp (ptr
))
1185 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1187 /* In non-debug mode, do at least some cheap testing. */
1188 if (!SCM_CELLP (ptr
))
1189 SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL
);
1192 #ifndef MARK_DEPENDENCIES
1194 if (SCM_GCMARKP (ptr
))
1197 SCM_SETGCMARK (ptr
);
1201 cell_type
= SCM_GC_CELL_TYPE (ptr
);
1202 switch (SCM_ITAG7 (cell_type
))
1204 case scm_tcs_cons_nimcar
:
1205 if (SCM_IMP (SCM_CDR (ptr
)))
1207 ptr
= SCM_CAR (ptr
);
1210 RECURSE (SCM_CAR (ptr
));
1211 ptr
= SCM_CDR (ptr
);
1213 case scm_tcs_cons_imcar
:
1214 ptr
= SCM_CDR (ptr
);
1217 RECURSE (SCM_SETTER (ptr
));
1218 ptr
= SCM_PROCEDURE (ptr
);
1220 case scm_tcs_cons_gloc
:
1222 /* Dirk:FIXME:: The following code is super ugly: ptr may be a
1223 * struct or a gloc. If it is a gloc, the cell word #0 of ptr
1224 * is the address of a scm_tc16_variable smob. If it is a
1225 * struct, the cell word #0 of ptr is a pointer to a struct
1226 * vtable data region. (The fact that these are accessed in
1227 * the same way restricts the possibilites to change the data
1228 * layout of structs or heap cells.) To discriminate between
1229 * the two, it is guaranteed that the scm_vtable_index_vcell
1230 * element of the prospective vtable is always zero. For a
1231 * gloc, this location has the CDR of the variable smob, which
1232 * is guaranteed to be non-zero.
1234 scm_bits_t word0
= SCM_CELL_WORD_0 (ptr
) - scm_tc3_cons_gloc
;
1235 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
; /* access as struct */
1236 if (vtable_data
[scm_vtable_index_vcell
] != 0)
1239 SCM gloc_car
= SCM_PACK (word0
);
1241 ptr
= SCM_CDR (ptr
);
1246 /* ptr is a struct */
1247 SCM layout
= SCM_PACK (vtable_data
[scm_vtable_index_layout
]);
1248 long len
= SCM_SYMBOL_LENGTH (layout
);
1249 char * fields_desc
= SCM_SYMBOL_CHARS (layout
);
1250 scm_bits_t
* struct_data
= (scm_bits_t
*) SCM_STRUCT_DATA (ptr
);
1252 if (vtable_data
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
1254 RECURSE (SCM_PACK (struct_data
[scm_struct_i_procedure
]));
1255 RECURSE (SCM_PACK (struct_data
[scm_struct_i_setter
]));
1261 for (x
= 0; x
< len
- 2; x
+= 2, ++struct_data
)
1262 if (fields_desc
[x
] == 'p')
1263 RECURSE (SCM_PACK (*struct_data
));
1264 if (fields_desc
[x
] == 'p')
1266 if (SCM_LAYOUT_TAILP (fields_desc
[x
+ 1]))
1267 for (x
= *struct_data
++; x
; --x
, ++struct_data
)
1268 RECURSE (SCM_PACK (*struct_data
));
1270 RECURSE (SCM_PACK (*struct_data
));
1274 ptr
= SCM_PACK (vtable_data
[scm_vtable_index_vtable
]);
1279 case scm_tcs_closures
:
1280 if (SCM_IMP (SCM_ENV (ptr
)))
1282 ptr
= SCM_CLOSCAR (ptr
);
1285 RECURSE (SCM_CLOSCAR (ptr
));
1286 ptr
= SCM_ENV (ptr
);
1288 case scm_tc7_vector
:
1289 i
= SCM_VECTOR_LENGTH (ptr
);
1293 if (SCM_NIMP (SCM_VELTS (ptr
)[i
]))
1294 RECURSE (SCM_VELTS (ptr
)[i
]);
1295 ptr
= SCM_VELTS (ptr
)[0];
1300 size_t i
= SCM_CCLO_LENGTH (ptr
);
1302 for (j
= 1; j
!= i
; ++j
)
1304 SCM obj
= SCM_CCLO_REF (ptr
, j
);
1308 ptr
= SCM_CCLO_REF (ptr
, 0);
1314 case scm_tc7_byvect
:
1321 #ifdef HAVE_LONG_LONGS
1322 case scm_tc7_llvect
:
1325 case scm_tc7_string
:
1328 case scm_tc7_substring
:
1329 ptr
= SCM_CDR (ptr
);
1333 SCM_WVECT_GC_CHAIN (ptr
) = scm_weak_vectors
;
1334 scm_weak_vectors
= ptr
;
1335 if (SCM_IS_WHVEC_ANY (ptr
))
1342 len
= SCM_VECTOR_LENGTH (ptr
);
1343 weak_keys
= SCM_IS_WHVEC (ptr
) || SCM_IS_WHVEC_B (ptr
);
1344 weak_values
= SCM_IS_WHVEC_V (ptr
) || SCM_IS_WHVEC_B (ptr
);
1346 for (x
= 0; x
< len
; ++x
)
1349 alist
= SCM_VELTS (ptr
)[x
];
1351 /* mark everything on the alist except the keys or
1352 * values, according to weak_values and weak_keys. */
1353 while ( SCM_CONSP (alist
)
1354 && !SCM_GCMARKP (alist
)
1355 && SCM_CONSP (SCM_CAR (alist
)))
1360 kvpair
= SCM_CAR (alist
);
1361 next_alist
= SCM_CDR (alist
);
1364 * SCM_SETGCMARK (alist);
1365 * SCM_SETGCMARK (kvpair);
1367 * It may be that either the key or value is protected by
1368 * an escaped reference to part of the spine of this alist.
1369 * If we mark the spine here, and only mark one or neither of the
1370 * key and value, they may never be properly marked.
1371 * This leads to a horrible situation in which an alist containing
1372 * freelist cells is exported.
1374 * So only mark the spines of these arrays last of all marking.
1375 * If somebody confuses us by constructing a weak vector
1376 * with a circular alist then we are hosed, but at least we
1377 * won't prematurely drop table entries.
1380 RECURSE (SCM_CAR (kvpair
));
1382 RECURSE (SCM_CDR (kvpair
));
1385 if (SCM_NIMP (alist
))
1391 case scm_tc7_symbol
:
1392 ptr
= SCM_PROP_SLOTS (ptr
);
1397 i
= SCM_PTOBNUM (ptr
);
1398 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1399 if (!(i
< scm_numptob
))
1400 SCM_MISC_ERROR ("undefined port type", SCM_EOL
);
1402 if (SCM_PTAB_ENTRY(ptr
))
1403 RECURSE (SCM_FILENAME (ptr
));
1404 if (scm_ptobs
[i
].mark
)
1406 ptr
= (scm_ptobs
[i
].mark
) (ptr
);
1413 switch (SCM_TYP16 (ptr
))
1414 { /* should be faster than going through scm_smobs */
1415 case scm_tc_free_cell
:
1416 /* printf("found free_cell %X ", ptr); fflush(stdout); */
1419 case scm_tc16_complex
:
1422 i
= SCM_SMOBNUM (ptr
);
1423 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1424 if (!(i
< scm_numsmob
))
1425 SCM_MISC_ERROR ("undefined smob type", SCM_EOL
);
1427 if (scm_smobs
[i
].mark
)
1429 ptr
= (scm_smobs
[i
].mark
) (ptr
);
1437 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1443 #ifndef MARK_DEPENDENCIES
1448 /* And here we define `scm_gc_mark_dependencies', by including this
1449 * same file in itself.
1451 #define MARK scm_gc_mark_dependencies
1452 #define FNAME "scm_gc_mark_dependencies"
1453 #define MARK_DEPENDENCIES
1455 #undef MARK_DEPENDENCIES
1460 /* Mark a Region Conservatively
1464 scm_mark_locations (SCM_STACKITEM x
[], unsigned long n
)
1468 for (m
= 0; m
< n
; ++m
)
1470 SCM obj
= * (SCM
*) &x
[m
];
1471 if (SCM_CELLP (obj
))
1473 SCM_CELLPTR ptr
= SCM2PTR (obj
);
1475 long j
= scm_n_heap_segs
- 1;
1476 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1477 && SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1484 || SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
))
1486 else if (SCM_PTR_LE (scm_heap_table
[j
].bounds
[0], ptr
))
1494 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
))
1498 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
))
1503 else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
))
1507 if (SCM_PTR_GT (scm_heap_table
[j
].bounds
[1], ptr
))
1514 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1517 if (scm_heap_table
[seg_id
].span
== 1
1518 || DOUBLECELL_ALIGNED_P (obj
))
1529 /* The function scm_cellp determines whether an SCM value can be regarded as a
1530 * pointer to a cell on the heap. Binary search is used in order to determine
1531 * the heap segment that contains the cell.
1534 scm_cellp (SCM value
)
1536 if (SCM_CELLP (value
)) {
1537 scm_cell
* ptr
= SCM2PTR (value
);
1538 unsigned long i
= 0;
1539 unsigned long j
= scm_n_heap_segs
- 1;
1541 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1545 long k
= (i
+ j
) / 2;
1546 if (SCM_PTR_GT (scm_heap_table
[k
].bounds
[1], ptr
)) {
1548 } else if (SCM_PTR_LE (scm_heap_table
[k
].bounds
[0], ptr
)) {
1553 if (SCM_PTR_LE (scm_heap_table
[i
].bounds
[0], ptr
)
1554 && SCM_PTR_GT (scm_heap_table
[i
].bounds
[1], ptr
)
1555 && (scm_heap_table
[i
].span
== 1 || DOUBLECELL_ALIGNED_P (value
))
1556 && !SCM_GC_IN_CARD_HEADERP (ptr
)
1567 gc_sweep_freelist_start (scm_freelist_t
*freelist
)
1569 freelist
->cells
= SCM_EOL
;
1570 freelist
->left_to_collect
= freelist
->cluster_size
;
1571 freelist
->clusters_allocated
= 0;
1572 freelist
->clusters
= SCM_EOL
;
1573 freelist
->clustertail
= &freelist
->clusters
;
1574 freelist
->collected_1
= freelist
->collected
;
1575 freelist
->collected
= 0;
1579 gc_sweep_freelist_finish (scm_freelist_t
*freelist
)
1582 *freelist
->clustertail
= freelist
->cells
;
1583 if (!SCM_NULLP (freelist
->cells
))
1585 SCM c
= freelist
->cells
;
1586 SCM_SET_CELL_WORD_0 (c
, SCM_FREE_CELL_CDR (c
));
1587 SCM_SET_CELL_WORD_1 (c
, SCM_EOL
);
1588 freelist
->collected
+=
1589 freelist
->span
* (freelist
->cluster_size
- freelist
->left_to_collect
);
1591 scm_gc_cells_collected
+= freelist
->collected
;
1593 /* Although freelist->min_yield is used to test freelist->collected
1594 * (which is the local GC yield for freelist), it is adjusted so
1595 * that *total* yield is freelist->min_yield_fraction of total heap
1596 * size. This means that a too low yield is compensated by more
1597 * heap on the list which is currently doing most work, which is
1598 * just what we want.
1600 collected
= SCM_MAX (freelist
->collected_1
, freelist
->collected
);
1601 freelist
->grow_heap_p
= (collected
< freelist
->min_yield
);
1604 #define NEXT_DATA_CELL(ptr, span) \
1606 scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \
1607 (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \
1608 CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \
1614 #define FUNC_NAME "scm_gc_sweep"
1616 register SCM_CELLPTR ptr
;
1617 register SCM nfreelist
;
1618 register scm_freelist_t
*freelist
;
1619 register unsigned long m
;
1626 gc_sweep_freelist_start (&scm_master_freelist
);
1627 gc_sweep_freelist_start (&scm_master_freelist2
);
1629 for (i
= 0; i
< scm_n_heap_segs
; i
++)
1631 register long left_to_collect
;
1634 /* Unmarked cells go onto the front of the freelist this heap
1635 segment points to. Rather than updating the real freelist
1636 pointer as we go along, we accumulate the new head in
1637 nfreelist. Then, if it turns out that the entire segment is
1638 free, we free (i.e., malloc's free) the whole segment, and
1639 simply don't assign nfreelist back into the real freelist. */
1640 freelist
= scm_heap_table
[i
].freelist
;
1641 nfreelist
= freelist
->cells
;
1642 left_to_collect
= freelist
->left_to_collect
;
1643 span
= scm_heap_table
[i
].span
;
1645 ptr
= CELL_UP (scm_heap_table
[i
].bounds
[0], span
);
1646 seg_size
= CELL_DN (scm_heap_table
[i
].bounds
[1], span
) - ptr
;
1648 /* use only data cells in seg_size */
1649 seg_size
= (seg_size
/ SCM_GC_CARD_N_CELLS
) * (SCM_GC_CARD_N_DATA_CELLS
/ span
) * span
;
1651 scm_gc_cells_swept
+= seg_size
;
1653 for (j
= seg_size
+ span
; j
-= span
; ptr
+= span
)
1657 if (SCM_GC_IN_CARD_HEADERP (ptr
))
1663 NEXT_DATA_CELL (nxt
, span
);
1670 scmptr
= PTR2SCM (ptr
);
1672 if (SCM_GCMARKP (scmptr
))
1675 switch SCM_TYP7 (scmptr
)
1677 case scm_tcs_cons_gloc
:
1679 /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
1680 * struct or a gloc. See the corresponding comment in
1683 scm_bits_t word0
= (SCM_CELL_WORD_0 (scmptr
)
1684 - scm_tc3_cons_gloc
);
1685 /* access as struct */
1686 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
;
1687 if (vtable_data
[scm_vtable_index_vcell
] == 0)
1689 /* Structs need to be freed in a special order.
1690 * This is handled by GC C hooks in struct.c.
1692 SCM_SET_STRUCT_GC_CHAIN (scmptr
, scm_structs_to_free
);
1693 scm_structs_to_free
= scmptr
;
1696 /* fall through so that scmptr gets collected */
1699 case scm_tcs_cons_imcar
:
1700 case scm_tcs_cons_nimcar
:
1701 case scm_tcs_closures
:
1705 m
+= (2 + SCM_VECTOR_LENGTH (scmptr
)) * sizeof (SCM
);
1706 scm_must_free (SCM_VECTOR_BASE (scmptr
) - 2);
1708 case scm_tc7_vector
:
1710 unsigned long int length
= SCM_VECTOR_LENGTH (scmptr
);
1713 m
+= length
* sizeof (scm_bits_t
);
1714 scm_must_free (SCM_VECTOR_BASE (scmptr
));
1720 m
+= (SCM_CCLO_LENGTH (scmptr
) * sizeof (SCM
));
1721 scm_must_free (SCM_CCLO_BASE (scmptr
));
1727 unsigned long int length
= SCM_BITVECTOR_LENGTH (scmptr
);
1730 m
+= sizeof (long) * ((length
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
1731 scm_must_free (SCM_BITVECTOR_BASE (scmptr
));
1735 case scm_tc7_byvect
:
1739 #ifdef HAVE_LONG_LONGS
1740 case scm_tc7_llvect
:
1745 m
+= SCM_UVECTOR_LENGTH (scmptr
) * scm_uniform_element_size (scmptr
);
1746 scm_must_free (SCM_UVECTOR_BASE (scmptr
));
1749 case scm_tc7_substring
:
1751 case scm_tc7_string
:
1752 m
+= SCM_STRING_LENGTH (scmptr
) + 1;
1753 scm_must_free (SCM_STRING_CHARS (scmptr
));
1755 case scm_tc7_symbol
:
1756 m
+= SCM_SYMBOL_LENGTH (scmptr
) + 1;
1757 scm_must_free (SCM_SYMBOL_CHARS (scmptr
));
1760 /* the various "subrs" (primitives) are never freed */
1763 if SCM_OPENP (scmptr
)
1765 int k
= SCM_PTOBNUM (scmptr
);
1766 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1767 if (!(k
< scm_numptob
))
1768 SCM_MISC_ERROR ("undefined port type", SCM_EOL
);
1770 /* Keep "revealed" ports alive. */
1771 if (scm_revealed_count (scmptr
) > 0)
1773 /* Yes, I really do mean scm_ptobs[k].free */
1774 /* rather than ftobs[k].close. .close */
1775 /* is for explicit CLOSE-PORT by user */
1776 m
+= (scm_ptobs
[k
].free
) (scmptr
);
1777 SCM_SETSTREAM (scmptr
, 0);
1778 scm_remove_from_port_table (scmptr
);
1779 scm_gc_ports_collected
++;
1780 SCM_CLR_PORT_OPEN_FLAG (scmptr
);
1784 switch SCM_TYP16 (scmptr
)
1786 case scm_tc_free_cell
:
1791 m
+= (SCM_NUMDIGS (scmptr
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
);
1792 scm_must_free (SCM_BDIGITS (scmptr
));
1794 #endif /* def SCM_BIGDIG */
1795 case scm_tc16_complex
:
1796 m
+= sizeof (scm_complex_t
);
1797 scm_must_free (SCM_COMPLEX_MEM (scmptr
));
1802 k
= SCM_SMOBNUM (scmptr
);
1803 #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
1804 if (!(k
< scm_numsmob
))
1805 SCM_MISC_ERROR ("undefined smob type", SCM_EOL
);
1807 if (scm_smobs
[k
].free
)
1808 m
+= (scm_smobs
[k
].free
) (scmptr
);
1814 SCM_MISC_ERROR ("unknown type", SCM_EOL
);
1817 if (!--left_to_collect
)
1819 SCM_SET_CELL_WORD_0 (scmptr
, nfreelist
);
1820 *freelist
->clustertail
= scmptr
;
1821 freelist
->clustertail
= SCM_CDRLOC (scmptr
);
1823 nfreelist
= SCM_EOL
;
1824 freelist
->collected
+= span
* freelist
->cluster_size
;
1825 left_to_collect
= freelist
->cluster_size
;
1829 /* Stick the new cell on the front of nfreelist. It's
1830 critical that we mark this cell as freed; otherwise, the
1831 conservative collector might trace it as some other type
1833 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
1834 SCM_SET_FREE_CELL_CDR (scmptr
, nfreelist
);
1839 #ifdef GC_FREE_SEGMENTS
1844 freelist
->heap_size
-= seg_size
;
1845 free ((char *) scm_heap_table
[i
].bounds
[0]);
1846 scm_heap_table
[i
].bounds
[0] = 0;
1847 for (j
= i
+ 1; j
< scm_n_heap_segs
; j
++)
1848 scm_heap_table
[j
- 1] = scm_heap_table
[j
];
1849 scm_n_heap_segs
-= 1;
1850 i
--; /* We need to scan the segment just moved. */
1853 #endif /* ifdef GC_FREE_SEGMENTS */
1855 /* Update the real freelist pointer to point to the head of
1856 the list of free cells we've built for this segment. */
1857 freelist
->cells
= nfreelist
;
1858 freelist
->left_to_collect
= left_to_collect
;
1861 #ifdef GUILE_DEBUG_FREELIST
1862 scm_map_free_list ();
1866 gc_sweep_freelist_finish (&scm_master_freelist
);
1867 gc_sweep_freelist_finish (&scm_master_freelist2
);
1869 /* When we move to POSIX threads private freelists should probably
1870 be GC-protected instead. */
1871 scm_freelist
= SCM_EOL
;
1872 scm_freelist2
= SCM_EOL
;
1874 scm_cells_allocated
= (SCM_HEAP_SIZE
- scm_gc_cells_collected
);
1875 scm_gc_yield
-= scm_cells_allocated
;
1877 if (scm_mallocated
< m
)
1878 /* The byte count of allocated objects has underflowed. This is
1879 probably because you forgot to report the sizes of objects you
1880 have allocated, by calling scm_done_malloc or some such. When
1881 the GC freed them, it subtracted their size from
1882 scm_mallocated, which underflowed. */
1885 scm_mallocated
-= m
;
1886 scm_gc_malloc_collected
= m
;
1892 /* {Front end to malloc}
1894 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
1897 * These functions provide services comparable to malloc, realloc, and
1898 * free. They should be used when allocating memory that will be under
1899 * control of the garbage collector, i.e., if the memory may be freed
1900 * during garbage collection.
1904 * Return newly malloced storage or throw an error.
1906 * The parameter WHAT is a string for error reporting.
1907 * If the threshold scm_mtrigger will be passed by this
1908 * allocation, or if the first call to malloc fails,
1909 * garbage collect -- on the presumption that some objects
1910 * using malloced storage may be collected.
1912 * The limit scm_mtrigger may be raised by this allocation.
1915 scm_must_malloc (size_t size
, const char *what
)
1918 unsigned long nm
= scm_mallocated
+ size
;
1921 /* The byte count of allocated objects has overflowed. This is
1922 probably because you forgot to report the correct size of freed
1923 memory in some of your smob free methods. */
1926 if (nm
<= scm_mtrigger
)
1928 SCM_SYSCALL (ptr
= malloc (size
));
1931 scm_mallocated
= nm
;
1932 #ifdef GUILE_DEBUG_MALLOC
1933 scm_malloc_register (ptr
, what
);
1941 nm
= scm_mallocated
+ size
;
1944 /* The byte count of allocated objects has overflowed. This is
1945 probably because you forgot to report the correct size of freed
1946 memory in some of your smob free methods. */
1949 SCM_SYSCALL (ptr
= malloc (size
));
1952 scm_mallocated
= nm
;
1953 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
1954 if (nm
> scm_mtrigger
)
1955 scm_mtrigger
= nm
+ nm
/ 2;
1957 scm_mtrigger
+= scm_mtrigger
/ 2;
1959 #ifdef GUILE_DEBUG_MALLOC
1960 scm_malloc_register (ptr
, what
);
1966 scm_memory_error (what
);
1971 * is similar to scm_must_malloc.
1974 scm_must_realloc (void *where
,
1982 if (size
<= old_size
)
1985 nm
= scm_mallocated
+ size
- old_size
;
1987 if (nm
< (size
- old_size
))
1988 /* The byte count of allocated objects has overflowed. This is
1989 probably because you forgot to report the correct size of freed
1990 memory in some of your smob free methods. */
1993 if (nm
<= scm_mtrigger
)
1995 SCM_SYSCALL (ptr
= realloc (where
, size
));
1998 scm_mallocated
= nm
;
1999 #ifdef GUILE_DEBUG_MALLOC
2000 scm_malloc_reregister (where
, ptr
, what
);
2008 nm
= scm_mallocated
+ size
- old_size
;
2010 if (nm
< (size
- old_size
))
2011 /* The byte count of allocated objects has overflowed. This is
2012 probably because you forgot to report the correct size of freed
2013 memory in some of your smob free methods. */
2016 SCM_SYSCALL (ptr
= realloc (where
, size
));
2019 scm_mallocated
= nm
;
2020 if (nm
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
) {
2021 if (nm
> scm_mtrigger
)
2022 scm_mtrigger
= nm
+ nm
/ 2;
2024 scm_mtrigger
+= scm_mtrigger
/ 2;
2026 #ifdef GUILE_DEBUG_MALLOC
2027 scm_malloc_reregister (where
, ptr
, what
);
2032 scm_memory_error (what
);
2036 scm_must_strndup (const char *str
, size_t length
)
2038 char * dst
= scm_must_malloc (length
+ 1, "scm_must_strndup");
2039 memcpy (dst
, str
, length
);
2045 scm_must_strdup (const char *str
)
2047 return scm_must_strndup (str
, strlen (str
));
2051 scm_must_free (void *obj
)
2052 #define FUNC_NAME "scm_must_free"
2054 #ifdef GUILE_DEBUG_MALLOC
2055 scm_malloc_unregister (obj
);
2060 SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL
);
2065 /* Announce that there has been some malloc done that will be freed
2066 * during gc. A typical use is for a smob that uses some malloced
2067 * memory but can not get it from scm_must_malloc (for whatever
2068 * reason). When a new object of this smob is created you call
2069 * scm_done_malloc with the size of the object. When your smob free
2070 * function is called, be sure to include this size in the return
2073 * If you can't actually free the memory in the smob free function,
2074 * for whatever reason (like reference counting), you still can (and
2075 * should) report the amount of memory freed when you actually free it.
2076 * Do it by calling scm_done_malloc with the _negated_ size. Clever,
2077 * eh? Or even better, call scm_done_free. */
2080 scm_done_malloc (long size
)
2083 if (scm_mallocated
< size
)
2084 /* The byte count of allocated objects has underflowed. This is
2085 probably because you forgot to report the sizes of objects you
2086 have allocated, by calling scm_done_malloc or some such. When
2087 the GC freed them, it subtracted their size from
2088 scm_mallocated, which underflowed. */
2091 unsigned long nm
= scm_mallocated
+ size
;
2093 /* The byte count of allocated objects has overflowed. This is
2094 probably because you forgot to report the correct size of freed
2095 memory in some of your smob free methods. */
2099 scm_mallocated
+= size
;
2101 if (scm_mallocated
> scm_mtrigger
)
2103 scm_igc ("foreign mallocs");
2104 if (scm_mallocated
> scm_mtrigger
- SCM_MTRIGGER_HYSTERESIS
)
2106 if (scm_mallocated
> scm_mtrigger
)
2107 scm_mtrigger
= scm_mallocated
+ scm_mallocated
/ 2;
2109 scm_mtrigger
+= scm_mtrigger
/ 2;
2115 scm_done_free (long size
)
2118 if (scm_mallocated
< size
)
2119 /* The byte count of allocated objects has underflowed. This is
2120 probably because you forgot to report the sizes of objects you
2121 have allocated, by calling scm_done_malloc or some such. When
2122 the GC freed them, it subtracted their size from
2123 scm_mallocated, which underflowed. */
2126 unsigned long nm
= scm_mallocated
+ size
;
2128 /* The byte count of allocated objects has overflowed. This is
2129 probably because you forgot to report the correct size of freed
2130 memory in some of your smob free methods. */
2134 scm_mallocated
-= size
;
2141 * Each heap segment is an array of objects of a particular size.
2142 * Every segment has an associated (possibly shared) freelist.
2143 * A table of segment records is kept that records the upper and
2144 * lower extents of the segment; this is used during the conservative
2145 * phase of gc to identify probably gc roots (because they point
2146 * into valid segments at reasonable offsets). */
2149 * is true if the first segment was smaller than INIT_HEAP_SEG.
2150 * If scm_expmem is set to one, subsequent segment allocations will
2151 * allocate segments of size SCM_EXPHEAP(scm_heap_size).
2155 size_t scm_max_segment_size
;
2158 * is the lowest base address of any heap segment.
2160 SCM_CELLPTR scm_heap_org
;
2162 scm_heap_seg_data_t
* scm_heap_table
= 0;
2163 static size_t heap_segment_table_size
= 0;
2164 size_t scm_n_heap_segs
= 0;
2167 * initializes a new heap segment and returns the number of objects it contains.
2169 * The segment origin and segment size in bytes are input parameters.
2170 * The freelist is both input and output.
2172 * This function presumes that the scm_heap_table has already been expanded
2173 * to accomodate a new segment record and that the markbit space was reserved
2174 * for all the cards in this segment.
2177 #define INIT_CARD(card, span) \
2179 SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \
2181 SCM_GC_SET_CARD_DOUBLECELL (card); \
2185 init_heap_seg (SCM_CELLPTR seg_org
, size_t size
, scm_freelist_t
*freelist
)
2187 register SCM_CELLPTR ptr
;
2188 SCM_CELLPTR seg_end
;
2190 ptrdiff_t n_new_cells
;
2191 int span
= freelist
->span
;
2193 if (seg_org
== NULL
)
2196 /* Align the begin ptr up.
2198 ptr
= SCM_GC_CARD_UP (seg_org
);
2200 /* Compute the ceiling on valid object pointers w/in this segment.
2202 seg_end
= SCM_GC_CARD_DOWN ((char *)seg_org
+ size
);
2204 /* Find the right place and insert the segment record.
2207 for (new_seg_index
= 0;
2208 ( (new_seg_index
< scm_n_heap_segs
)
2209 && SCM_PTR_LE (scm_heap_table
[new_seg_index
].bounds
[0], seg_org
));
2215 for (i
= scm_n_heap_segs
; i
> new_seg_index
; --i
)
2216 scm_heap_table
[i
] = scm_heap_table
[i
- 1];
2221 scm_heap_table
[new_seg_index
].span
= span
;
2222 scm_heap_table
[new_seg_index
].freelist
= freelist
;
2223 scm_heap_table
[new_seg_index
].bounds
[0] = ptr
;
2224 scm_heap_table
[new_seg_index
].bounds
[1] = seg_end
;
2227 n_new_cells
= seg_end
- ptr
;
2229 freelist
->heap_size
+= n_new_cells
;
2231 /* Partition objects in this segment into clusters */
2234 SCM
*clusterp
= &clusters
;
2236 NEXT_DATA_CELL (ptr
, span
);
2237 while (ptr
< seg_end
)
2239 scm_cell
*nxt
= ptr
;
2240 scm_cell
*prv
= NULL
;
2241 scm_cell
*last_card
= NULL
;
2242 int n_data_cells
= (SCM_GC_CARD_N_DATA_CELLS
/ span
) * SCM_CARDS_PER_CLUSTER
- 1;
2243 NEXT_DATA_CELL(nxt
, span
);
2245 /* Allocate cluster spine
2247 *clusterp
= PTR2SCM (ptr
);
2248 SCM_SETCAR (*clusterp
, PTR2SCM (nxt
));
2249 clusterp
= SCM_CDRLOC (*clusterp
);
2252 while (n_data_cells
--)
2254 scm_cell
*card
= SCM_GC_CELL_CARD (ptr
);
2255 SCM scmptr
= PTR2SCM (ptr
);
2257 NEXT_DATA_CELL (nxt
, span
);
2260 if (card
!= last_card
)
2262 INIT_CARD (card
, span
);
2266 SCM_SET_CELL_TYPE (scmptr
, scm_tc_free_cell
);
2267 SCM_SET_FREE_CELL_CDR (scmptr
, PTR2SCM (nxt
));
2272 SCM_SET_FREE_CELL_CDR (PTR2SCM (prv
), SCM_EOL
);
2277 scm_cell
*ref
= seg_end
;
2278 NEXT_DATA_CELL (ref
, span
);
2280 /* [cmm] looks like the segment size doesn't divide cleanly by
2281 cluster size. bad cmm! */
2285 /* Patch up the last cluster pointer in the segment
2286 * to join it to the input freelist.
2288 *clusterp
= freelist
->clusters
;
2289 freelist
->clusters
= clusters
;
2293 fprintf (stderr
, "H");
2299 round_to_cluster_size (scm_freelist_t
*freelist
, size_t len
)
2301 size_t cluster_size_in_bytes
= CLUSTER_SIZE_IN_BYTES (freelist
);
2304 (len
+ cluster_size_in_bytes
- 1) / cluster_size_in_bytes
* cluster_size_in_bytes
2305 + ALIGNMENT_SLACK (freelist
);
2309 alloc_some_heap (scm_freelist_t
*freelist
, policy_on_error error_policy
)
2310 #define FUNC_NAME "alloc_some_heap"
2315 if (scm_gc_heap_lock
)
2317 /* Critical code sections (such as the garbage collector) aren't
2318 * supposed to add heap segments.
2320 fprintf (stderr
, "alloc_some_heap: Can not extend locked heap.\n");
2324 if (scm_n_heap_segs
== heap_segment_table_size
)
2326 /* We have to expand the heap segment table to have room for the new
2327 * segment. Do not yet increment scm_n_heap_segs -- that is done by
2328 * init_heap_seg only if the allocation of the segment itself succeeds.
2330 size_t new_table_size
= scm_n_heap_segs
+ 1;
2331 size_t size
= new_table_size
* sizeof (scm_heap_seg_data_t
);
2332 scm_heap_seg_data_t
*new_heap_table
;
2334 SCM_SYSCALL (new_heap_table
= ((scm_heap_seg_data_t
*)
2335 realloc ((char *)scm_heap_table
, size
)));
2336 if (!new_heap_table
)
2338 if (error_policy
== abort_on_error
)
2340 fprintf (stderr
, "alloc_some_heap: Could not grow heap segment table.\n");
2350 scm_heap_table
= new_heap_table
;
2351 heap_segment_table_size
= new_table_size
;
2355 /* Pick a size for the new heap segment.
2356 * The rule for picking the size of a segment is explained in
2360 /* Assure that the new segment is predicted to be large enough.
2362 * New yield should at least equal GC fraction of new heap size, i.e.
2364 * y + dh > f * (h + dh)
2367 * f : min yield fraction
2369 * dh : size of new heap segment
2371 * This gives dh > (f * h - y) / (1 - f)
2373 int f
= freelist
->min_yield_fraction
;
2374 unsigned long h
= SCM_HEAP_SIZE
;
2375 size_t min_cells
= (f
* h
- 100 * (long) scm_gc_yield
) / (99 - f
);
2376 len
= SCM_EXPHEAP (freelist
->heap_size
);
2378 fprintf (stderr
, "(%ld < %ld)", (long) len
, (long) min_cells
);
2380 if (len
< min_cells
)
2381 len
= min_cells
+ freelist
->cluster_size
;
2382 len
*= sizeof (scm_cell
);
2383 /* force new sampling */
2384 freelist
->collected
= LONG_MAX
;
2387 if (len
> scm_max_segment_size
)
2388 len
= scm_max_segment_size
;
2393 smallest
= CLUSTER_SIZE_IN_BYTES (freelist
);
2398 /* Allocate with decaying ambition. */
2399 while ((len
>= SCM_MIN_HEAP_SEG_SIZE
)
2400 && (len
>= smallest
))
2402 size_t rounded_len
= round_to_cluster_size (freelist
, len
);
2403 SCM_SYSCALL (ptr
= (SCM_CELLPTR
) malloc (rounded_len
));
2406 init_heap_seg (ptr
, rounded_len
, freelist
);
2413 if (error_policy
== abort_on_error
)
2415 fprintf (stderr
, "alloc_some_heap: Could not grow heap.\n");
2422 /* {GC Protection Helper Functions}
2427 * If within a function you need to protect one or more scheme objects from
2428 * garbage collection, pass them as parameters to one of the
2429 * scm_remember_upto_here* functions below. These functions don't do
2430 * anything, but since the compiler does not know that they are actually
2431 * no-ops, it will generate code that calls these functions with the given
2432 * parameters. Therefore, you can be sure that the compiler will keep those
2433 * scheme values alive (on the stack or in a register) up to the point where
2434 * scm_remember_upto_here* is called. In other words, place the call to
2435 * scm_remember_upt_here* _behind_ the last code in your function, that
2436 * depends on the scheme object to exist.
2438 * Example: We want to make sure, that the string object str does not get
2439 * garbage collected during the execution of 'some_function', because
2440 * otherwise the characters belonging to str would be freed and
2441 * 'some_function' might access freed memory. To make sure that the compiler
2442 * keeps str alive on the stack or in a register such that it is visible to
2443 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
2444 * call to 'some_function'. Note that this would not be necessary if str was
2445 * used anyway after the call to 'some_function'.
2446 * char *chars = SCM_STRING_CHARS (str);
2447 * some_function (chars);
2448 * scm_remember_upto_here_1 (str); // str will be alive up to this point.
2452 scm_remember_upto_here_1 (SCM obj
)
2454 /* Empty. Protects a single object from garbage collection. */
2458 scm_remember_upto_here_2 (SCM obj1
, SCM obj2
)
2460 /* Empty. Protects two objects from garbage collection. */
2464 scm_remember_upto_here (SCM obj
, ...)
2466 /* Empty. Protects any number of objects from garbage collection. */
2470 #if (SCM_DEBUG_DEPRECATED == 0)
2473 scm_remember (SCM
*ptr
)
2475 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
2476 "Use the `scm_remember_upto_here*' family of functions instead.");
2480 scm_protect_object (SCM obj
)
2482 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
2483 "Use `scm_gc_protect_object' instead.");
2484 return scm_gc_protect_object (obj
);
2488 scm_unprotect_object (SCM obj
)
2490 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
2491 "Use `scm_gc_unprotect_object' instead.");
2492 return scm_gc_unprotect_object (obj
);
2495 #endif /* SCM_DEBUG_DEPRECATED == 0 */
2498 These crazy functions prevent garbage collection
2499 of arguments after the first argument by
2500 ensuring they remain live throughout the
2501 function because they are used in the last
2502 line of the code block.
2503 It'd be better to have a nice compiler hint to
2504 aid the conservative stack-scanning GC. --03/09/00 gjb */
2506 scm_return_first (SCM elt
, ...)
2512 scm_return_first_int (int i
, ...)
2519 scm_permanent_object (SCM obj
)
2522 scm_permobjs
= scm_cons (obj
, scm_permobjs
);
2528 /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
2529 other references are dropped, until the object is unprotected by calling
2530 scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
2531 i. e. it is possible to protect the same object several times, but it is
2532 necessary to unprotect the object the same number of times to actually get
2533 the object unprotected. It is an error to unprotect an object more often
2534 than it has been protected before. The function scm_protect_object returns
2538 /* Implementation note: For every object X, there is a counter which
2539 scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
2543 scm_gc_protect_object (SCM obj
)
2547 /* This critical section barrier will be replaced by a mutex. */
2550 handle
= scm_hashq_create_handle_x (scm_protects
, obj
, SCM_MAKINUM (0));
2551 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), SCM_MAKINUM (1)));
2559 /* Remove any protection for OBJ established by a prior call to
2560 scm_protect_object. This function returns OBJ.
2562 See scm_protect_object for more information. */
2564 scm_gc_unprotect_object (SCM obj
)
2568 /* This critical section barrier will be replaced by a mutex. */
2571 handle
= scm_hashq_get_handle (scm_protects
, obj
);
2573 if (SCM_FALSEP (handle
))
2575 fprintf (stderr
, "scm_unprotect_object called on unprotected object\n");
2580 SCM count
= scm_difference (SCM_CDR (handle
), SCM_MAKINUM (1));
2581 if (SCM_EQ_P (count
, SCM_MAKINUM (0)))
2582 scm_hashq_remove_x (scm_protects
, obj
);
2584 SCM_SETCDR (handle
, count
);
2593 scm_gc_register_root (SCM
*p
)
2596 SCM key
= scm_long2num ((long) p
);
2598 /* This critical section barrier will be replaced by a mutex. */
2601 handle
= scm_hashv_create_handle_x (scm_gc_registered_roots
, key
, SCM_MAKINUM (0));
2602 SCM_SETCDR (handle
, scm_sum (SCM_CDR (handle
), SCM_MAKINUM (1)));
2608 scm_gc_unregister_root (SCM
*p
)
2611 SCM key
= scm_long2num ((long) p
);
2613 /* This critical section barrier will be replaced by a mutex. */
2616 handle
= scm_hashv_get_handle (scm_gc_registered_roots
, key
);
2618 if (SCM_FALSEP (handle
))
2620 fprintf (stderr
, "scm_gc_unregister_root called on unregistered root\n");
2625 SCM count
= scm_difference (SCM_CDR (handle
), SCM_MAKINUM (1));
2626 if (SCM_EQ_P (count
, SCM_MAKINUM (0)))
2627 scm_hashv_remove_x (scm_gc_registered_roots
, key
);
2629 SCM_SETCDR (handle
, count
);
2636 scm_gc_register_roots (SCM
*b
, unsigned long n
)
2639 for (; p
< b
+ n
; ++p
)
2640 scm_gc_register_root (p
);
2644 scm_gc_unregister_roots (SCM
*b
, unsigned long n
)
2647 for (; p
< b
+ n
; ++p
)
2648 scm_gc_unregister_root (p
);
2653 /* called on process termination. */
2659 extern int on_exit (void (*procp
) (), int arg
);
2662 cleanup (int status
, void *arg
)
2664 #error Dont know how to setup a cleanup handler on your system.
2669 scm_flush_all_ports ();
2674 make_initial_segment (size_t init_heap_size
, scm_freelist_t
*freelist
)
2676 size_t rounded_size
= round_to_cluster_size (freelist
, init_heap_size
);
2678 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2682 rounded_size
= round_to_cluster_size (freelist
, SCM_HEAP_SEG_SIZE
);
2683 if (!init_heap_seg ((SCM_CELLPTR
) malloc (rounded_size
),
2691 if (freelist
->min_yield_fraction
)
2692 freelist
->min_yield
= (freelist
->heap_size
* freelist
->min_yield_fraction
2694 freelist
->grow_heap_p
= (freelist
->heap_size
< freelist
->min_yield
);
2701 init_freelist (scm_freelist_t
*freelist
,
2706 freelist
->clusters
= SCM_EOL
;
2707 freelist
->cluster_size
= cluster_size
+ 1;
2708 freelist
->left_to_collect
= 0;
2709 freelist
->clusters_allocated
= 0;
2710 freelist
->min_yield
= 0;
2711 freelist
->min_yield_fraction
= min_yield
;
2712 freelist
->span
= span
;
2713 freelist
->collected
= 0;
2714 freelist
->collected_1
= 0;
2715 freelist
->heap_size
= 0;
2719 /* Get an integer from an environment variable. */
2721 scm_i_getenv_int (const char *var
, int def
)
2723 char *end
, *val
= getenv (var
);
2727 res
= strtol (val
, &end
, 10);
2737 unsigned long gc_trigger_1
;
2738 unsigned long gc_trigger_2
;
2739 size_t init_heap_size_1
;
2740 size_t init_heap_size_2
;
2743 #if (SCM_DEBUG_CELL_ACCESSES == 1)
2744 scm_tc16_allocated
= scm_make_smob_type ("allocated cell", 0);
2745 #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
2747 j
= SCM_NUM_PROTECTS
;
2749 scm_sys_protects
[--j
] = SCM_BOOL_F
;
2752 scm_freelist
= SCM_EOL
;
2753 scm_freelist2
= SCM_EOL
;
2754 gc_trigger_1
= scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1
);
2755 init_freelist (&scm_master_freelist
, 1, SCM_CLUSTER_SIZE_1
, gc_trigger_1
);
2756 gc_trigger_2
= scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2
);
2757 init_freelist (&scm_master_freelist2
, 2, SCM_CLUSTER_SIZE_2
, gc_trigger_2
);
2758 scm_max_segment_size
= scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size
);
2762 j
= SCM_HEAP_SEG_SIZE
;
2763 scm_mtrigger
= SCM_INIT_MALLOC_LIMIT
;
2764 scm_heap_table
= ((scm_heap_seg_data_t
*)
2765 scm_must_malloc (sizeof (scm_heap_seg_data_t
) * 2, "hplims"));
2766 heap_segment_table_size
= 2;
2768 mark_space_ptr
= &mark_space_head
;
2770 init_heap_size_1
= scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1
);
2771 init_heap_size_2
= scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2
);
2772 if (make_initial_segment (init_heap_size_1
, &scm_master_freelist
) ||
2773 make_initial_segment (init_heap_size_2
, &scm_master_freelist2
))
2776 /* scm_hplims[0] can change. do not remove scm_heap_org */
2777 scm_heap_org
= CELL_UP (scm_heap_table
[0].bounds
[0], 1);
2779 scm_c_hook_init (&scm_before_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2780 scm_c_hook_init (&scm_before_mark_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2781 scm_c_hook_init (&scm_before_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2782 scm_c_hook_init (&scm_after_sweep_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2783 scm_c_hook_init (&scm_after_gc_c_hook
, 0, SCM_C_HOOK_NORMAL
);
2785 /* Initialise the list of ports. */
2786 scm_port_table
= (scm_port_t
**)
2787 malloc (sizeof (scm_port_t
*) * scm_port_table_room
);
2788 if (!scm_port_table
)
2795 on_exit (cleanup
, 0);
2799 scm_stand_in_procs
= SCM_EOL
;
2800 scm_permobjs
= SCM_EOL
;
2801 scm_protects
= scm_c_make_hash_table (31);
2802 scm_gc_registered_roots
= scm_c_make_hash_table (31);
2809 SCM scm_after_gc_hook
;
2811 static SCM gc_async
;
2813 /* The function gc_async_thunk causes the execution of the after-gc-hook. It
2814 * is run after the gc, as soon as the asynchronous events are handled by the
2818 gc_async_thunk (void)
2820 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
2821 return SCM_UNSPECIFIED
;
2825 /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
2826 * the garbage collection. The only purpose of this function is to mark the
2827 * gc_async (which will eventually lead to the execution of the
2831 mark_gc_async (void * hook_data
, void *func_data
, void *data
)
2833 scm_system_async_mark (gc_async
);
2843 /* Dirk:FIXME:: scm_create_hook is strange. */
2844 scm_after_gc_hook
= scm_create_hook ("after-gc-hook", 0);
2846 after_gc_thunk
= scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0
,
2848 gc_async
= scm_system_async (after_gc_thunk
); /* protected via scm_asyncs */
2850 scm_c_hook_add (&scm_after_gc_c_hook
, mark_gc_async
, NULL
, 0);
2852 #ifndef SCM_MAGIC_SNARFER
2853 #include "libguile/gc.x"
2857 #endif /*MARK_DEPENDENCIES*/