| 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. |
| 2 | * |
| 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) |
| 6 | * any later version. |
| 7 | * |
| 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. |
| 12 | * |
| 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 |
| 17 | * |
| 18 | * As a special exception, the Free Software Foundation gives permission |
| 19 | * for additional uses of the text contained in its release of GUILE. |
| 20 | * |
| 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. |
| 26 | * |
| 27 | * This exception does not however invalidate any other reasons why |
| 28 | * the executable file might be covered by the GNU General Public License. |
| 29 | * |
| 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. |
| 37 | * |
| 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. */ |
| 41 | |
| 42 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, |
| 43 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ |
| 44 | |
| 45 | /* #define DEBUGINFO */ |
| 46 | |
| 47 | /* SECTION: This code is compiled once. |
| 48 | */ |
| 49 | |
| 50 | #ifndef MARK_DEPENDENCIES |
| 51 | |
| 52 | \f |
| 53 | #include <stdio.h> |
| 54 | #include <errno.h> |
| 55 | #include <string.h> |
| 56 | |
| 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" |
| 72 | |
| 73 | #include "libguile/validate.h" |
| 74 | #include "libguile/deprecation.h" |
| 75 | #include "libguile/gc.h" |
| 76 | |
| 77 | #ifdef GUILE_DEBUG_MALLOC |
| 78 | #include "libguile/debug-malloc.h" |
| 79 | #endif |
| 80 | |
| 81 | #ifdef HAVE_MALLOC_H |
| 82 | #include <malloc.h> |
| 83 | #endif |
| 84 | |
| 85 | #ifdef HAVE_UNISTD_H |
| 86 | #include <unistd.h> |
| 87 | #endif |
| 88 | |
| 89 | #ifdef __STDC__ |
| 90 | #include <stdarg.h> |
| 91 | #define var_start(x, y) va_start(x, y) |
| 92 | #else |
| 93 | #include <varargs.h> |
| 94 | #define var_start(x, y) va_start(x) |
| 95 | #endif |
| 96 | |
| 97 | \f |
| 98 | |
| 99 | unsigned int scm_gc_running_p = 0; |
| 100 | |
| 101 | \f |
| 102 | |
| 103 | #if (SCM_DEBUG_CELL_ACCESSES == 1) |
| 104 | |
| 105 | scm_bits_t scm_tc16_allocated; |
| 106 | |
| 107 | /* Set this to != 0 if every cell that is accessed shall be checked: |
| 108 | */ |
| 109 | unsigned int scm_debug_cell_accesses_p = 1; |
| 110 | |
| 111 | |
| 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. |
| 116 | */ |
| 117 | void |
| 118 | scm_assert_cell_valid (SCM cell) |
| 119 | { |
| 120 | static unsigned int already_running = 0; |
| 121 | |
| 122 | if (scm_debug_cell_accesses_p && !already_running) |
| 123 | { |
| 124 | already_running = 1; /* set to avoid recursion */ |
| 125 | |
| 126 | if (!scm_cellp (cell)) |
| 127 | { |
| 128 | fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lux\n", |
| 129 | (unsigned long) SCM_UNPACK (cell)); |
| 130 | abort (); |
| 131 | } |
| 132 | else if (!scm_gc_running_p) |
| 133 | { |
| 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 |
| 141 | gc is running. |
| 142 | */ |
| 143 | if (SCM_FREE_CELL_P (cell)) |
| 144 | { |
| 145 | fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lux\n", |
| 146 | (unsigned long) SCM_UNPACK (cell)); |
| 147 | abort (); |
| 148 | } |
| 149 | } |
| 150 | already_running = 0; /* re-enable */ |
| 151 | } |
| 152 | } |
| 153 | |
| 154 | |
| 155 | SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, |
| 156 | (SCM flag), |
| 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 |
| 162 | { |
| 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; |
| 167 | } else { |
| 168 | SCM_WRONG_TYPE_ARG (1, flag); |
| 169 | } |
| 170 | return SCM_UNSPECIFIED; |
| 171 | } |
| 172 | #undef FUNC_NAME |
| 173 | |
| 174 | #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ |
| 175 | |
| 176 | \f |
| 177 | |
| 178 | /* {heap tuning parameters} |
| 179 | * |
| 180 | * These are parameters for controlling memory allocation. The heap |
| 181 | * is the area out of which scm_cons, and object headers are allocated. |
| 182 | * |
| 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. |
| 186 | * |
| 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. |
| 190 | * |
| 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 |
| 195 | * |
| 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. |
| 198 | * |
| 199 | * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap |
| 200 | * is needed. |
| 201 | * |
| 202 | * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will |
| 203 | * trigger a GC. |
| 204 | * |
| 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.] |
| 210 | */ |
| 211 | |
| 212 | /* |
| 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. |
| 217 | */ |
| 218 | |
| 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; |
| 225 | |
| 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 |
| 231 | */ |
| 232 | int scm_default_min_yield_2 = 40; |
| 233 | |
| 234 | size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ |
| 235 | |
| 236 | #define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE) |
| 237 | #ifdef _QC |
| 238 | # define SCM_HEAP_SEG_SIZE 32768L |
| 239 | #else |
| 240 | # ifdef sequent |
| 241 | # define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell)) |
| 242 | # else |
| 243 | # define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell)) |
| 244 | # endif |
| 245 | #endif |
| 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) |
| 250 | |
| 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 */ |
| 253 | |
| 254 | #ifdef PROT386 |
| 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)) |
| 258 | #else |
| 259 | # ifdef _UNICOS |
| 260 | # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span))) |
| 261 | # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p)) |
| 262 | # else |
| 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)) |
| 265 | # endif /* UNICOS */ |
| 266 | #endif /* PROT386 */ |
| 267 | |
| 268 | #define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) |
| 269 | |
| 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) |
| 273 | |
| 274 | \f |
| 275 | /* scm_freelists |
| 276 | */ |
| 277 | |
| 278 | typedef struct scm_freelist_t { |
| 279 | /* collected cells */ |
| 280 | SCM 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 |
| 287 | */ |
| 288 | SCM clusters; |
| 289 | SCM *clustertail; |
| 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 |
| 293 | */ |
| 294 | int grow_heap_p; |
| 295 | /* minimum yield on this list in order not to grow the heap |
| 296 | */ |
| 297 | long min_yield; |
| 298 | /* defines min_yield as percent of total heap size |
| 299 | */ |
| 300 | int min_yield_fraction; |
| 301 | /* number of cells per object on this list */ |
| 302 | int span; |
| 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. |
| 309 | */ |
| 310 | unsigned long heap_size; |
| 311 | } scm_freelist_t; |
| 312 | |
| 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 |
| 316 | }; |
| 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 |
| 320 | }; |
| 321 | |
| 322 | /* scm_mtrigger |
| 323 | * is the number of bytes of must_malloc allocation needed to trigger gc. |
| 324 | */ |
| 325 | unsigned long scm_mtrigger; |
| 326 | |
| 327 | /* scm_gc_heap_lock |
| 328 | * If set, don't expand the heap. Set only during gc, during which no allocation |
| 329 | * is supposed to take place anyway. |
| 330 | */ |
| 331 | int scm_gc_heap_lock = 0; |
| 332 | |
| 333 | /* GC Blocking |
| 334 | * Don't pause for collection if this is set -- just |
| 335 | * expand the heap. |
| 336 | */ |
| 337 | int scm_block_gc = 1; |
| 338 | |
| 339 | /* During collection, this accumulates objects holding |
| 340 | * weak references. |
| 341 | */ |
| 342 | SCM scm_weak_vectors; |
| 343 | |
| 344 | /* During collection, this accumulates structures which are to be freed. |
| 345 | */ |
| 346 | SCM scm_structs_to_free; |
| 347 | |
| 348 | /* GC Statistics Keeping |
| 349 | */ |
| 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.; |
| 366 | |
| 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"); |
| 378 | |
| 379 | typedef struct scm_heap_seg_data_t |
| 380 | { |
| 381 | /* lower and upper bounds of the segment */ |
| 382 | SCM_CELLPTR bounds[2]; |
| 383 | |
| 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; |
| 387 | |
| 388 | /* number of cells per object in this segment */ |
| 389 | int span; |
| 390 | } scm_heap_seg_data_t; |
| 391 | |
| 392 | |
| 393 | |
| 394 | static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_freelist_t *); |
| 395 | |
| 396 | typedef enum { return_on_error, abort_on_error } policy_on_error; |
| 397 | static void alloc_some_heap (scm_freelist_t *, policy_on_error); |
| 398 | |
| 399 | |
| 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)) |
| 403 | |
| 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)) |
| 407 | |
| 408 | /* mark space allocation */ |
| 409 | |
| 410 | typedef struct scm_mark_space_t |
| 411 | { |
| 412 | scm_c_bvec_limb_t *bvec_space; |
| 413 | struct scm_mark_space_t *next; |
| 414 | } scm_mark_space_t; |
| 415 | |
| 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; |
| 420 | |
| 421 | static scm_c_bvec_limb_t * |
| 422 | get_bvec () |
| 423 | #define FUNC_NAME "get_bvec" |
| 424 | { |
| 425 | scm_c_bvec_limb_t *res; |
| 426 | |
| 427 | if (!current_mark_space) |
| 428 | { |
| 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); |
| 432 | |
| 433 | current_mark_space->bvec_space = NULL; |
| 434 | current_mark_space->next = NULL; |
| 435 | |
| 436 | *mark_space_ptr = current_mark_space; |
| 437 | mark_space_ptr = &(current_mark_space->next); |
| 438 | |
| 439 | return get_bvec (); |
| 440 | } |
| 441 | |
| 442 | if (!(current_mark_space->bvec_space)) |
| 443 | { |
| 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); |
| 448 | |
| 449 | current_mark_space_offset = 0; |
| 450 | |
| 451 | return get_bvec (); |
| 452 | } |
| 453 | |
| 454 | if (current_mark_space_offset == BVEC_GROW_SIZE_IN_LIMBS) |
| 455 | { |
| 456 | current_mark_space = NULL; |
| 457 | |
| 458 | return get_bvec (); |
| 459 | } |
| 460 | |
| 461 | res = current_mark_space->bvec_space + current_mark_space_offset; |
| 462 | current_mark_space_offset += SCM_GC_CARD_BVEC_SIZE_IN_LIMBS; |
| 463 | |
| 464 | return res; |
| 465 | } |
| 466 | #undef FUNC_NAME |
| 467 | |
| 468 | |
| 469 | static void |
| 470 | clear_mark_space () |
| 471 | { |
| 472 | scm_mark_space_t *ms; |
| 473 | |
| 474 | for (ms = mark_space_head; ms; ms = ms->next) |
| 475 | memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES); |
| 476 | } |
| 477 | |
| 478 | |
| 479 | \f |
| 480 | /* Debugging functions. */ |
| 481 | |
| 482 | #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) |
| 483 | |
| 484 | /* Return the number of the heap segment containing CELL. */ |
| 485 | static long |
| 486 | which_seg (SCM cell) |
| 487 | { |
| 488 | long i; |
| 489 | |
| 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))) |
| 493 | return i; |
| 494 | fprintf (stderr, "which_seg: can't find segment containing cell %lux\n", |
| 495 | (unsigned long) SCM_UNPACK (cell)); |
| 496 | abort (); |
| 497 | } |
| 498 | |
| 499 | |
| 500 | static void |
| 501 | map_free_list (scm_freelist_t *master, SCM freelist) |
| 502 | { |
| 503 | long last_seg = -1, count = 0; |
| 504 | SCM f; |
| 505 | |
| 506 | for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) |
| 507 | { |
| 508 | long this_seg = which_seg (f); |
| 509 | |
| 510 | if (this_seg != last_seg) |
| 511 | { |
| 512 | if (last_seg != -1) |
| 513 | fprintf (stderr, " %5ld %d-cells in segment %ld\n", |
| 514 | (long) count, master->span, (long) last_seg); |
| 515 | last_seg = this_seg; |
| 516 | count = 0; |
| 517 | } |
| 518 | count++; |
| 519 | } |
| 520 | if (last_seg != -1) |
| 521 | fprintf (stderr, " %5ld %d-cells in segment %ld\n", |
| 522 | (long) count, master->span, (long) last_seg); |
| 523 | } |
| 524 | |
| 525 | SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, |
| 526 | (), |
| 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 |
| 531 | { |
| 532 | long i; |
| 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); |
| 544 | fflush (stderr); |
| 545 | |
| 546 | return SCM_UNSPECIFIED; |
| 547 | } |
| 548 | #undef FUNC_NAME |
| 549 | |
| 550 | static long last_cluster; |
| 551 | static long last_size; |
| 552 | |
| 553 | static long |
| 554 | free_list_length (char *title, long i, SCM freelist) |
| 555 | { |
| 556 | SCM ls; |
| 557 | long n = 0; |
| 558 | for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls)) |
| 559 | if (SCM_FREE_CELL_P (ls)) |
| 560 | ++n; |
| 561 | else |
| 562 | { |
| 563 | fprintf (stderr, "bad cell in %s at position %ld\n", title, (long) n); |
| 564 | abort (); |
| 565 | } |
| 566 | if (n != last_size) |
| 567 | { |
| 568 | if (i > 0) |
| 569 | { |
| 570 | if (last_cluster == i - 1) |
| 571 | fprintf (stderr, "\t%ld\n", (long) last_size); |
| 572 | else |
| 573 | fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size); |
| 574 | } |
| 575 | if (i >= 0) |
| 576 | fprintf (stderr, "%s %ld", title, (long) i); |
| 577 | else |
| 578 | fprintf (stderr, "%s\t%ld\n", title, (long) n); |
| 579 | last_cluster = i; |
| 580 | last_size = n; |
| 581 | } |
| 582 | return n; |
| 583 | } |
| 584 | |
| 585 | static void |
| 586 | free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) |
| 587 | { |
| 588 | SCM clusters; |
| 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)) |
| 595 | { |
| 596 | len = free_list_length ("cluster", i++, SCM_CAR (clusters)); |
| 597 | n += len; |
| 598 | } |
| 599 | if (last_cluster == i - 1) |
| 600 | fprintf (stderr, "\t%ld\n", (long) last_size); |
| 601 | else |
| 602 | fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size); |
| 603 | fprintf (stderr, "\ntotal %ld objects\n\n", (long) n); |
| 604 | } |
| 605 | |
| 606 | SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, |
| 607 | (), |
| 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 |
| 612 | { |
| 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; |
| 616 | } |
| 617 | #undef FUNC_NAME |
| 618 | |
| 619 | #endif |
| 620 | |
| 621 | #ifdef GUILE_DEBUG_FREELIST |
| 622 | |
| 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; |
| 626 | |
| 627 | /* Number of calls to SCM_NEWCELL since startup. */ |
| 628 | static unsigned long scm_newcell_count; |
| 629 | static unsigned long scm_newcell2_count; |
| 630 | |
| 631 | /* Search freelist for anything that isn't marked as a free cell. |
| 632 | Abort if we find something. */ |
| 633 | static void |
| 634 | scm_check_freelist (SCM freelist) |
| 635 | { |
| 636 | SCM f; |
| 637 | long i = 0; |
| 638 | |
| 639 | for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++) |
| 640 | if (!SCM_FREE_CELL_P (f)) |
| 641 | { |
| 642 | fprintf (stderr, "Bad cell in freelist on newcell %lu: %lu'th elt\n", |
| 643 | (long) scm_newcell_count, (long) i); |
| 644 | abort (); |
| 645 | } |
| 646 | } |
| 647 | |
| 648 | SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, |
| 649 | (SCM flag), |
| 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 |
| 654 | { |
| 655 | /* [cmm] I did a double-take when I read this code the first time. |
| 656 | well, FWIW. */ |
| 657 | SCM_VALIDATE_BOOL_COPY (1, flag, scm_debug_check_freelist); |
| 658 | return SCM_UNSPECIFIED; |
| 659 | } |
| 660 | #undef FUNC_NAME |
| 661 | |
| 662 | |
| 663 | SCM |
| 664 | scm_debug_newcell (void) |
| 665 | { |
| 666 | SCM new; |
| 667 | |
| 668 | scm_newcell_count++; |
| 669 | if (scm_debug_check_freelist) |
| 670 | { |
| 671 | scm_check_freelist (scm_freelist); |
| 672 | scm_gc(); |
| 673 | } |
| 674 | |
| 675 | /* The rest of this is supposed to be identical to the SCM_NEWCELL |
| 676 | macro. */ |
| 677 | if (SCM_NULLP (scm_freelist)) |
| 678 | { |
| 679 | new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); |
| 680 | SCM_GC_SET_ALLOCATED (new); |
| 681 | } |
| 682 | else |
| 683 | { |
| 684 | new = scm_freelist; |
| 685 | scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); |
| 686 | SCM_GC_SET_ALLOCATED (new); |
| 687 | } |
| 688 | |
| 689 | return new; |
| 690 | } |
| 691 | |
| 692 | SCM |
| 693 | scm_debug_newcell2 (void) |
| 694 | { |
| 695 | SCM new; |
| 696 | |
| 697 | scm_newcell2_count++; |
| 698 | if (scm_debug_check_freelist) |
| 699 | { |
| 700 | scm_check_freelist (scm_freelist2); |
| 701 | scm_gc (); |
| 702 | } |
| 703 | |
| 704 | /* The rest of this is supposed to be identical to the SCM_NEWCELL |
| 705 | macro. */ |
| 706 | if (SCM_NULLP (scm_freelist2)) |
| 707 | { |
| 708 | new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); |
| 709 | SCM_GC_SET_ALLOCATED (new); |
| 710 | } |
| 711 | else |
| 712 | { |
| 713 | new = scm_freelist2; |
| 714 | scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); |
| 715 | SCM_GC_SET_ALLOCATED (new); |
| 716 | } |
| 717 | |
| 718 | return new; |
| 719 | } |
| 720 | |
| 721 | #endif /* GUILE_DEBUG_FREELIST */ |
| 722 | |
| 723 | \f |
| 724 | |
| 725 | static unsigned long |
| 726 | master_cells_allocated (scm_freelist_t *master) |
| 727 | { |
| 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; |
| 733 | } |
| 734 | |
| 735 | static unsigned long |
| 736 | freelist_length (SCM freelist) |
| 737 | { |
| 738 | long n; |
| 739 | for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist)) |
| 740 | ++n; |
| 741 | return n; |
| 742 | } |
| 743 | |
| 744 | static unsigned long |
| 745 | compute_cells_allocated () |
| 746 | { |
| 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)); |
| 752 | } |
| 753 | |
| 754 | /* {Scheme Interface to GC} |
| 755 | */ |
| 756 | |
| 757 | SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, |
| 758 | (), |
| 759 | "Return an association list of statistics about Guile's current\n" |
| 760 | "use of storage.") |
| 761 | #define FUNC_NAME s_scm_gc_stats |
| 762 | { |
| 763 | long i; |
| 764 | long n; |
| 765 | SCM heap_segs; |
| 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; |
| 776 | SCM answer; |
| 777 | |
| 778 | SCM_DEFER_INTS; |
| 779 | |
| 780 | ++scm_block_gc; |
| 781 | |
| 782 | retry: |
| 783 | heap_segs = SCM_EOL; |
| 784 | n = scm_n_heap_segs; |
| 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])), |
| 788 | heap_segs); |
| 789 | if (scm_n_heap_segs != n) |
| 790 | goto retry; |
| 791 | |
| 792 | --scm_block_gc; |
| 793 | |
| 794 | /* Below, we cons to produce the resulting list. We want a snapshot of |
| 795 | * the heap situation before consing. |
| 796 | */ |
| 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; |
| 807 | |
| 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), |
| 819 | SCM_UNDEFINED); |
| 820 | SCM_ALLOW_INTS; |
| 821 | return answer; |
| 822 | } |
| 823 | #undef FUNC_NAME |
| 824 | |
| 825 | |
| 826 | static void |
| 827 | gc_start_stats (const char *what) |
| 828 | { |
| 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; |
| 838 | } |
| 839 | |
| 840 | |
| 841 | static void |
| 842 | gc_end_stats () |
| 843 | { |
| 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); |
| 847 | ++scm_gc_times; |
| 848 | |
| 849 | scm_gc_cells_marked_acc += scm_gc_cells_swept - scm_gc_cells_collected; |
| 850 | scm_gc_cells_swept_acc += scm_gc_cells_swept; |
| 851 | } |
| 852 | |
| 853 | |
| 854 | SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0, |
| 855 | (SCM obj), |
| 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 |
| 859 | { |
| 860 | return scm_ulong2num ((unsigned long) SCM_UNPACK (obj)); |
| 861 | } |
| 862 | #undef FUNC_NAME |
| 863 | |
| 864 | |
| 865 | SCM_DEFINE (scm_gc, "gc", 0, 0, 0, |
| 866 | (), |
| 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 |
| 870 | { |
| 871 | SCM_DEFER_INTS; |
| 872 | scm_igc ("call"); |
| 873 | SCM_ALLOW_INTS; |
| 874 | return SCM_UNSPECIFIED; |
| 875 | } |
| 876 | #undef FUNC_NAME |
| 877 | |
| 878 | |
| 879 | \f |
| 880 | /* {C Interface For When GC is Triggered} |
| 881 | */ |
| 882 | |
| 883 | static void |
| 884 | adjust_min_yield (scm_freelist_t *freelist) |
| 885 | { |
| 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). |
| 891 | * |
| 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. |
| 896 | * |
| 897 | * (We might consider computing a better prediction, for example |
| 898 | * by computing an average over multiple GC:s.) |
| 899 | */ |
| 900 | if (freelist->min_yield_fraction) |
| 901 | { |
| 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)); |
| 905 | #ifdef DEBUGINFO |
| 906 | fprintf (stderr, " after GC = %lu, delta = %ld\n", |
| 907 | (long) scm_cells_allocated, |
| 908 | (long) delta); |
| 909 | #endif |
| 910 | if (delta > 0) |
| 911 | freelist->min_yield += delta; |
| 912 | } |
| 913 | } |
| 914 | |
| 915 | |
| 916 | /* When we get POSIX threads support, the master will be global and |
| 917 | * common while the freelist will be individual for each thread. |
| 918 | */ |
| 919 | |
| 920 | SCM |
| 921 | scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) |
| 922 | { |
| 923 | SCM cell; |
| 924 | ++scm_ints_disabled; |
| 925 | do |
| 926 | { |
| 927 | if (SCM_NULLP (master->clusters)) |
| 928 | { |
| 929 | if (master->grow_heap_p || scm_block_gc) |
| 930 | { |
| 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. |
| 934 | */ |
| 935 | master->grow_heap_p = 0; |
| 936 | alloc_some_heap (master, return_on_error); |
| 937 | } |
| 938 | if (SCM_NULLP (master->clusters)) |
| 939 | { |
| 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. |
| 943 | */ |
| 944 | #ifdef DEBUGINFO |
| 945 | fprintf (stderr, "allocated = %lu, ", |
| 946 | (long) (scm_cells_allocated |
| 947 | + master_cells_allocated (&scm_master_freelist) |
| 948 | + master_cells_allocated (&scm_master_freelist2))); |
| 949 | #endif |
| 950 | scm_igc ("cells"); |
| 951 | adjust_min_yield (master); |
| 952 | if (SCM_NULLP (master->clusters)) |
| 953 | { |
| 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. |
| 957 | */ |
| 958 | alloc_some_heap (master, abort_on_error); |
| 959 | } |
| 960 | } |
| 961 | } |
| 962 | cell = SCM_CAR (master->clusters); |
| 963 | master->clusters = SCM_CDR (master->clusters); |
| 964 | ++master->clusters_allocated; |
| 965 | } |
| 966 | while (SCM_NULLP (cell)); |
| 967 | |
| 968 | #ifdef GUILE_DEBUG_FREELIST |
| 969 | scm_check_freelist (cell); |
| 970 | #endif |
| 971 | |
| 972 | --scm_ints_disabled; |
| 973 | *freelist = SCM_FREE_CELL_CDR (cell); |
| 974 | return cell; |
| 975 | } |
| 976 | |
| 977 | |
| 978 | #if 0 |
| 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. |
| 982 | */ |
| 983 | |
| 984 | void |
| 985 | scm_alloc_cluster (scm_freelist_t *master) |
| 986 | { |
| 987 | SCM freelist, cell; |
| 988 | cell = scm_gc_for_newcell (master, &freelist); |
| 989 | SCM_SETCDR (cell, freelist); |
| 990 | return cell; |
| 991 | } |
| 992 | #endif |
| 993 | |
| 994 | |
| 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; |
| 1000 | |
| 1001 | |
| 1002 | void |
| 1003 | scm_igc (const char *what) |
| 1004 | { |
| 1005 | long j; |
| 1006 | |
| 1007 | ++scm_gc_running_p; |
| 1008 | scm_c_hook_run (&scm_before_gc_c_hook, 0); |
| 1009 | #ifdef DEBUGINFO |
| 1010 | fprintf (stderr, |
| 1011 | SCM_NULLP (scm_freelist) |
| 1012 | ? "*" |
| 1013 | : (SCM_NULLP (scm_freelist2) ? "o" : "m")); |
| 1014 | #endif |
| 1015 | /* During the critical section, only the current thread may run. */ |
| 1016 | SCM_CRITICAL_SECTION_START; |
| 1017 | |
| 1018 | /* fprintf (stderr, "gc: %s\n", what); */ |
| 1019 | |
| 1020 | if (!scm_stack_base || scm_block_gc) |
| 1021 | { |
| 1022 | --scm_gc_running_p; |
| 1023 | return; |
| 1024 | } |
| 1025 | |
| 1026 | gc_start_stats (what); |
| 1027 | |
| 1028 | if (scm_gc_heap_lock) |
| 1029 | /* We've invoked the collector while a GC is already in progress. |
| 1030 | That should never happen. */ |
| 1031 | abort (); |
| 1032 | |
| 1033 | ++scm_gc_heap_lock; |
| 1034 | |
| 1035 | /* flush dead entries from the continuation stack */ |
| 1036 | { |
| 1037 | long x; |
| 1038 | long bound; |
| 1039 | SCM * elts; |
| 1040 | elts = SCM_VELTS (scm_continuation_stack); |
| 1041 | bound = SCM_VECTOR_LENGTH (scm_continuation_stack); |
| 1042 | x = SCM_INUM (scm_continuation_stack_ptr); |
| 1043 | while (x < bound) |
| 1044 | { |
| 1045 | elts[x] = SCM_BOOL_F; |
| 1046 | ++x; |
| 1047 | } |
| 1048 | } |
| 1049 | |
| 1050 | scm_c_hook_run (&scm_before_mark_c_hook, 0); |
| 1051 | |
| 1052 | clear_mark_space (); |
| 1053 | |
| 1054 | #ifndef USE_THREADS |
| 1055 | |
| 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))); |
| 1064 | |
| 1065 | { |
| 1066 | size_t stack_len = scm_stack_size (scm_stack_base); |
| 1067 | #ifdef SCM_STACK_GROWS_UP |
| 1068 | scm_mark_locations (scm_stack_base, stack_len); |
| 1069 | #else |
| 1070 | scm_mark_locations (scm_stack_base - stack_len, stack_len); |
| 1071 | #endif |
| 1072 | } |
| 1073 | |
| 1074 | #else /* USE_THREADS */ |
| 1075 | |
| 1076 | /* Mark every thread's stack and registers */ |
| 1077 | scm_threads_mark_stacks (); |
| 1078 | |
| 1079 | #endif /* USE_THREADS */ |
| 1080 | |
| 1081 | j = SCM_NUM_PROTECTS; |
| 1082 | while (j--) |
| 1083 | scm_gc_mark (scm_sys_protects[j]); |
| 1084 | |
| 1085 | /* FIXME: we should have a means to register C functions to be run |
| 1086 | * in different phases of GC |
| 1087 | */ |
| 1088 | scm_mark_subr_table (); |
| 1089 | |
| 1090 | #ifndef USE_THREADS |
| 1091 | scm_gc_mark (scm_root->handle); |
| 1092 | #endif |
| 1093 | |
| 1094 | t_before_sweep = scm_c_get_internal_run_time (); |
| 1095 | scm_gc_mark_time_taken += (t_before_sweep - t_before_gc); |
| 1096 | |
| 1097 | scm_c_hook_run (&scm_before_sweep_c_hook, 0); |
| 1098 | |
| 1099 | scm_gc_sweep (); |
| 1100 | |
| 1101 | scm_c_hook_run (&scm_after_sweep_c_hook, 0); |
| 1102 | |
| 1103 | --scm_gc_heap_lock; |
| 1104 | gc_end_stats (); |
| 1105 | |
| 1106 | SCM_CRITICAL_SECTION_END; |
| 1107 | scm_c_hook_run (&scm_after_gc_c_hook, 0); |
| 1108 | --scm_gc_running_p; |
| 1109 | } |
| 1110 | |
| 1111 | \f |
| 1112 | |
| 1113 | /* {Mark/Sweep} |
| 1114 | */ |
| 1115 | |
| 1116 | #define MARK scm_gc_mark |
| 1117 | #define FNAME "scm_gc_mark" |
| 1118 | |
| 1119 | #endif /*!MARK_DEPENDENCIES*/ |
| 1120 | |
| 1121 | /* Mark an object precisely. |
| 1122 | */ |
| 1123 | void |
| 1124 | MARK (SCM p) |
| 1125 | #define FUNC_NAME FNAME |
| 1126 | { |
| 1127 | register long i; |
| 1128 | register SCM ptr; |
| 1129 | scm_bits_t cell_type; |
| 1130 | |
| 1131 | #ifndef MARK_DEPENDENCIES |
| 1132 | # define RECURSE scm_gc_mark |
| 1133 | #else |
| 1134 | /* go through the usual marking, but not for self-cycles. */ |
| 1135 | # define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0) |
| 1136 | #endif |
| 1137 | ptr = p; |
| 1138 | |
| 1139 | #ifdef MARK_DEPENDENCIES |
| 1140 | goto gc_mark_loop_first_time; |
| 1141 | #endif |
| 1142 | |
| 1143 | /* A simple hack for debugging. Chose the second branch to get a |
| 1144 | meaningful backtrace for crashes inside the GC. |
| 1145 | */ |
| 1146 | #if 1 |
| 1147 | #define goto_gc_mark_loop goto gc_mark_loop |
| 1148 | #define goto_gc_mark_nimp goto gc_mark_nimp |
| 1149 | #else |
| 1150 | #define goto_gc_mark_loop RECURSE(ptr); return |
| 1151 | #define goto_gc_mark_nimp RECURSE(ptr); return |
| 1152 | #endif |
| 1153 | |
| 1154 | gc_mark_loop: |
| 1155 | if (SCM_IMP (ptr)) |
| 1156 | return; |
| 1157 | |
| 1158 | gc_mark_nimp: |
| 1159 | |
| 1160 | #ifdef MARK_DEPENDENCIES |
| 1161 | if (SCM_EQ_P (ptr, p)) |
| 1162 | return; |
| 1163 | |
| 1164 | scm_gc_mark (ptr); |
| 1165 | return; |
| 1166 | |
| 1167 | gc_mark_loop_first_time: |
| 1168 | #endif |
| 1169 | |
| 1170 | #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) |
| 1171 | /* We are in debug mode. Check the ptr exhaustively. */ |
| 1172 | if (!scm_cellp (ptr)) |
| 1173 | SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); |
| 1174 | #else |
| 1175 | /* In non-debug mode, do at least some cheap testing. */ |
| 1176 | if (!SCM_CELLP (ptr)) |
| 1177 | SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); |
| 1178 | #endif |
| 1179 | |
| 1180 | #ifndef MARK_DEPENDENCIES |
| 1181 | |
| 1182 | if (SCM_GCMARKP (ptr)) |
| 1183 | return; |
| 1184 | |
| 1185 | SCM_SETGCMARK (ptr); |
| 1186 | |
| 1187 | #endif |
| 1188 | |
| 1189 | cell_type = SCM_GC_CELL_TYPE (ptr); |
| 1190 | switch (SCM_ITAG7 (cell_type)) |
| 1191 | { |
| 1192 | case scm_tcs_cons_nimcar: |
| 1193 | if (SCM_IMP (SCM_CDR (ptr))) |
| 1194 | { |
| 1195 | ptr = SCM_CAR (ptr); |
| 1196 | goto_gc_mark_nimp; |
| 1197 | } |
| 1198 | RECURSE (SCM_CAR (ptr)); |
| 1199 | ptr = SCM_CDR (ptr); |
| 1200 | goto_gc_mark_nimp; |
| 1201 | case scm_tcs_cons_imcar: |
| 1202 | ptr = SCM_CDR (ptr); |
| 1203 | goto_gc_mark_loop; |
| 1204 | case scm_tc7_pws: |
| 1205 | RECURSE (SCM_SETTER (ptr)); |
| 1206 | ptr = SCM_PROCEDURE (ptr); |
| 1207 | goto_gc_mark_loop; |
| 1208 | case scm_tcs_cons_gloc: |
| 1209 | { |
| 1210 | /* Dirk:FIXME:: The following code is super ugly: ptr may be a |
| 1211 | * struct or a gloc. If it is a gloc, the cell word #0 of ptr |
| 1212 | * is the address of a scm_tc16_variable smob. If it is a |
| 1213 | * struct, the cell word #0 of ptr is a pointer to a struct |
| 1214 | * vtable data region. (The fact that these are accessed in |
| 1215 | * the same way restricts the possibilites to change the data |
| 1216 | * layout of structs or heap cells.) To discriminate between |
| 1217 | * the two, it is guaranteed that the scm_vtable_index_vcell |
| 1218 | * element of the prospective vtable is always zero. For a |
| 1219 | * gloc, this location has the CDR of the variable smob, which |
| 1220 | * is guaranteed to be non-zero. |
| 1221 | */ |
| 1222 | scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; |
| 1223 | scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ |
| 1224 | if (vtable_data [scm_vtable_index_vcell] != 0) |
| 1225 | { |
| 1226 | /* ptr is a gloc */ |
| 1227 | SCM gloc_car = SCM_PACK (word0); |
| 1228 | RECURSE (gloc_car); |
| 1229 | ptr = SCM_CDR (ptr); |
| 1230 | goto gc_mark_loop; |
| 1231 | } |
| 1232 | else |
| 1233 | { |
| 1234 | /* ptr is a struct */ |
| 1235 | SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); |
| 1236 | long len = SCM_SYMBOL_LENGTH (layout); |
| 1237 | char * fields_desc = SCM_SYMBOL_CHARS (layout); |
| 1238 | scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); |
| 1239 | |
| 1240 | if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) |
| 1241 | { |
| 1242 | RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); |
| 1243 | RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); |
| 1244 | } |
| 1245 | if (len) |
| 1246 | { |
| 1247 | long x; |
| 1248 | |
| 1249 | for (x = 0; x < len - 2; x += 2, ++struct_data) |
| 1250 | if (fields_desc[x] == 'p') |
| 1251 | RECURSE (SCM_PACK (*struct_data)); |
| 1252 | if (fields_desc[x] == 'p') |
| 1253 | { |
| 1254 | if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) |
| 1255 | for (x = *struct_data++; x; --x, ++struct_data) |
| 1256 | RECURSE (SCM_PACK (*struct_data)); |
| 1257 | else |
| 1258 | RECURSE (SCM_PACK (*struct_data)); |
| 1259 | } |
| 1260 | } |
| 1261 | /* mark vtable */ |
| 1262 | ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); |
| 1263 | goto_gc_mark_loop; |
| 1264 | } |
| 1265 | } |
| 1266 | break; |
| 1267 | case scm_tcs_closures: |
| 1268 | if (SCM_IMP (SCM_ENV (ptr))) |
| 1269 | { |
| 1270 | ptr = SCM_CLOSCAR (ptr); |
| 1271 | goto_gc_mark_nimp; |
| 1272 | } |
| 1273 | RECURSE (SCM_CLOSCAR (ptr)); |
| 1274 | ptr = SCM_ENV (ptr); |
| 1275 | goto_gc_mark_nimp; |
| 1276 | case scm_tc7_vector: |
| 1277 | i = SCM_VECTOR_LENGTH (ptr); |
| 1278 | if (i == 0) |
| 1279 | break; |
| 1280 | while (--i > 0) |
| 1281 | if (SCM_NIMP (SCM_VELTS (ptr)[i])) |
| 1282 | RECURSE (SCM_VELTS (ptr)[i]); |
| 1283 | ptr = SCM_VELTS (ptr)[0]; |
| 1284 | goto_gc_mark_loop; |
| 1285 | #ifdef CCLO |
| 1286 | case scm_tc7_cclo: |
| 1287 | { |
| 1288 | size_t i = SCM_CCLO_LENGTH (ptr); |
| 1289 | size_t j; |
| 1290 | for (j = 1; j != i; ++j) |
| 1291 | { |
| 1292 | SCM obj = SCM_CCLO_REF (ptr, j); |
| 1293 | if (!SCM_IMP (obj)) |
| 1294 | RECURSE (obj); |
| 1295 | } |
| 1296 | ptr = SCM_CCLO_REF (ptr, 0); |
| 1297 | goto_gc_mark_loop; |
| 1298 | } |
| 1299 | #endif |
| 1300 | #ifdef HAVE_ARRAYS |
| 1301 | case scm_tc7_bvect: |
| 1302 | case scm_tc7_byvect: |
| 1303 | case scm_tc7_ivect: |
| 1304 | case scm_tc7_uvect: |
| 1305 | case scm_tc7_fvect: |
| 1306 | case scm_tc7_dvect: |
| 1307 | case scm_tc7_cvect: |
| 1308 | case scm_tc7_svect: |
| 1309 | #ifdef HAVE_LONG_LONGS |
| 1310 | case scm_tc7_llvect: |
| 1311 | #endif |
| 1312 | #endif |
| 1313 | case scm_tc7_string: |
| 1314 | break; |
| 1315 | |
| 1316 | case scm_tc7_substring: |
| 1317 | ptr = SCM_CDR (ptr); |
| 1318 | goto_gc_mark_loop; |
| 1319 | |
| 1320 | case scm_tc7_wvect: |
| 1321 | SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; |
| 1322 | scm_weak_vectors = ptr; |
| 1323 | if (SCM_IS_WHVEC_ANY (ptr)) |
| 1324 | { |
| 1325 | long x; |
| 1326 | long len; |
| 1327 | int weak_keys; |
| 1328 | int weak_values; |
| 1329 | |
| 1330 | len = SCM_VECTOR_LENGTH (ptr); |
| 1331 | weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); |
| 1332 | weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); |
| 1333 | |
| 1334 | for (x = 0; x < len; ++x) |
| 1335 | { |
| 1336 | SCM alist; |
| 1337 | alist = SCM_VELTS (ptr)[x]; |
| 1338 | |
| 1339 | /* mark everything on the alist except the keys or |
| 1340 | * values, according to weak_values and weak_keys. */ |
| 1341 | while ( SCM_CONSP (alist) |
| 1342 | && !SCM_GCMARKP (alist) |
| 1343 | && SCM_CONSP (SCM_CAR (alist))) |
| 1344 | { |
| 1345 | SCM kvpair; |
| 1346 | SCM next_alist; |
| 1347 | |
| 1348 | kvpair = SCM_CAR (alist); |
| 1349 | next_alist = SCM_CDR (alist); |
| 1350 | /* |
| 1351 | * Do not do this: |
| 1352 | * SCM_SETGCMARK (alist); |
| 1353 | * SCM_SETGCMARK (kvpair); |
| 1354 | * |
| 1355 | * It may be that either the key or value is protected by |
| 1356 | * an escaped reference to part of the spine of this alist. |
| 1357 | * If we mark the spine here, and only mark one or neither of the |
| 1358 | * key and value, they may never be properly marked. |
| 1359 | * This leads to a horrible situation in which an alist containing |
| 1360 | * freelist cells is exported. |
| 1361 | * |
| 1362 | * So only mark the spines of these arrays last of all marking. |
| 1363 | * If somebody confuses us by constructing a weak vector |
| 1364 | * with a circular alist then we are hosed, but at least we |
| 1365 | * won't prematurely drop table entries. |
| 1366 | */ |
| 1367 | if (!weak_keys) |
| 1368 | RECURSE (SCM_CAR (kvpair)); |
| 1369 | if (!weak_values) |
| 1370 | RECURSE (SCM_CDR (kvpair)); |
| 1371 | alist = next_alist; |
| 1372 | } |
| 1373 | if (SCM_NIMP (alist)) |
| 1374 | RECURSE (alist); |
| 1375 | } |
| 1376 | } |
| 1377 | break; |
| 1378 | |
| 1379 | case scm_tc7_symbol: |
| 1380 | ptr = SCM_PROP_SLOTS (ptr); |
| 1381 | goto_gc_mark_loop; |
| 1382 | case scm_tcs_subrs: |
| 1383 | break; |
| 1384 | case scm_tc7_port: |
| 1385 | i = SCM_PTOBNUM (ptr); |
| 1386 | #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) |
| 1387 | if (!(i < scm_numptob)) |
| 1388 | SCM_MISC_ERROR ("undefined port type", SCM_EOL); |
| 1389 | #endif |
| 1390 | if (SCM_PTAB_ENTRY(ptr)) |
| 1391 | RECURSE (SCM_FILENAME (ptr)); |
| 1392 | if (scm_ptobs[i].mark) |
| 1393 | { |
| 1394 | ptr = (scm_ptobs[i].mark) (ptr); |
| 1395 | goto_gc_mark_loop; |
| 1396 | } |
| 1397 | else |
| 1398 | return; |
| 1399 | break; |
| 1400 | case scm_tc7_smob: |
| 1401 | switch (SCM_TYP16 (ptr)) |
| 1402 | { /* should be faster than going through scm_smobs */ |
| 1403 | case scm_tc_free_cell: |
| 1404 | /* printf("found free_cell %X ", ptr); fflush(stdout); */ |
| 1405 | case scm_tc16_big: |
| 1406 | case scm_tc16_real: |
| 1407 | case scm_tc16_complex: |
| 1408 | break; |
| 1409 | default: |
| 1410 | i = SCM_SMOBNUM (ptr); |
| 1411 | #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) |
| 1412 | if (!(i < scm_numsmob)) |
| 1413 | SCM_MISC_ERROR ("undefined smob type", SCM_EOL); |
| 1414 | #endif |
| 1415 | if (scm_smobs[i].mark) |
| 1416 | { |
| 1417 | ptr = (scm_smobs[i].mark) (ptr); |
| 1418 | goto_gc_mark_loop; |
| 1419 | } |
| 1420 | else |
| 1421 | return; |
| 1422 | } |
| 1423 | break; |
| 1424 | default: |
| 1425 | SCM_MISC_ERROR ("unknown type", SCM_EOL); |
| 1426 | } |
| 1427 | #undef RECURSE |
| 1428 | } |
| 1429 | #undef FUNC_NAME |
| 1430 | |
| 1431 | #ifndef MARK_DEPENDENCIES |
| 1432 | |
| 1433 | #undef MARK |
| 1434 | #undef FNAME |
| 1435 | |
| 1436 | /* And here we define `scm_gc_mark_dependencies', by including this |
| 1437 | * same file in itself. |
| 1438 | */ |
| 1439 | #define MARK scm_gc_mark_dependencies |
| 1440 | #define FNAME "scm_gc_mark_dependencies" |
| 1441 | #define MARK_DEPENDENCIES |
| 1442 | #include "gc.c" |
| 1443 | #undef MARK_DEPENDENCIES |
| 1444 | #undef MARK |
| 1445 | #undef FNAME |
| 1446 | |
| 1447 | |
| 1448 | /* Mark a Region Conservatively |
| 1449 | */ |
| 1450 | |
| 1451 | void |
| 1452 | scm_mark_locations (SCM_STACKITEM x[], unsigned long n) |
| 1453 | { |
| 1454 | unsigned long m; |
| 1455 | |
| 1456 | for (m = 0; m < n; ++m) |
| 1457 | { |
| 1458 | SCM obj = * (SCM *) &x[m]; |
| 1459 | if (SCM_CELLP (obj)) |
| 1460 | { |
| 1461 | SCM_CELLPTR ptr = SCM2PTR (obj); |
| 1462 | long i = 0; |
| 1463 | long j = scm_n_heap_segs - 1; |
| 1464 | if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) |
| 1465 | && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) |
| 1466 | { |
| 1467 | while (i <= j) |
| 1468 | { |
| 1469 | long seg_id; |
| 1470 | seg_id = -1; |
| 1471 | if ((i == j) |
| 1472 | || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) |
| 1473 | seg_id = i; |
| 1474 | else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) |
| 1475 | seg_id = j; |
| 1476 | else |
| 1477 | { |
| 1478 | long k; |
| 1479 | k = (i + j) / 2; |
| 1480 | if (k == i) |
| 1481 | break; |
| 1482 | if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) |
| 1483 | { |
| 1484 | j = k; |
| 1485 | ++i; |
| 1486 | if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) |
| 1487 | continue; |
| 1488 | else |
| 1489 | break; |
| 1490 | } |
| 1491 | else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) |
| 1492 | { |
| 1493 | i = k; |
| 1494 | --j; |
| 1495 | if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) |
| 1496 | continue; |
| 1497 | else |
| 1498 | break; |
| 1499 | } |
| 1500 | } |
| 1501 | |
| 1502 | if (SCM_GC_IN_CARD_HEADERP (ptr)) |
| 1503 | break; |
| 1504 | |
| 1505 | if (scm_heap_table[seg_id].span == 1 |
| 1506 | || DOUBLECELL_ALIGNED_P (obj)) |
| 1507 | scm_gc_mark (obj); |
| 1508 | |
| 1509 | break; |
| 1510 | } |
| 1511 | } |
| 1512 | } |
| 1513 | } |
| 1514 | } |
| 1515 | |
| 1516 | |
| 1517 | /* The function scm_cellp determines whether an SCM value can be regarded as a |
| 1518 | * pointer to a cell on the heap. Binary search is used in order to determine |
| 1519 | * the heap segment that contains the cell. |
| 1520 | */ |
| 1521 | int |
| 1522 | scm_cellp (SCM value) |
| 1523 | { |
| 1524 | if (SCM_CELLP (value)) { |
| 1525 | scm_cell * ptr = SCM2PTR (value); |
| 1526 | unsigned long i = 0; |
| 1527 | unsigned long j = scm_n_heap_segs - 1; |
| 1528 | |
| 1529 | if (SCM_GC_IN_CARD_HEADERP (ptr)) |
| 1530 | return 0; |
| 1531 | |
| 1532 | while (i < j) { |
| 1533 | long k = (i + j) / 2; |
| 1534 | if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { |
| 1535 | j = k; |
| 1536 | } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) { |
| 1537 | i = k + 1; |
| 1538 | } |
| 1539 | } |
| 1540 | |
| 1541 | if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) |
| 1542 | && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr) |
| 1543 | && (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value)) |
| 1544 | && !SCM_GC_IN_CARD_HEADERP (ptr) |
| 1545 | ) |
| 1546 | return 1; |
| 1547 | else |
| 1548 | return 0; |
| 1549 | } else |
| 1550 | return 0; |
| 1551 | } |
| 1552 | |
| 1553 | |
| 1554 | static void |
| 1555 | gc_sweep_freelist_start (scm_freelist_t *freelist) |
| 1556 | { |
| 1557 | freelist->cells = SCM_EOL; |
| 1558 | freelist->left_to_collect = freelist->cluster_size; |
| 1559 | freelist->clusters_allocated = 0; |
| 1560 | freelist->clusters = SCM_EOL; |
| 1561 | freelist->clustertail = &freelist->clusters; |
| 1562 | freelist->collected_1 = freelist->collected; |
| 1563 | freelist->collected = 0; |
| 1564 | } |
| 1565 | |
| 1566 | static void |
| 1567 | gc_sweep_freelist_finish (scm_freelist_t *freelist) |
| 1568 | { |
| 1569 | long collected; |
| 1570 | *freelist->clustertail = freelist->cells; |
| 1571 | if (!SCM_NULLP (freelist->cells)) |
| 1572 | { |
| 1573 | SCM c = freelist->cells; |
| 1574 | SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c)); |
| 1575 | SCM_SET_CELL_WORD_1 (c, SCM_EOL); |
| 1576 | freelist->collected += |
| 1577 | freelist->span * (freelist->cluster_size - freelist->left_to_collect); |
| 1578 | } |
| 1579 | scm_gc_cells_collected += freelist->collected; |
| 1580 | |
| 1581 | /* Although freelist->min_yield is used to test freelist->collected |
| 1582 | * (which is the local GC yield for freelist), it is adjusted so |
| 1583 | * that *total* yield is freelist->min_yield_fraction of total heap |
| 1584 | * size. This means that a too low yield is compensated by more |
| 1585 | * heap on the list which is currently doing most work, which is |
| 1586 | * just what we want. |
| 1587 | */ |
| 1588 | collected = SCM_MAX (freelist->collected_1, freelist->collected); |
| 1589 | freelist->grow_heap_p = (collected < freelist->min_yield); |
| 1590 | } |
| 1591 | |
| 1592 | #define NEXT_DATA_CELL(ptr, span) \ |
| 1593 | do { \ |
| 1594 | scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ |
| 1595 | (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \ |
| 1596 | CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \ |
| 1597 | : nxt__); \ |
| 1598 | } while (0) |
| 1599 | |
| 1600 | void |
| 1601 | scm_gc_sweep () |
| 1602 | #define FUNC_NAME "scm_gc_sweep" |
| 1603 | { |
| 1604 | register SCM_CELLPTR ptr; |
| 1605 | register SCM nfreelist; |
| 1606 | register scm_freelist_t *freelist; |
| 1607 | register unsigned long m; |
| 1608 | register int span; |
| 1609 | long i; |
| 1610 | size_t seg_size; |
| 1611 | |
| 1612 | m = 0; |
| 1613 | |
| 1614 | gc_sweep_freelist_start (&scm_master_freelist); |
| 1615 | gc_sweep_freelist_start (&scm_master_freelist2); |
| 1616 | |
| 1617 | for (i = 0; i < scm_n_heap_segs; i++) |
| 1618 | { |
| 1619 | register long left_to_collect; |
| 1620 | register size_t j; |
| 1621 | |
| 1622 | /* Unmarked cells go onto the front of the freelist this heap |
| 1623 | segment points to. Rather than updating the real freelist |
| 1624 | pointer as we go along, we accumulate the new head in |
| 1625 | nfreelist. Then, if it turns out that the entire segment is |
| 1626 | free, we free (i.e., malloc's free) the whole segment, and |
| 1627 | simply don't assign nfreelist back into the real freelist. */ |
| 1628 | freelist = scm_heap_table[i].freelist; |
| 1629 | nfreelist = freelist->cells; |
| 1630 | left_to_collect = freelist->left_to_collect; |
| 1631 | span = scm_heap_table[i].span; |
| 1632 | |
| 1633 | ptr = CELL_UP (scm_heap_table[i].bounds[0], span); |
| 1634 | seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr; |
| 1635 | |
| 1636 | /* use only data cells in seg_size */ |
| 1637 | seg_size = (seg_size / SCM_GC_CARD_N_CELLS) * (SCM_GC_CARD_N_DATA_CELLS / span) * span; |
| 1638 | |
| 1639 | scm_gc_cells_swept += seg_size; |
| 1640 | |
| 1641 | for (j = seg_size + span; j -= span; ptr += span) |
| 1642 | { |
| 1643 | SCM scmptr; |
| 1644 | |
| 1645 | if (SCM_GC_IN_CARD_HEADERP (ptr)) |
| 1646 | { |
| 1647 | SCM_CELLPTR nxt; |
| 1648 | |
| 1649 | /* cheat here */ |
| 1650 | nxt = ptr; |
| 1651 | NEXT_DATA_CELL (nxt, span); |
| 1652 | j += span; |
| 1653 | |
| 1654 | ptr = nxt - span; |
| 1655 | continue; |
| 1656 | } |
| 1657 | |
| 1658 | scmptr = PTR2SCM (ptr); |
| 1659 | |
| 1660 | if (SCM_GCMARKP (scmptr)) |
| 1661 | continue; |
| 1662 | |
| 1663 | switch SCM_TYP7 (scmptr) |
| 1664 | { |
| 1665 | case scm_tcs_cons_gloc: |
| 1666 | { |
| 1667 | /* Dirk:FIXME:: Again, super ugly code: scmptr may be a |
| 1668 | * struct or a gloc. See the corresponding comment in |
| 1669 | * scm_gc_mark. |
| 1670 | */ |
| 1671 | scm_bits_t word0 = (SCM_CELL_WORD_0 (scmptr) |
| 1672 | - scm_tc3_cons_gloc); |
| 1673 | /* access as struct */ |
| 1674 | scm_bits_t * vtable_data = (scm_bits_t *) word0; |
| 1675 | if (vtable_data[scm_vtable_index_vcell] == 0) |
| 1676 | { |
| 1677 | /* Structs need to be freed in a special order. |
| 1678 | * This is handled by GC C hooks in struct.c. |
| 1679 | */ |
| 1680 | SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); |
| 1681 | scm_structs_to_free = scmptr; |
| 1682 | continue; |
| 1683 | } |
| 1684 | /* fall through so that scmptr gets collected */ |
| 1685 | } |
| 1686 | break; |
| 1687 | case scm_tcs_cons_imcar: |
| 1688 | case scm_tcs_cons_nimcar: |
| 1689 | case scm_tcs_closures: |
| 1690 | case scm_tc7_pws: |
| 1691 | break; |
| 1692 | case scm_tc7_wvect: |
| 1693 | m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM); |
| 1694 | scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); |
| 1695 | break; |
| 1696 | case scm_tc7_vector: |
| 1697 | { |
| 1698 | unsigned long int length = SCM_VECTOR_LENGTH (scmptr); |
| 1699 | if (length > 0) |
| 1700 | { |
| 1701 | m += length * sizeof (scm_bits_t); |
| 1702 | scm_must_free (SCM_VECTOR_BASE (scmptr)); |
| 1703 | } |
| 1704 | break; |
| 1705 | } |
| 1706 | #ifdef CCLO |
| 1707 | case scm_tc7_cclo: |
| 1708 | m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); |
| 1709 | scm_must_free (SCM_CCLO_BASE (scmptr)); |
| 1710 | break; |
| 1711 | #endif |
| 1712 | #ifdef HAVE_ARRAYS |
| 1713 | case scm_tc7_bvect: |
| 1714 | { |
| 1715 | unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); |
| 1716 | if (length > 0) |
| 1717 | { |
| 1718 | m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); |
| 1719 | scm_must_free (SCM_BITVECTOR_BASE (scmptr)); |
| 1720 | } |
| 1721 | } |
| 1722 | break; |
| 1723 | case scm_tc7_byvect: |
| 1724 | case scm_tc7_ivect: |
| 1725 | case scm_tc7_uvect: |
| 1726 | case scm_tc7_svect: |
| 1727 | #ifdef HAVE_LONG_LONGS |
| 1728 | case scm_tc7_llvect: |
| 1729 | #endif |
| 1730 | case scm_tc7_fvect: |
| 1731 | case scm_tc7_dvect: |
| 1732 | case scm_tc7_cvect: |
| 1733 | m += SCM_UVECTOR_LENGTH (scmptr) * scm_uniform_element_size (scmptr); |
| 1734 | scm_must_free (SCM_UVECTOR_BASE (scmptr)); |
| 1735 | break; |
| 1736 | #endif |
| 1737 | case scm_tc7_substring: |
| 1738 | break; |
| 1739 | case scm_tc7_string: |
| 1740 | m += SCM_STRING_LENGTH (scmptr) + 1; |
| 1741 | scm_must_free (SCM_STRING_CHARS (scmptr)); |
| 1742 | break; |
| 1743 | case scm_tc7_symbol: |
| 1744 | m += SCM_SYMBOL_LENGTH (scmptr) + 1; |
| 1745 | scm_must_free (SCM_SYMBOL_CHARS (scmptr)); |
| 1746 | break; |
| 1747 | case scm_tcs_subrs: |
| 1748 | /* the various "subrs" (primitives) are never freed */ |
| 1749 | continue; |
| 1750 | case scm_tc7_port: |
| 1751 | if SCM_OPENP (scmptr) |
| 1752 | { |
| 1753 | int k = SCM_PTOBNUM (scmptr); |
| 1754 | #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) |
| 1755 | if (!(k < scm_numptob)) |
| 1756 | SCM_MISC_ERROR ("undefined port type", SCM_EOL); |
| 1757 | #endif |
| 1758 | /* Keep "revealed" ports alive. */ |
| 1759 | if (scm_revealed_count (scmptr) > 0) |
| 1760 | continue; |
| 1761 | /* Yes, I really do mean scm_ptobs[k].free */ |
| 1762 | /* rather than ftobs[k].close. .close */ |
| 1763 | /* is for explicit CLOSE-PORT by user */ |
| 1764 | m += (scm_ptobs[k].free) (scmptr); |
| 1765 | SCM_SETSTREAM (scmptr, 0); |
| 1766 | scm_remove_from_port_table (scmptr); |
| 1767 | scm_gc_ports_collected++; |
| 1768 | SCM_CLR_PORT_OPEN_FLAG (scmptr); |
| 1769 | } |
| 1770 | break; |
| 1771 | case scm_tc7_smob: |
| 1772 | switch SCM_TYP16 (scmptr) |
| 1773 | { |
| 1774 | case scm_tc_free_cell: |
| 1775 | case scm_tc16_real: |
| 1776 | break; |
| 1777 | #ifdef SCM_BIGDIG |
| 1778 | case scm_tc16_big: |
| 1779 | m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); |
| 1780 | scm_must_free (SCM_BDIGITS (scmptr)); |
| 1781 | break; |
| 1782 | #endif /* def SCM_BIGDIG */ |
| 1783 | case scm_tc16_complex: |
| 1784 | m += sizeof (scm_complex_t); |
| 1785 | scm_must_free (SCM_COMPLEX_MEM (scmptr)); |
| 1786 | break; |
| 1787 | default: |
| 1788 | { |
| 1789 | int k; |
| 1790 | k = SCM_SMOBNUM (scmptr); |
| 1791 | #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) |
| 1792 | if (!(k < scm_numsmob)) |
| 1793 | SCM_MISC_ERROR ("undefined smob type", SCM_EOL); |
| 1794 | #endif |
| 1795 | if (scm_smobs[k].free) |
| 1796 | m += (scm_smobs[k].free) (scmptr); |
| 1797 | break; |
| 1798 | } |
| 1799 | } |
| 1800 | break; |
| 1801 | default: |
| 1802 | SCM_MISC_ERROR ("unknown type", SCM_EOL); |
| 1803 | } |
| 1804 | |
| 1805 | if (!--left_to_collect) |
| 1806 | { |
| 1807 | SCM_SET_CELL_WORD_0 (scmptr, nfreelist); |
| 1808 | *freelist->clustertail = scmptr; |
| 1809 | freelist->clustertail = SCM_CDRLOC (scmptr); |
| 1810 | |
| 1811 | nfreelist = SCM_EOL; |
| 1812 | freelist->collected += span * freelist->cluster_size; |
| 1813 | left_to_collect = freelist->cluster_size; |
| 1814 | } |
| 1815 | else |
| 1816 | { |
| 1817 | /* Stick the new cell on the front of nfreelist. It's |
| 1818 | critical that we mark this cell as freed; otherwise, the |
| 1819 | conservative collector might trace it as some other type |
| 1820 | of object. */ |
| 1821 | SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); |
| 1822 | SCM_SET_FREE_CELL_CDR (scmptr, nfreelist); |
| 1823 | nfreelist = scmptr; |
| 1824 | } |
| 1825 | } |
| 1826 | |
| 1827 | #ifdef GC_FREE_SEGMENTS |
| 1828 | if (n == seg_size) |
| 1829 | { |
| 1830 | register long j; |
| 1831 | |
| 1832 | freelist->heap_size -= seg_size; |
| 1833 | free ((char *) scm_heap_table[i].bounds[0]); |
| 1834 | scm_heap_table[i].bounds[0] = 0; |
| 1835 | for (j = i + 1; j < scm_n_heap_segs; j++) |
| 1836 | scm_heap_table[j - 1] = scm_heap_table[j]; |
| 1837 | scm_n_heap_segs -= 1; |
| 1838 | i--; /* We need to scan the segment just moved. */ |
| 1839 | } |
| 1840 | else |
| 1841 | #endif /* ifdef GC_FREE_SEGMENTS */ |
| 1842 | { |
| 1843 | /* Update the real freelist pointer to point to the head of |
| 1844 | the list of free cells we've built for this segment. */ |
| 1845 | freelist->cells = nfreelist; |
| 1846 | freelist->left_to_collect = left_to_collect; |
| 1847 | } |
| 1848 | |
| 1849 | #ifdef GUILE_DEBUG_FREELIST |
| 1850 | scm_map_free_list (); |
| 1851 | #endif |
| 1852 | } |
| 1853 | |
| 1854 | gc_sweep_freelist_finish (&scm_master_freelist); |
| 1855 | gc_sweep_freelist_finish (&scm_master_freelist2); |
| 1856 | |
| 1857 | /* When we move to POSIX threads private freelists should probably |
| 1858 | be GC-protected instead. */ |
| 1859 | scm_freelist = SCM_EOL; |
| 1860 | scm_freelist2 = SCM_EOL; |
| 1861 | |
| 1862 | scm_cells_allocated = (SCM_HEAP_SIZE - scm_gc_cells_collected); |
| 1863 | scm_gc_yield -= scm_cells_allocated; |
| 1864 | |
| 1865 | if (scm_mallocated < m) |
| 1866 | /* The byte count of allocated objects has underflowed. This is |
| 1867 | probably because you forgot to report the sizes of objects you |
| 1868 | have allocated, by calling scm_done_malloc or some such. When |
| 1869 | the GC freed them, it subtracted their size from |
| 1870 | scm_mallocated, which underflowed. */ |
| 1871 | abort (); |
| 1872 | |
| 1873 | scm_mallocated -= m; |
| 1874 | scm_gc_malloc_collected = m; |
| 1875 | } |
| 1876 | #undef FUNC_NAME |
| 1877 | |
| 1878 | |
| 1879 | \f |
| 1880 | /* {Front end to malloc} |
| 1881 | * |
| 1882 | * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, |
| 1883 | * scm_done_free |
| 1884 | * |
| 1885 | * These functions provide services comparable to malloc, realloc, and |
| 1886 | * free. They should be used when allocating memory that will be under |
| 1887 | * control of the garbage collector, i.e., if the memory may be freed |
| 1888 | * during garbage collection. |
| 1889 | */ |
| 1890 | |
| 1891 | /* scm_must_malloc |
| 1892 | * Return newly malloced storage or throw an error. |
| 1893 | * |
| 1894 | * The parameter WHAT is a string for error reporting. |
| 1895 | * If the threshold scm_mtrigger will be passed by this |
| 1896 | * allocation, or if the first call to malloc fails, |
| 1897 | * garbage collect -- on the presumption that some objects |
| 1898 | * using malloced storage may be collected. |
| 1899 | * |
| 1900 | * The limit scm_mtrigger may be raised by this allocation. |
| 1901 | */ |
| 1902 | void * |
| 1903 | scm_must_malloc (size_t size, const char *what) |
| 1904 | { |
| 1905 | void *ptr; |
| 1906 | unsigned long nm = scm_mallocated + size; |
| 1907 | |
| 1908 | if (nm < size) |
| 1909 | /* The byte count of allocated objects has overflowed. This is |
| 1910 | probably because you forgot to report the correct size of freed |
| 1911 | memory in some of your smob free methods. */ |
| 1912 | abort (); |
| 1913 | |
| 1914 | if (nm <= scm_mtrigger) |
| 1915 | { |
| 1916 | SCM_SYSCALL (ptr = malloc (size)); |
| 1917 | if (NULL != ptr) |
| 1918 | { |
| 1919 | scm_mallocated = nm; |
| 1920 | #ifdef GUILE_DEBUG_MALLOC |
| 1921 | scm_malloc_register (ptr, what); |
| 1922 | #endif |
| 1923 | return ptr; |
| 1924 | } |
| 1925 | } |
| 1926 | |
| 1927 | scm_igc (what); |
| 1928 | |
| 1929 | nm = scm_mallocated + size; |
| 1930 | |
| 1931 | if (nm < size) |
| 1932 | /* The byte count of allocated objects has overflowed. This is |
| 1933 | probably because you forgot to report the correct size of freed |
| 1934 | memory in some of your smob free methods. */ |
| 1935 | abort (); |
| 1936 | |
| 1937 | SCM_SYSCALL (ptr = malloc (size)); |
| 1938 | if (NULL != ptr) |
| 1939 | { |
| 1940 | scm_mallocated = nm; |
| 1941 | if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { |
| 1942 | if (nm > scm_mtrigger) |
| 1943 | scm_mtrigger = nm + nm / 2; |
| 1944 | else |
| 1945 | scm_mtrigger += scm_mtrigger / 2; |
| 1946 | } |
| 1947 | #ifdef GUILE_DEBUG_MALLOC |
| 1948 | scm_malloc_register (ptr, what); |
| 1949 | #endif |
| 1950 | |
| 1951 | return ptr; |
| 1952 | } |
| 1953 | |
| 1954 | scm_memory_error (what); |
| 1955 | } |
| 1956 | |
| 1957 | |
| 1958 | /* scm_must_realloc |
| 1959 | * is similar to scm_must_malloc. |
| 1960 | */ |
| 1961 | void * |
| 1962 | scm_must_realloc (void *where, |
| 1963 | size_t old_size, |
| 1964 | size_t size, |
| 1965 | const char *what) |
| 1966 | { |
| 1967 | void *ptr; |
| 1968 | unsigned long nm; |
| 1969 | |
| 1970 | if (size <= old_size) |
| 1971 | return where; |
| 1972 | |
| 1973 | nm = scm_mallocated + size - old_size; |
| 1974 | |
| 1975 | if (nm < (size - old_size)) |
| 1976 | /* The byte count of allocated objects has overflowed. This is |
| 1977 | probably because you forgot to report the correct size of freed |
| 1978 | memory in some of your smob free methods. */ |
| 1979 | abort (); |
| 1980 | |
| 1981 | if (nm <= scm_mtrigger) |
| 1982 | { |
| 1983 | SCM_SYSCALL (ptr = realloc (where, size)); |
| 1984 | if (NULL != ptr) |
| 1985 | { |
| 1986 | scm_mallocated = nm; |
| 1987 | #ifdef GUILE_DEBUG_MALLOC |
| 1988 | scm_malloc_reregister (where, ptr, what); |
| 1989 | #endif |
| 1990 | return ptr; |
| 1991 | } |
| 1992 | } |
| 1993 | |
| 1994 | scm_igc (what); |
| 1995 | |
| 1996 | nm = scm_mallocated + size - old_size; |
| 1997 | |
| 1998 | if (nm < (size - old_size)) |
| 1999 | /* The byte count of allocated objects has overflowed. This is |
| 2000 | probably because you forgot to report the correct size of freed |
| 2001 | memory in some of your smob free methods. */ |
| 2002 | abort (); |
| 2003 | |
| 2004 | SCM_SYSCALL (ptr = realloc (where, size)); |
| 2005 | if (NULL != ptr) |
| 2006 | { |
| 2007 | scm_mallocated = nm; |
| 2008 | if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { |
| 2009 | if (nm > scm_mtrigger) |
| 2010 | scm_mtrigger = nm + nm / 2; |
| 2011 | else |
| 2012 | scm_mtrigger += scm_mtrigger / 2; |
| 2013 | } |
| 2014 | #ifdef GUILE_DEBUG_MALLOC |
| 2015 | scm_malloc_reregister (where, ptr, what); |
| 2016 | #endif |
| 2017 | return ptr; |
| 2018 | } |
| 2019 | |
| 2020 | scm_memory_error (what); |
| 2021 | } |
| 2022 | |
| 2023 | char * |
| 2024 | scm_must_strndup (const char *str, size_t length) |
| 2025 | { |
| 2026 | char * dst = scm_must_malloc (length + 1, "scm_must_strndup"); |
| 2027 | memcpy (dst, str, length); |
| 2028 | dst[length] = 0; |
| 2029 | return dst; |
| 2030 | } |
| 2031 | |
| 2032 | char * |
| 2033 | scm_must_strdup (const char *str) |
| 2034 | { |
| 2035 | return scm_must_strndup (str, strlen (str)); |
| 2036 | } |
| 2037 | |
| 2038 | void |
| 2039 | scm_must_free (void *obj) |
| 2040 | #define FUNC_NAME "scm_must_free" |
| 2041 | { |
| 2042 | #ifdef GUILE_DEBUG_MALLOC |
| 2043 | scm_malloc_unregister (obj); |
| 2044 | #endif |
| 2045 | if (obj) |
| 2046 | free (obj); |
| 2047 | else |
| 2048 | SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL); |
| 2049 | } |
| 2050 | #undef FUNC_NAME |
| 2051 | |
| 2052 | |
| 2053 | /* Announce that there has been some malloc done that will be freed |
| 2054 | * during gc. A typical use is for a smob that uses some malloced |
| 2055 | * memory but can not get it from scm_must_malloc (for whatever |
| 2056 | * reason). When a new object of this smob is created you call |
| 2057 | * scm_done_malloc with the size of the object. When your smob free |
| 2058 | * function is called, be sure to include this size in the return |
| 2059 | * value. |
| 2060 | * |
| 2061 | * If you can't actually free the memory in the smob free function, |
| 2062 | * for whatever reason (like reference counting), you still can (and |
| 2063 | * should) report the amount of memory freed when you actually free it. |
| 2064 | * Do it by calling scm_done_malloc with the _negated_ size. Clever, |
| 2065 | * eh? Or even better, call scm_done_free. */ |
| 2066 | |
| 2067 | void |
| 2068 | scm_done_malloc (long size) |
| 2069 | { |
| 2070 | if (size < 0) { |
| 2071 | if (scm_mallocated < size) |
| 2072 | /* The byte count of allocated objects has underflowed. This is |
| 2073 | probably because you forgot to report the sizes of objects you |
| 2074 | have allocated, by calling scm_done_malloc or some such. When |
| 2075 | the GC freed them, it subtracted their size from |
| 2076 | scm_mallocated, which underflowed. */ |
| 2077 | abort (); |
| 2078 | } else { |
| 2079 | unsigned long nm = scm_mallocated + size; |
| 2080 | if (nm < size) |
| 2081 | /* The byte count of allocated objects has overflowed. This is |
| 2082 | probably because you forgot to report the correct size of freed |
| 2083 | memory in some of your smob free methods. */ |
| 2084 | abort (); |
| 2085 | } |
| 2086 | |
| 2087 | scm_mallocated += size; |
| 2088 | |
| 2089 | if (scm_mallocated > scm_mtrigger) |
| 2090 | { |
| 2091 | scm_igc ("foreign mallocs"); |
| 2092 | if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) |
| 2093 | { |
| 2094 | if (scm_mallocated > scm_mtrigger) |
| 2095 | scm_mtrigger = scm_mallocated + scm_mallocated / 2; |
| 2096 | else |
| 2097 | scm_mtrigger += scm_mtrigger / 2; |
| 2098 | } |
| 2099 | } |
| 2100 | } |
| 2101 | |
| 2102 | void |
| 2103 | scm_done_free (long size) |
| 2104 | { |
| 2105 | if (size >= 0) { |
| 2106 | if (scm_mallocated < size) |
| 2107 | /* The byte count of allocated objects has underflowed. This is |
| 2108 | probably because you forgot to report the sizes of objects you |
| 2109 | have allocated, by calling scm_done_malloc or some such. When |
| 2110 | the GC freed them, it subtracted their size from |
| 2111 | scm_mallocated, which underflowed. */ |
| 2112 | abort (); |
| 2113 | } else { |
| 2114 | unsigned long nm = scm_mallocated + size; |
| 2115 | if (nm < size) |
| 2116 | /* The byte count of allocated objects has overflowed. This is |
| 2117 | probably because you forgot to report the correct size of freed |
| 2118 | memory in some of your smob free methods. */ |
| 2119 | abort (); |
| 2120 | } |
| 2121 | |
| 2122 | scm_mallocated -= size; |
| 2123 | } |
| 2124 | |
| 2125 | |
| 2126 | \f |
| 2127 | /* {Heap Segments} |
| 2128 | * |
| 2129 | * Each heap segment is an array of objects of a particular size. |
| 2130 | * Every segment has an associated (possibly shared) freelist. |
| 2131 | * A table of segment records is kept that records the upper and |
| 2132 | * lower extents of the segment; this is used during the conservative |
| 2133 | * phase of gc to identify probably gc roots (because they point |
| 2134 | * into valid segments at reasonable offsets). */ |
| 2135 | |
| 2136 | /* scm_expmem |
| 2137 | * is true if the first segment was smaller than INIT_HEAP_SEG. |
| 2138 | * If scm_expmem is set to one, subsequent segment allocations will |
| 2139 | * allocate segments of size SCM_EXPHEAP(scm_heap_size). |
| 2140 | */ |
| 2141 | int scm_expmem = 0; |
| 2142 | |
| 2143 | size_t scm_max_segment_size; |
| 2144 | |
| 2145 | /* scm_heap_org |
| 2146 | * is the lowest base address of any heap segment. |
| 2147 | */ |
| 2148 | SCM_CELLPTR scm_heap_org; |
| 2149 | |
| 2150 | scm_heap_seg_data_t * scm_heap_table = 0; |
| 2151 | static size_t heap_segment_table_size = 0; |
| 2152 | size_t scm_n_heap_segs = 0; |
| 2153 | |
| 2154 | /* init_heap_seg |
| 2155 | * initializes a new heap segment and returns the number of objects it contains. |
| 2156 | * |
| 2157 | * The segment origin and segment size in bytes are input parameters. |
| 2158 | * The freelist is both input and output. |
| 2159 | * |
| 2160 | * This function presumes that the scm_heap_table has already been expanded |
| 2161 | * to accomodate a new segment record and that the markbit space was reserved |
| 2162 | * for all the cards in this segment. |
| 2163 | */ |
| 2164 | |
| 2165 | #define INIT_CARD(card, span) \ |
| 2166 | do { \ |
| 2167 | SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \ |
| 2168 | if ((span) == 2) \ |
| 2169 | SCM_GC_SET_CARD_DOUBLECELL (card); \ |
| 2170 | } while (0) |
| 2171 | |
| 2172 | static size_t |
| 2173 | init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_freelist_t *freelist) |
| 2174 | { |
| 2175 | register SCM_CELLPTR ptr; |
| 2176 | SCM_CELLPTR seg_end; |
| 2177 | long new_seg_index; |
| 2178 | ptrdiff_t n_new_cells; |
| 2179 | int span = freelist->span; |
| 2180 | |
| 2181 | if (seg_org == NULL) |
| 2182 | return 0; |
| 2183 | |
| 2184 | /* Align the begin ptr up. |
| 2185 | */ |
| 2186 | ptr = SCM_GC_CARD_UP (seg_org); |
| 2187 | |
| 2188 | /* Compute the ceiling on valid object pointers w/in this segment. |
| 2189 | */ |
| 2190 | seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size); |
| 2191 | |
| 2192 | /* Find the right place and insert the segment record. |
| 2193 | * |
| 2194 | */ |
| 2195 | for (new_seg_index = 0; |
| 2196 | ( (new_seg_index < scm_n_heap_segs) |
| 2197 | && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)); |
| 2198 | new_seg_index++) |
| 2199 | ; |
| 2200 | |
| 2201 | { |
| 2202 | int i; |
| 2203 | for (i = scm_n_heap_segs; i > new_seg_index; --i) |
| 2204 | scm_heap_table[i] = scm_heap_table[i - 1]; |
| 2205 | } |
| 2206 | |
| 2207 | ++scm_n_heap_segs; |
| 2208 | |
| 2209 | scm_heap_table[new_seg_index].span = span; |
| 2210 | scm_heap_table[new_seg_index].freelist = freelist; |
| 2211 | scm_heap_table[new_seg_index].bounds[0] = ptr; |
| 2212 | scm_heap_table[new_seg_index].bounds[1] = seg_end; |
| 2213 | |
| 2214 | /*n_new_cells*/ |
| 2215 | n_new_cells = seg_end - ptr; |
| 2216 | |
| 2217 | freelist->heap_size += n_new_cells; |
| 2218 | |
| 2219 | /* Partition objects in this segment into clusters */ |
| 2220 | { |
| 2221 | SCM clusters; |
| 2222 | SCM *clusterp = &clusters; |
| 2223 | |
| 2224 | NEXT_DATA_CELL (ptr, span); |
| 2225 | while (ptr < seg_end) |
| 2226 | { |
| 2227 | scm_cell *nxt = ptr; |
| 2228 | scm_cell *prv = NULL; |
| 2229 | scm_cell *last_card = NULL; |
| 2230 | int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1; |
| 2231 | NEXT_DATA_CELL(nxt, span); |
| 2232 | |
| 2233 | /* Allocate cluster spine |
| 2234 | */ |
| 2235 | *clusterp = PTR2SCM (ptr); |
| 2236 | SCM_SETCAR (*clusterp, PTR2SCM (nxt)); |
| 2237 | clusterp = SCM_CDRLOC (*clusterp); |
| 2238 | ptr = nxt; |
| 2239 | |
| 2240 | while (n_data_cells--) |
| 2241 | { |
| 2242 | scm_cell *card = SCM_GC_CELL_CARD (ptr); |
| 2243 | SCM scmptr = PTR2SCM (ptr); |
| 2244 | nxt = ptr; |
| 2245 | NEXT_DATA_CELL (nxt, span); |
| 2246 | prv = ptr; |
| 2247 | |
| 2248 | if (card != last_card) |
| 2249 | { |
| 2250 | INIT_CARD (card, span); |
| 2251 | last_card = card; |
| 2252 | } |
| 2253 | |
| 2254 | SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); |
| 2255 | SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt)); |
| 2256 | |
| 2257 | ptr = nxt; |
| 2258 | } |
| 2259 | |
| 2260 | SCM_SET_FREE_CELL_CDR (PTR2SCM (prv), SCM_EOL); |
| 2261 | } |
| 2262 | |
| 2263 | /* sanity check */ |
| 2264 | { |
| 2265 | scm_cell *ref = seg_end; |
| 2266 | NEXT_DATA_CELL (ref, span); |
| 2267 | if (ref != ptr) |
| 2268 | /* [cmm] looks like the segment size doesn't divide cleanly by |
| 2269 | cluster size. bad cmm! */ |
| 2270 | abort(); |
| 2271 | } |
| 2272 | |
| 2273 | /* Patch up the last cluster pointer in the segment |
| 2274 | * to join it to the input freelist. |
| 2275 | */ |
| 2276 | *clusterp = freelist->clusters; |
| 2277 | freelist->clusters = clusters; |
| 2278 | } |
| 2279 | |
| 2280 | #ifdef DEBUGINFO |
| 2281 | fprintf (stderr, "H"); |
| 2282 | #endif |
| 2283 | return size; |
| 2284 | } |
| 2285 | |
| 2286 | static size_t |
| 2287 | round_to_cluster_size (scm_freelist_t *freelist, size_t len) |
| 2288 | { |
| 2289 | size_t cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist); |
| 2290 | |
| 2291 | return |
| 2292 | (len + cluster_size_in_bytes - 1) / cluster_size_in_bytes * cluster_size_in_bytes |
| 2293 | + ALIGNMENT_SLACK (freelist); |
| 2294 | } |
| 2295 | |
| 2296 | static void |
| 2297 | alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) |
| 2298 | #define FUNC_NAME "alloc_some_heap" |
| 2299 | { |
| 2300 | SCM_CELLPTR ptr; |
| 2301 | size_t len; |
| 2302 | |
| 2303 | if (scm_gc_heap_lock) |
| 2304 | { |
| 2305 | /* Critical code sections (such as the garbage collector) aren't |
| 2306 | * supposed to add heap segments. |
| 2307 | */ |
| 2308 | fprintf (stderr, "alloc_some_heap: Can not extend locked heap.\n"); |
| 2309 | abort (); |
| 2310 | } |
| 2311 | |
| 2312 | if (scm_n_heap_segs == heap_segment_table_size) |
| 2313 | { |
| 2314 | /* We have to expand the heap segment table to have room for the new |
| 2315 | * segment. Do not yet increment scm_n_heap_segs -- that is done by |
| 2316 | * init_heap_seg only if the allocation of the segment itself succeeds. |
| 2317 | */ |
| 2318 | size_t new_table_size = scm_n_heap_segs + 1; |
| 2319 | size_t size = new_table_size * sizeof (scm_heap_seg_data_t); |
| 2320 | scm_heap_seg_data_t *new_heap_table; |
| 2321 | |
| 2322 | SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *) |
| 2323 | realloc ((char *)scm_heap_table, size))); |
| 2324 | if (!new_heap_table) |
| 2325 | { |
| 2326 | if (error_policy == abort_on_error) |
| 2327 | { |
| 2328 | fprintf (stderr, "alloc_some_heap: Could not grow heap segment table.\n"); |
| 2329 | abort (); |
| 2330 | } |
| 2331 | else |
| 2332 | { |
| 2333 | return; |
| 2334 | } |
| 2335 | } |
| 2336 | else |
| 2337 | { |
| 2338 | scm_heap_table = new_heap_table; |
| 2339 | heap_segment_table_size = new_table_size; |
| 2340 | } |
| 2341 | } |
| 2342 | |
| 2343 | /* Pick a size for the new heap segment. |
| 2344 | * The rule for picking the size of a segment is explained in |
| 2345 | * gc.h |
| 2346 | */ |
| 2347 | { |
| 2348 | /* Assure that the new segment is predicted to be large enough. |
| 2349 | * |
| 2350 | * New yield should at least equal GC fraction of new heap size, i.e. |
| 2351 | * |
| 2352 | * y + dh > f * (h + dh) |
| 2353 | * |
| 2354 | * y : yield |
| 2355 | * f : min yield fraction |
| 2356 | * h : heap size |
| 2357 | * dh : size of new heap segment |
| 2358 | * |
| 2359 | * This gives dh > (f * h - y) / (1 - f) |
| 2360 | */ |
| 2361 | int f = freelist->min_yield_fraction; |
| 2362 | unsigned long h = SCM_HEAP_SIZE; |
| 2363 | size_t min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f); |
| 2364 | len = SCM_EXPHEAP (freelist->heap_size); |
| 2365 | #ifdef DEBUGINFO |
| 2366 | fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells); |
| 2367 | #endif |
| 2368 | if (len < min_cells) |
| 2369 | len = min_cells + freelist->cluster_size; |
| 2370 | len *= sizeof (scm_cell); |
| 2371 | /* force new sampling */ |
| 2372 | freelist->collected = LONG_MAX; |
| 2373 | } |
| 2374 | |
| 2375 | if (len > scm_max_segment_size) |
| 2376 | len = scm_max_segment_size; |
| 2377 | |
| 2378 | { |
| 2379 | size_t smallest; |
| 2380 | |
| 2381 | smallest = CLUSTER_SIZE_IN_BYTES (freelist); |
| 2382 | |
| 2383 | if (len < smallest) |
| 2384 | len = smallest; |
| 2385 | |
| 2386 | /* Allocate with decaying ambition. */ |
| 2387 | while ((len >= SCM_MIN_HEAP_SEG_SIZE) |
| 2388 | && (len >= smallest)) |
| 2389 | { |
| 2390 | size_t rounded_len = round_to_cluster_size (freelist, len); |
| 2391 | SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (rounded_len)); |
| 2392 | if (ptr) |
| 2393 | { |
| 2394 | init_heap_seg (ptr, rounded_len, freelist); |
| 2395 | return; |
| 2396 | } |
| 2397 | len /= 2; |
| 2398 | } |
| 2399 | } |
| 2400 | |
| 2401 | if (error_policy == abort_on_error) |
| 2402 | { |
| 2403 | fprintf (stderr, "alloc_some_heap: Could not grow heap.\n"); |
| 2404 | abort (); |
| 2405 | } |
| 2406 | } |
| 2407 | #undef FUNC_NAME |
| 2408 | |
| 2409 | \f |
| 2410 | /* {GC Protection Helper Functions} |
| 2411 | */ |
| 2412 | |
| 2413 | |
| 2414 | /* |
| 2415 | * If within a function you need to protect one or more scheme objects from |
| 2416 | * garbage collection, pass them as parameters to one of the |
| 2417 | * scm_remember_upto_here* functions below. These functions don't do |
| 2418 | * anything, but since the compiler does not know that they are actually |
| 2419 | * no-ops, it will generate code that calls these functions with the given |
| 2420 | * parameters. Therefore, you can be sure that the compiler will keep those |
| 2421 | * scheme values alive (on the stack or in a register) up to the point where |
| 2422 | * scm_remember_upto_here* is called. In other words, place the call to |
| 2423 | * scm_remember_upt_here* _behind_ the last code in your function, that |
| 2424 | * depends on the scheme object to exist. |
| 2425 | * |
| 2426 | * Example: We want to make sure, that the string object str does not get |
| 2427 | * garbage collected during the execution of 'some_function', because |
| 2428 | * otherwise the characters belonging to str would be freed and |
| 2429 | * 'some_function' might access freed memory. To make sure that the compiler |
| 2430 | * keeps str alive on the stack or in a register such that it is visible to |
| 2431 | * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the |
| 2432 | * call to 'some_function'. Note that this would not be necessary if str was |
| 2433 | * used anyway after the call to 'some_function'. |
| 2434 | * char *chars = SCM_STRING_CHARS (str); |
| 2435 | * some_function (chars); |
| 2436 | * scm_remember_upto_here_1 (str); // str will be alive up to this point. |
| 2437 | */ |
| 2438 | |
| 2439 | void |
| 2440 | scm_remember_upto_here_1 (SCM obj) |
| 2441 | { |
| 2442 | /* Empty. Protects a single object from garbage collection. */ |
| 2443 | } |
| 2444 | |
| 2445 | void |
| 2446 | scm_remember_upto_here_2 (SCM obj1, SCM obj2) |
| 2447 | { |
| 2448 | /* Empty. Protects two objects from garbage collection. */ |
| 2449 | } |
| 2450 | |
| 2451 | void |
| 2452 | scm_remember_upto_here (SCM obj, ...) |
| 2453 | { |
| 2454 | /* Empty. Protects any number of objects from garbage collection. */ |
| 2455 | } |
| 2456 | |
| 2457 | |
| 2458 | #if (SCM_DEBUG_DEPRECATED == 0) |
| 2459 | |
| 2460 | void |
| 2461 | scm_remember (SCM *ptr) |
| 2462 | { |
| 2463 | scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. " |
| 2464 | "Use the `scm_remember_upto_here*' family of functions instead."); |
| 2465 | } |
| 2466 | |
| 2467 | #endif /* SCM_DEBUG_DEPRECATED == 0 */ |
| 2468 | |
| 2469 | /* |
| 2470 | These crazy functions prevent garbage collection |
| 2471 | of arguments after the first argument by |
| 2472 | ensuring they remain live throughout the |
| 2473 | function because they are used in the last |
| 2474 | line of the code block. |
| 2475 | It'd be better to have a nice compiler hint to |
| 2476 | aid the conservative stack-scanning GC. --03/09/00 gjb */ |
| 2477 | SCM |
| 2478 | scm_return_first (SCM elt, ...) |
| 2479 | { |
| 2480 | return elt; |
| 2481 | } |
| 2482 | |
| 2483 | int |
| 2484 | scm_return_first_int (int i, ...) |
| 2485 | { |
| 2486 | return i; |
| 2487 | } |
| 2488 | |
| 2489 | |
| 2490 | SCM |
| 2491 | scm_permanent_object (SCM obj) |
| 2492 | { |
| 2493 | SCM_REDEFER_INTS; |
| 2494 | scm_permobjs = scm_cons (obj, scm_permobjs); |
| 2495 | SCM_REALLOW_INTS; |
| 2496 | return obj; |
| 2497 | } |
| 2498 | |
| 2499 | |
| 2500 | /* Protect OBJ from the garbage collector. OBJ will not be freed, even if all |
| 2501 | other references are dropped, until the object is unprotected by calling |
| 2502 | scm_unprotect_object (OBJ). Calls to scm_protect/unprotect_object nest, |
| 2503 | i. e. it is possible to protect the same object several times, but it is |
| 2504 | necessary to unprotect the object the same number of times to actually get |
| 2505 | the object unprotected. It is an error to unprotect an object more often |
| 2506 | than it has been protected before. The function scm_protect_object returns |
| 2507 | OBJ. |
| 2508 | */ |
| 2509 | |
| 2510 | /* Implementation note: For every object X, there is a counter which |
| 2511 | scm_protect_object(X) increments and scm_unprotect_object(X) decrements. |
| 2512 | */ |
| 2513 | |
| 2514 | SCM |
| 2515 | scm_protect_object (SCM obj) |
| 2516 | { |
| 2517 | SCM handle; |
| 2518 | |
| 2519 | /* This critical section barrier will be replaced by a mutex. */ |
| 2520 | SCM_REDEFER_INTS; |
| 2521 | |
| 2522 | handle = scm_hashq_create_handle_x (scm_protects, obj, SCM_MAKINUM (0)); |
| 2523 | SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1))); |
| 2524 | |
| 2525 | SCM_REALLOW_INTS; |
| 2526 | |
| 2527 | return obj; |
| 2528 | } |
| 2529 | |
| 2530 | |
| 2531 | /* Remove any protection for OBJ established by a prior call to |
| 2532 | scm_protect_object. This function returns OBJ. |
| 2533 | |
| 2534 | See scm_protect_object for more information. */ |
| 2535 | SCM |
| 2536 | scm_unprotect_object (SCM obj) |
| 2537 | { |
| 2538 | SCM handle; |
| 2539 | |
| 2540 | /* This critical section barrier will be replaced by a mutex. */ |
| 2541 | SCM_REDEFER_INTS; |
| 2542 | |
| 2543 | handle = scm_hashq_get_handle (scm_protects, obj); |
| 2544 | |
| 2545 | if (SCM_FALSEP (handle)) |
| 2546 | { |
| 2547 | fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); |
| 2548 | abort (); |
| 2549 | } |
| 2550 | else |
| 2551 | { |
| 2552 | SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1)); |
| 2553 | if (SCM_EQ_P (count, SCM_MAKINUM (0))) |
| 2554 | scm_hashq_remove_x (scm_protects, obj); |
| 2555 | else |
| 2556 | SCM_SETCDR (handle, count); |
| 2557 | } |
| 2558 | |
| 2559 | SCM_REALLOW_INTS; |
| 2560 | |
| 2561 | return obj; |
| 2562 | } |
| 2563 | |
| 2564 | int terminating; |
| 2565 | |
| 2566 | /* called on process termination. */ |
| 2567 | #ifdef HAVE_ATEXIT |
| 2568 | static void |
| 2569 | cleanup (void) |
| 2570 | #else |
| 2571 | #ifdef HAVE_ON_EXIT |
| 2572 | extern int on_exit (void (*procp) (), int arg); |
| 2573 | |
| 2574 | static void |
| 2575 | cleanup (int status, void *arg) |
| 2576 | #else |
| 2577 | #error Dont know how to setup a cleanup handler on your system. |
| 2578 | #endif |
| 2579 | #endif |
| 2580 | { |
| 2581 | terminating = 1; |
| 2582 | scm_flush_all_ports (); |
| 2583 | } |
| 2584 | |
| 2585 | \f |
| 2586 | static int |
| 2587 | make_initial_segment (size_t init_heap_size, scm_freelist_t *freelist) |
| 2588 | { |
| 2589 | size_t rounded_size = round_to_cluster_size (freelist, init_heap_size); |
| 2590 | |
| 2591 | if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size), |
| 2592 | rounded_size, |
| 2593 | freelist)) |
| 2594 | { |
| 2595 | rounded_size = round_to_cluster_size (freelist, SCM_HEAP_SEG_SIZE); |
| 2596 | if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size), |
| 2597 | rounded_size, |
| 2598 | freelist)) |
| 2599 | return 1; |
| 2600 | } |
| 2601 | else |
| 2602 | scm_expmem = 1; |
| 2603 | |
| 2604 | if (freelist->min_yield_fraction) |
| 2605 | freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction |
| 2606 | / 100); |
| 2607 | freelist->grow_heap_p = (freelist->heap_size < freelist->min_yield); |
| 2608 | |
| 2609 | return 0; |
| 2610 | } |
| 2611 | |
| 2612 | \f |
| 2613 | static void |
| 2614 | init_freelist (scm_freelist_t *freelist, |
| 2615 | int span, |
| 2616 | long cluster_size, |
| 2617 | int min_yield) |
| 2618 | { |
| 2619 | freelist->clusters = SCM_EOL; |
| 2620 | freelist->cluster_size = cluster_size + 1; |
| 2621 | freelist->left_to_collect = 0; |
| 2622 | freelist->clusters_allocated = 0; |
| 2623 | freelist->min_yield = 0; |
| 2624 | freelist->min_yield_fraction = min_yield; |
| 2625 | freelist->span = span; |
| 2626 | freelist->collected = 0; |
| 2627 | freelist->collected_1 = 0; |
| 2628 | freelist->heap_size = 0; |
| 2629 | } |
| 2630 | |
| 2631 | |
| 2632 | /* Get an integer from an environment variable. */ |
| 2633 | static int |
| 2634 | scm_i_getenv_int (const char *var, int def) |
| 2635 | { |
| 2636 | char *end, *val = getenv (var); |
| 2637 | long res; |
| 2638 | if (!val) |
| 2639 | return def; |
| 2640 | res = strtol (val, &end, 10); |
| 2641 | if (end == val) |
| 2642 | return def; |
| 2643 | return res; |
| 2644 | } |
| 2645 | |
| 2646 | |
| 2647 | int |
| 2648 | scm_init_storage () |
| 2649 | { |
| 2650 | unsigned long gc_trigger_1; |
| 2651 | unsigned long gc_trigger_2; |
| 2652 | size_t init_heap_size_1; |
| 2653 | size_t init_heap_size_2; |
| 2654 | size_t j; |
| 2655 | |
| 2656 | #if (SCM_DEBUG_CELL_ACCESSES == 1) |
| 2657 | scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); |
| 2658 | #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ |
| 2659 | |
| 2660 | j = SCM_NUM_PROTECTS; |
| 2661 | while (j) |
| 2662 | scm_sys_protects[--j] = SCM_BOOL_F; |
| 2663 | scm_block_gc = 1; |
| 2664 | |
| 2665 | scm_freelist = SCM_EOL; |
| 2666 | scm_freelist2 = SCM_EOL; |
| 2667 | gc_trigger_1 = scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1); |
| 2668 | init_freelist (&scm_master_freelist, 1, SCM_CLUSTER_SIZE_1, gc_trigger_1); |
| 2669 | gc_trigger_2 = scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2); |
| 2670 | init_freelist (&scm_master_freelist2, 2, SCM_CLUSTER_SIZE_2, gc_trigger_2); |
| 2671 | scm_max_segment_size = scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size); |
| 2672 | |
| 2673 | scm_expmem = 0; |
| 2674 | |
| 2675 | j = SCM_HEAP_SEG_SIZE; |
| 2676 | scm_mtrigger = SCM_INIT_MALLOC_LIMIT; |
| 2677 | scm_heap_table = ((scm_heap_seg_data_t *) |
| 2678 | scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims")); |
| 2679 | heap_segment_table_size = 2; |
| 2680 | |
| 2681 | mark_space_ptr = &mark_space_head; |
| 2682 | |
| 2683 | init_heap_size_1 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1); |
| 2684 | init_heap_size_2 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2); |
| 2685 | if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || |
| 2686 | make_initial_segment (init_heap_size_2, &scm_master_freelist2)) |
| 2687 | return 1; |
| 2688 | |
| 2689 | /* scm_hplims[0] can change. do not remove scm_heap_org */ |
| 2690 | scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0], 1); |
| 2691 | |
| 2692 | scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL); |
| 2693 | scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL); |
| 2694 | scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL); |
| 2695 | scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL); |
| 2696 | scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); |
| 2697 | |
| 2698 | /* Initialise the list of ports. */ |
| 2699 | scm_port_table = (scm_port_t **) |
| 2700 | malloc (sizeof (scm_port_t *) * scm_port_table_room); |
| 2701 | if (!scm_port_table) |
| 2702 | return 1; |
| 2703 | |
| 2704 | #ifdef HAVE_ATEXIT |
| 2705 | atexit (cleanup); |
| 2706 | #else |
| 2707 | #ifdef HAVE_ON_EXIT |
| 2708 | on_exit (cleanup, 0); |
| 2709 | #endif |
| 2710 | #endif |
| 2711 | |
| 2712 | scm_stand_in_procs = SCM_EOL; |
| 2713 | scm_permobjs = SCM_EOL; |
| 2714 | scm_protects = scm_c_make_hash_table (31); |
| 2715 | |
| 2716 | return 0; |
| 2717 | } |
| 2718 | |
| 2719 | \f |
| 2720 | |
| 2721 | SCM scm_after_gc_hook; |
| 2722 | |
| 2723 | static SCM gc_async; |
| 2724 | |
| 2725 | /* The function gc_async_thunk causes the execution of the after-gc-hook. It |
| 2726 | * is run after the gc, as soon as the asynchronous events are handled by the |
| 2727 | * evaluator. |
| 2728 | */ |
| 2729 | static SCM |
| 2730 | gc_async_thunk (void) |
| 2731 | { |
| 2732 | scm_c_run_hook (scm_after_gc_hook, SCM_EOL); |
| 2733 | return SCM_UNSPECIFIED; |
| 2734 | } |
| 2735 | |
| 2736 | |
| 2737 | /* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of |
| 2738 | * the garbage collection. The only purpose of this function is to mark the |
| 2739 | * gc_async (which will eventually lead to the execution of the |
| 2740 | * gc_async_thunk). |
| 2741 | */ |
| 2742 | static void * |
| 2743 | mark_gc_async (void * hook_data, void *func_data, void *data) |
| 2744 | { |
| 2745 | scm_system_async_mark (gc_async); |
| 2746 | return NULL; |
| 2747 | } |
| 2748 | |
| 2749 | |
| 2750 | void |
| 2751 | scm_init_gc () |
| 2752 | { |
| 2753 | SCM after_gc_thunk; |
| 2754 | |
| 2755 | /* Dirk:FIXME:: scm_create_hook is strange. */ |
| 2756 | scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); |
| 2757 | |
| 2758 | after_gc_thunk = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0, |
| 2759 | gc_async_thunk); |
| 2760 | gc_async = scm_system_async (after_gc_thunk); /* protected via scm_asyncs */ |
| 2761 | |
| 2762 | scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); |
| 2763 | |
| 2764 | #ifndef SCM_MAGIC_SNARFER |
| 2765 | #include "libguile/gc.x" |
| 2766 | #endif |
| 2767 | } |
| 2768 | |
| 2769 | #endif /*MARK_DEPENDENCIES*/ |
| 2770 | |
| 2771 | /* |
| 2772 | Local Variables: |
| 2773 | c-file-style: "gnu" |
| 2774 | End: |
| 2775 | */ |