| 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This library is free software; you can redistribute it and/or |
| 4 | * modify it under the terms of the GNU Lesser General Public |
| 5 | * License as published by the Free Software Foundation; either |
| 6 | * version 2.1 of the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library 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 GNU |
| 11 | * Lesser General Public License for more details. |
| 12 | * |
| 13 | * You should have received a copy of the GNU Lesser General Public |
| 14 | * License along with this library; if not, write to the Free Software |
| 15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| 16 | */ |
| 17 | |
| 18 | #include <assert.h> |
| 19 | #include <stdio.h> |
| 20 | #include <string.h> |
| 21 | |
| 22 | #include "libguile/_scm.h" |
| 23 | #include "libguile/pairs.h" |
| 24 | #include "libguile/gc.h" |
| 25 | #include "libguile/private-gc.h" |
| 26 | |
| 27 | |
| 28 | |
| 29 | |
| 30 | |
| 31 | size_t scm_max_segment_size; |
| 32 | |
| 33 | scm_t_heap_segment * |
| 34 | scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl) |
| 35 | { |
| 36 | scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment)); |
| 37 | |
| 38 | if (!shs) |
| 39 | { |
| 40 | fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n"); |
| 41 | abort (); |
| 42 | } |
| 43 | |
| 44 | shs->bounds[0] = NULL; |
| 45 | shs->bounds[1] = NULL; |
| 46 | shs->malloced = NULL; |
| 47 | shs->span = fl->span; |
| 48 | shs->freelist = fl; |
| 49 | shs->next_free_card = NULL; |
| 50 | |
| 51 | return shs; |
| 52 | } |
| 53 | |
| 54 | |
| 55 | /* |
| 56 | Fill SEGMENT with memory both for data and mark bits. |
| 57 | |
| 58 | RETURN: 1 on success, 0 failure |
| 59 | */ |
| 60 | int |
| 61 | scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested) |
| 62 | { |
| 63 | /* |
| 64 | round upwards |
| 65 | */ |
| 66 | int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS); |
| 67 | int card_count =1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count; |
| 68 | |
| 69 | /* |
| 70 | one card extra due to alignment |
| 71 | */ |
| 72 | size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD |
| 73 | + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG |
| 74 | ; |
| 75 | scm_t_c_bvec_long * bvec_ptr = 0; |
| 76 | scm_t_cell * memory = 0; |
| 77 | |
| 78 | /* |
| 79 | We use malloc to alloc the heap. On GNU libc this is |
| 80 | equivalent to mmapping /dev/zero |
| 81 | */ |
| 82 | SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed)); |
| 83 | |
| 84 | if (memory == NULL) |
| 85 | return 0; |
| 86 | |
| 87 | segment->malloced = memory; |
| 88 | segment->bounds[0] = SCM_GC_CARD_UP (memory); |
| 89 | segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS; |
| 90 | |
| 91 | segment->freelist->heap_size += scm_i_segment_cell_count (segment); |
| 92 | |
| 93 | bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1]; |
| 94 | |
| 95 | /* |
| 96 | Don't init the mem or the bitvector. This is handled by lazy |
| 97 | sweeping. |
| 98 | */ |
| 99 | |
| 100 | segment->next_free_card = segment->bounds[0]; |
| 101 | segment->first_time = 1; |
| 102 | return 1; |
| 103 | } |
| 104 | |
| 105 | int |
| 106 | scm_i_segment_card_count (scm_t_heap_segment * seg) |
| 107 | { |
| 108 | return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; |
| 109 | } |
| 110 | |
| 111 | /* |
| 112 | Return the number of available single-cell data cells. |
| 113 | */ |
| 114 | int |
| 115 | scm_i_segment_cell_count (scm_t_heap_segment * seg) |
| 116 | { |
| 117 | return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) |
| 118 | + ((seg->span == 2) ? -1 : 0); |
| 119 | } |
| 120 | |
| 121 | void |
| 122 | scm_i_clear_segment_mark_space (scm_t_heap_segment *seg) |
| 123 | { |
| 124 | scm_t_cell * markspace = seg->bounds[1]; |
| 125 | |
| 126 | memset (markspace, 0x00, |
| 127 | scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG); |
| 128 | } |
| 129 | |
| 130 | /* |
| 131 | Sweep cards from SEG until we've gathered THRESHOLD cells |
| 132 | |
| 133 | RETURN: |
| 134 | |
| 135 | Freelist. |
| 136 | */ |
| 137 | SCM |
| 138 | scm_i_sweep_some_cards (scm_t_heap_segment *seg) |
| 139 | { |
| 140 | SCM cells = SCM_EOL; |
| 141 | int threshold = 512; |
| 142 | int collected = 0; |
| 143 | int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* ) |
| 144 | = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card; |
| 145 | |
| 146 | scm_t_cell * next_free = seg->next_free_card; |
| 147 | int cards_swept = 0; |
| 148 | |
| 149 | while (collected < threshold && next_free < seg->bounds[1]) |
| 150 | { |
| 151 | collected += (*sweeper) (next_free, &cells, seg); |
| 152 | next_free += SCM_GC_CARD_N_CELLS; |
| 153 | cards_swept ++; |
| 154 | } |
| 155 | |
| 156 | scm_gc_cells_swept += cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS); |
| 157 | scm_gc_cells_collected += collected * seg->span; |
| 158 | |
| 159 | if (!seg->first_time) |
| 160 | scm_cells_allocated -= collected * seg->span; |
| 161 | |
| 162 | seg->freelist->collected += collected * seg->span; |
| 163 | |
| 164 | |
| 165 | if(next_free == seg->bounds[1]) |
| 166 | { |
| 167 | seg->first_time = 0; |
| 168 | } |
| 169 | |
| 170 | seg->next_free_card = next_free; |
| 171 | return cells; |
| 172 | } |
| 173 | |
| 174 | |
| 175 | /* |
| 176 | Force a sweep of this entire segment. This doesn't modify sweep |
| 177 | statistics, it just frees the memory pointed to by to-be-swept |
| 178 | cells. |
| 179 | |
| 180 | Implementation is slightly ugh. |
| 181 | |
| 182 | FIXME: if you do scm_i_sweep_segment(), and then allocate from this |
| 183 | segment again, the statistics are off. |
| 184 | */ |
| 185 | void |
| 186 | scm_i_sweep_segment (scm_t_heap_segment * seg) |
| 187 | { |
| 188 | scm_t_cell * p = seg->next_free_card; |
| 189 | int yield = scm_gc_cells_collected; |
| 190 | int coll = seg->freelist->collected; |
| 191 | unsigned long alloc = scm_cells_allocated ; |
| 192 | |
| 193 | while (scm_i_sweep_some_cards (seg) != SCM_EOL) |
| 194 | ; |
| 195 | |
| 196 | scm_gc_cells_collected = yield; |
| 197 | scm_cells_allocated = alloc; |
| 198 | seg->freelist->collected = coll; |
| 199 | |
| 200 | seg->next_free_card =p; |
| 201 | } |
| 202 | |
| 203 | void |
| 204 | scm_i_sweep_all_segments (char const *reason) |
| 205 | { |
| 206 | int i= 0; |
| 207 | |
| 208 | for (i = 0; i < scm_i_heap_segment_table_size; i++) |
| 209 | { |
| 210 | scm_i_sweep_segment (scm_i_heap_segment_table[i]); |
| 211 | } |
| 212 | } |
| 213 | |
| 214 | |
| 215 | /* |
| 216 | Heap segment table. |
| 217 | |
| 218 | The table is sorted by the address of the data itself. This makes |
| 219 | for easy lookups. This is not portable: according to ANSI C, |
| 220 | pointers can only be compared within the same object (i.e. the same |
| 221 | block of malloced memory.). For machines with weird architectures, |
| 222 | this should be revised. |
| 223 | |
| 224 | (Apparently, for this reason 1.6 and earlier had macros for pointer |
| 225 | comparison. ) |
| 226 | |
| 227 | perhaps it is worthwhile to remove the 2nd level of indirection in |
| 228 | the table, but this certainly makes for cleaner code. |
| 229 | */ |
| 230 | scm_t_heap_segment ** scm_i_heap_segment_table; |
| 231 | size_t scm_i_heap_segment_table_size; |
| 232 | scm_t_cell *lowest_cell; |
| 233 | scm_t_cell *highest_cell; |
| 234 | |
| 235 | |
| 236 | void |
| 237 | scm_i_clear_mark_space (void) |
| 238 | { |
| 239 | int i = 0; |
| 240 | for (; i < scm_i_heap_segment_table_size; i++) |
| 241 | { |
| 242 | scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]); |
| 243 | } |
| 244 | } |
| 245 | |
| 246 | |
| 247 | /* |
| 248 | RETURN: index of inserted segment. |
| 249 | */ |
| 250 | int |
| 251 | scm_i_insert_segment (scm_t_heap_segment * seg) |
| 252 | { |
| 253 | size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *); |
| 254 | SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **) |
| 255 | realloc ((char *)scm_i_heap_segment_table, size))); |
| 256 | |
| 257 | /* |
| 258 | We can't alloc 4 more bytes. This is hopeless. |
| 259 | */ |
| 260 | if (!scm_i_heap_segment_table) |
| 261 | { |
| 262 | fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n"); |
| 263 | abort (); |
| 264 | } |
| 265 | |
| 266 | if (!lowest_cell) |
| 267 | { |
| 268 | lowest_cell = seg->bounds[0]; |
| 269 | highest_cell = seg->bounds[1]; |
| 270 | } |
| 271 | else |
| 272 | { |
| 273 | lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]); |
| 274 | highest_cell = SCM_MAX (highest_cell, seg->bounds[1]); |
| 275 | } |
| 276 | |
| 277 | |
| 278 | { |
| 279 | int i = 0; |
| 280 | int j = 0; |
| 281 | |
| 282 | while (i < scm_i_heap_segment_table_size |
| 283 | && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0]) |
| 284 | i++; |
| 285 | |
| 286 | /* |
| 287 | We insert a new entry; if that happens to be before the |
| 288 | "current" segment of a freelist, we must move the freelist index |
| 289 | as well. |
| 290 | */ |
| 291 | if (scm_i_master_freelist.heap_segment_idx >= i) |
| 292 | scm_i_master_freelist.heap_segment_idx ++; |
| 293 | if (scm_i_master_freelist2.heap_segment_idx >= i) |
| 294 | scm_i_master_freelist2.heap_segment_idx ++; |
| 295 | |
| 296 | for (j = scm_i_heap_segment_table_size; j > i; --j) |
| 297 | scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1]; |
| 298 | |
| 299 | scm_i_heap_segment_table [i] = seg; |
| 300 | scm_i_heap_segment_table_size ++; |
| 301 | |
| 302 | return i; |
| 303 | } |
| 304 | } |
| 305 | |
| 306 | SCM |
| 307 | scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl) |
| 308 | { |
| 309 | int i = fl->heap_segment_idx; |
| 310 | SCM collected =SCM_EOL; |
| 311 | |
| 312 | if (i == -1) |
| 313 | i++; |
| 314 | |
| 315 | for (; |
| 316 | i < scm_i_heap_segment_table_size; i++) |
| 317 | { |
| 318 | if (scm_i_heap_segment_table[i]->freelist != fl) |
| 319 | continue; |
| 320 | |
| 321 | collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]); |
| 322 | |
| 323 | |
| 324 | if (collected != SCM_EOL) /* Don't increment i */ |
| 325 | break; |
| 326 | } |
| 327 | |
| 328 | fl->heap_segment_idx = i; |
| 329 | |
| 330 | return collected; |
| 331 | } |
| 332 | |
| 333 | |
| 334 | |
| 335 | |
| 336 | void |
| 337 | scm_i_reset_segments (void) |
| 338 | { |
| 339 | int i = 0; |
| 340 | for (; i < scm_i_heap_segment_table_size; i++) |
| 341 | { |
| 342 | scm_t_heap_segment * seg = scm_i_heap_segment_table[i]; |
| 343 | seg->next_free_card = seg->bounds[0]; |
| 344 | } |
| 345 | } |
| 346 | |
| 347 | |
| 348 | /* |
| 349 | Determine whether the given value does actually represent a cell in |
| 350 | some heap segment. If this is the case, the number of the heap |
| 351 | segment is returned. Otherwise, -1 is returned. Binary search is |
| 352 | used to determine the heap segment that contains the cell. |
| 353 | |
| 354 | |
| 355 | I think this function is too long to be inlined. --hwn |
| 356 | */ |
| 357 | long int |
| 358 | scm_i_find_heap_segment_containing_object (SCM obj) |
| 359 | { |
| 360 | if (!CELL_P (obj)) |
| 361 | return -1; |
| 362 | |
| 363 | if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell) |
| 364 | return -1; |
| 365 | |
| 366 | |
| 367 | { |
| 368 | scm_t_cell * ptr = SCM2PTR (obj); |
| 369 | unsigned long int i = 0; |
| 370 | unsigned long int j = scm_i_heap_segment_table_size - 1; |
| 371 | |
| 372 | if (ptr < scm_i_heap_segment_table[i]->bounds[0]) |
| 373 | return -1; |
| 374 | else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) |
| 375 | return -1; |
| 376 | else |
| 377 | { |
| 378 | while (i < j) |
| 379 | { |
| 380 | if (ptr < scm_i_heap_segment_table[i]->bounds[1]) |
| 381 | { |
| 382 | break; |
| 383 | } |
| 384 | else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr) |
| 385 | { |
| 386 | i = j; |
| 387 | break; |
| 388 | } |
| 389 | else |
| 390 | { |
| 391 | unsigned long int k = (i + j) / 2; |
| 392 | |
| 393 | if (k == i) |
| 394 | return -1; |
| 395 | else if (ptr < scm_i_heap_segment_table[k]->bounds[1]) |
| 396 | { |
| 397 | j = k; |
| 398 | ++i; |
| 399 | if (ptr < scm_i_heap_segment_table[i]->bounds[0]) |
| 400 | return -1; |
| 401 | } |
| 402 | else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr) |
| 403 | { |
| 404 | i = k; |
| 405 | --j; |
| 406 | if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) |
| 407 | return -1; |
| 408 | } |
| 409 | } |
| 410 | } |
| 411 | |
| 412 | if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2) |
| 413 | return -1; |
| 414 | else if (SCM_GC_IN_CARD_HEADERP (ptr)) |
| 415 | return -1; |
| 416 | else |
| 417 | return i; |
| 418 | } |
| 419 | } |
| 420 | } |
| 421 | |
| 422 | |
| 423 | /* |
| 424 | Important entry point: try to grab some memory, and make it into a |
| 425 | segment. |
| 426 | |
| 427 | RETURN: the index of the segment. |
| 428 | */ |
| 429 | int |
| 430 | scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_error error_policy) |
| 431 | { |
| 432 | size_t len; |
| 433 | |
| 434 | if (scm_gc_heap_lock) |
| 435 | { |
| 436 | /* Critical code sections (such as the garbage collector) aren't |
| 437 | * supposed to add heap segments. |
| 438 | */ |
| 439 | fprintf (stderr, "scm_i_get_new_heap_segment: Can not extend locked heap.\n"); |
| 440 | abort (); |
| 441 | } |
| 442 | |
| 443 | { |
| 444 | /* Assure that the new segment is predicted to be large enough. |
| 445 | * |
| 446 | * New yield should at least equal GC fraction of new heap size, i.e. |
| 447 | * |
| 448 | * y + dh > f * (h + dh) |
| 449 | * |
| 450 | * y : yield |
| 451 | * f : min yield fraction |
| 452 | * h : heap size |
| 453 | * dh : size of new heap segment |
| 454 | * |
| 455 | * This gives dh > (f * h - y) / (1 - f) |
| 456 | */ |
| 457 | float f = freelist->min_yield_fraction / 100.0; |
| 458 | float h = SCM_HEAP_SIZE; |
| 459 | float min_cells |
| 460 | = (f * h - scm_gc_cells_collected) / (1.0 - f); |
| 461 | |
| 462 | /* Make heap grow with factor 1.5 */ |
| 463 | len = freelist->heap_size / 2; |
| 464 | #ifdef DEBUGINFO |
| 465 | fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells); |
| 466 | #endif |
| 467 | |
| 468 | if (len < min_cells) |
| 469 | len = (unsigned long) min_cells; |
| 470 | len *= sizeof (scm_t_cell); |
| 471 | /* force new sampling */ |
| 472 | freelist->collected = LONG_MAX; |
| 473 | } |
| 474 | |
| 475 | if (len > scm_max_segment_size) |
| 476 | len = scm_max_segment_size; |
| 477 | if (len < SCM_MIN_HEAP_SEG_SIZE) |
| 478 | len = SCM_MIN_HEAP_SEG_SIZE; |
| 479 | |
| 480 | { |
| 481 | scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist); |
| 482 | |
| 483 | /* Allocate with decaying ambition. */ |
| 484 | while (len >= SCM_MIN_HEAP_SEG_SIZE) |
| 485 | { |
| 486 | if (scm_i_initialize_heap_segment_data (seg, len)) |
| 487 | { |
| 488 | return scm_i_insert_segment (seg); |
| 489 | } |
| 490 | |
| 491 | len /= 2; |
| 492 | } |
| 493 | } |
| 494 | |
| 495 | if (error_policy == abort_on_error) |
| 496 | { |
| 497 | fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n"); |
| 498 | abort (); |
| 499 | } |
| 500 | return -1; |
| 501 | } |
| 502 | |
| 503 | void |
| 504 | scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist) |
| 505 | { |
| 506 | scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist); |
| 507 | |
| 508 | if (init_heap_size < 1) |
| 509 | { |
| 510 | init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1; |
| 511 | } |
| 512 | |
| 513 | if (scm_i_initialize_heap_segment_data (seg, init_heap_size)) |
| 514 | { |
| 515 | freelist->heap_segment_idx = scm_i_insert_segment (seg); |
| 516 | } |
| 517 | |
| 518 | /* |
| 519 | Why the fuck try twice? --hwn |
| 520 | */ |
| 521 | if (!seg->malloced) |
| 522 | { |
| 523 | scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE); |
| 524 | } |
| 525 | |
| 526 | if (freelist->min_yield_fraction) |
| 527 | freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction |
| 528 | / 100); |
| 529 | } |