vm/data_gc.c

   1 #include "master.h"
   2
   3 CELL init_zone(F_ZONE *z, CELL size, CELL start)
   4 {
   5         z->size = size;
   6         z->start = z->here = start;
   7         z->end = start + size;
   8         return z->end;
   9 }
  10
  11 void init_card_decks(void)
  12 {
  13         CELL start = align(data_heap->segment->start,DECK_SIZE);
  14         allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
  15         cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
  16         decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
  17 }
  18
  19 F_DATA_HEAP *alloc_data_heap(CELL gens,
  20         CELL young_size,
  21         CELL aging_size,
  22         CELL tenured_size)
  23 {
  24         young_size = align(young_size,DECK_SIZE);
  25         aging_size = align(aging_size,DECK_SIZE);
  26         tenured_size = align(tenured_size,DECK_SIZE);
  27
  28         F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
  29         data_heap->young_size = young_size;
  30         data_heap->aging_size = aging_size;
  31         data_heap->tenured_size = tenured_size;
  32         data_heap->gen_count = gens;
  33
  34         CELL total_size;
  35         if(data_heap->gen_count == 2)
  36                 total_size = young_size + 2 * tenured_size;
  37         else if(data_heap->gen_count == 3)
  38                 total_size = young_size + 2 * aging_size + 2 * tenured_size;
  39         else
  40         {
  41                 fatal_error("Invalid number of generations",data_heap->gen_count);
  42                 return NULL; /* can't happen */
  43         }
  44
  45         total_size += DECK_SIZE;
  46
  47         data_heap->segment = alloc_segment(total_size);
  48
  49         data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
  50         data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
  51
  52         CELL cards_size = total_size >> CARD_BITS;
  53         data_heap->allot_markers = safe_malloc(cards_size);
  54         data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
  55
  56         data_heap->cards = safe_malloc(cards_size);
  57         data_heap->cards_end = data_heap->cards + cards_size;
  58
  59         CELL decks_size = total_size >> DECK_BITS;
  60         data_heap->decks = safe_malloc(decks_size);
  61         data_heap->decks_end = data_heap->decks + decks_size;
  62
  63         CELL alloter = align(data_heap->segment->start,DECK_SIZE);
  64
  65         alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
  66         alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
  67
  68         if(data_heap->gen_count == 3)
  69         {
  70                 alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
  71                 alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
  72         }
  73
  74         if(data_heap->gen_count >= 2)
  75         {
  76                 alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
  77                 alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
  78         }
  79
  80         if(data_heap->segment->end - alloter > DECK_SIZE)
  81                 critical_error("Bug in alloc_data_heap",alloter);
  82
  83         return data_heap;
  84 }
  85
  86 F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
  87 {
  88         CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
  89
  90         return alloc_data_heap(data_heap->gen_count,
  91                 data_heap->young_size,
  92                 data_heap->aging_size,
  93                 new_tenured_size);
  94 }
  95
  96 void dealloc_data_heap(F_DATA_HEAP *data_heap)
  97 {
  98         dealloc_segment(data_heap->segment);
  99         free(data_heap->generations);
 100         free(data_heap->semispaces);
 101         free(data_heap->allot_markers);
 102         free(data_heap->cards);
 103         free(data_heap->decks);
 104         free(data_heap);
 105 }
 106
 107 void clear_cards(CELL from, CELL to)
 108 {
 109         /* NOTE: reverse order due to heap layout. */
 110         F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
 111         F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
 112         memset(first_card,0,last_card - first_card);
 113 }
 114
 115 void clear_decks(CELL from, CELL to)
 116 {
 117         /* NOTE: reverse order due to heap layout. */
 118         F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
 119         F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
 120         memset(first_deck,0,last_deck - first_deck);
 121 }
 122
 123 void clear_allot_markers(CELL from, CELL to)
 124 {
 125         /* NOTE: reverse order due to heap layout. */
 126         F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
 127         F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
 128         memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
 129 }
 130
 131 void set_data_heap(F_DATA_HEAP *data_heap_)
 132 {
 133         data_heap = data_heap_;
 134         nursery = data_heap->generations[NURSERY];
 135         init_card_decks();
 136         clear_cards(NURSERY,TENURED);
 137         clear_decks(NURSERY,TENURED);
 138         clear_allot_markers(NURSERY,TENURED);
 139 }
 140
 141 void gc_reset(void)
 142 {
 143         int i;
 144         for(i = 0; i < MAX_GEN_COUNT; i++)
 145                 memset(&gc_stats[i],0,sizeof(F_GC_STATS));
 146
 147         cards_scanned = 0;
 148         decks_scanned = 0;
 149         code_heap_scans = 0;
 150 }
 151
 152 void init_data_heap(CELL gens,
 153         CELL young_size,
 154         CELL aging_size,
 155         CELL tenured_size,
 156         bool secure_gc_)
 157 {
 158         set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
 159
 160         gc_locals_region = alloc_segment(getpagesize());
 161         gc_locals = gc_locals_region->start - CELLS;
 162
 163         extra_roots_region = alloc_segment(getpagesize());
 164         extra_roots = extra_roots_region->start - CELLS;
 165
 166         secure_gc = secure_gc_;
 167
 168         gc_reset();
 169 }
 170
 171 /* Size of the object pointed to by a tagged pointer */
 172 CELL object_size(CELL tagged)
 173 {
 174         if(immediate_p(tagged))
 175                 return 0;
 176         else
 177                 return untagged_object_size(UNTAG(tagged));
 178 }
 179
 180 /* Size of the object pointed to by an untagged pointer */
 181 CELL untagged_object_size(CELL pointer)
 182 {
 183         return align8(unaligned_object_size(pointer));
 184 }
 185
 186 /* Size of the data area of an object pointed to by an untagged pointer */
 187 CELL unaligned_object_size(CELL pointer)
 188 {
 189         F_TUPLE *tuple;
 190         F_TUPLE_LAYOUT *layout;
 191
 192         switch(untag_header(get(pointer)))
 193         {
 194         case ARRAY_TYPE:
 195         case BIGNUM_TYPE:
 196                 return array_size(array_capacity((F_ARRAY*)pointer));
 197         case BYTE_ARRAY_TYPE:
 198                 return byte_array_size(
 199                         byte_array_capacity((F_BYTE_ARRAY*)pointer));
 200         case STRING_TYPE:
 201                 return string_size(string_capacity((F_STRING*)pointer));
 202         case TUPLE_TYPE:
 203                 tuple = untag_object(pointer);
 204                 layout = untag_object(tuple->layout);
 205                 return tuple_size(layout);
 206         case QUOTATION_TYPE:
 207                 return sizeof(F_QUOTATION);
 208         case WORD_TYPE:
 209                 return sizeof(F_WORD);
 210         case RATIO_TYPE:
 211                 return sizeof(F_RATIO);
 212         case FLOAT_TYPE:
 213                 return sizeof(F_FLOAT);
 214         case COMPLEX_TYPE:
 215                 return sizeof(F_COMPLEX);
 216         case DLL_TYPE:
 217                 return sizeof(F_DLL);
 218         case ALIEN_TYPE:
 219                 return sizeof(F_ALIEN);
 220         case WRAPPER_TYPE:
 221                 return sizeof(F_WRAPPER);
 222         case CALLSTACK_TYPE:
 223                 return callstack_size(
 224                         untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
 225         default:
 226                 critical_error("Invalid header",pointer);
 227                 return -1; /* can't happen */
 228         }
 229 }
 230
 231 void primitive_size(void)
 232 {
 233         box_unsigned_cell(object_size(dpop()));
 234 }
 235
 236 /* Push memory usage statistics in data heap */
 237 void primitive_data_room(void)
 238 {
 239         F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
 240         int gen;
 241
 242         dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
 243         dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
 244
 245         for(gen = 0; gen < data_heap->gen_count; gen++)
 246         {
 247                 F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
 248                 set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
 249                 set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
 250         }
 251
 252         dpush(tag_object(a));
 253 }
 254
 255 /* Disables GC and activates next-object ( -- obj ) primitive */
 256 void begin_scan(void)
 257 {
 258         heap_scan_ptr = data_heap->generations[TENURED].start;
 259         gc_off = true;
 260 }
 261
 262 void primitive_begin_scan(void)
 263 {
 264         gc();
 265         begin_scan();
 266 }
 267
 268 CELL next_object(void)
 269 {
 270         if(!gc_off)
 271                 general_error(ERROR_HEAP_SCAN,F,F,NULL);
 272
 273         CELL value = get(heap_scan_ptr);
 274         CELL obj = heap_scan_ptr;
 275         CELL type;
 276
 277         if(heap_scan_ptr >= data_heap->generations[TENURED].here)
 278                 return F;
 279
 280         type = untag_header(value);
 281         heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 282
 283         return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
 284 }
 285
 286 /* Push object at heap scan cursor and advance; pushes f when done */
 287 void primitive_next_object(void)
 288 {
 289         dpush(next_object());
 290 }
 291
 292 /* Re-enables GC */
 293 void primitive_end_scan(void)
 294 {
 295         gc_off = false;
 296 }
 297
 298 /* Scan all the objects in the card */
 299 void copy_card(F_CARD *ptr, CELL gen, CELL here)
 300 {
 301         CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
 302         CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
 303
 304         if(here < card_end)
 305                 card_end = here;
 306
 307         copy_reachable_objects(card_scan,&card_end);
 308
 309         cards_scanned++;
 310 }
 311
 312 void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
 313 {
 314         F_CARD *first_card = DECK_TO_CARD(deck);
 315         F_CARD *last_card = DECK_TO_CARD(deck + 1);
 316
 317         CELL here = data_heap->generations[gen].here;
 318
 319         u32 *quad_ptr;
 320         u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
 321
 322         for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
 323         {
 324                 if(*quad_ptr & quad_mask)
 325                 {
 326                         F_CARD *ptr = (F_CARD *)quad_ptr;
 327
 328                         int card;
 329                         for(card = 0; card < 4; card++)
 330                         {
 331                                 if(ptr[card] & mask)
 332                                 {
 333                                         copy_card(&ptr[card],gen,here);
 334                                         ptr[card] &= ~unmask;
 335                                 }
 336                         }
 337                 }
 338         }
 339
 340         decks_scanned++;
 341 }
 342
 343 /* Copy all newspace objects referenced from marked cards to the destination */
 344 void copy_gen_cards(CELL gen)
 345 {
 346         F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
 347         F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
 348
 349         F_CARD mask, unmask;
 350
 351         /* if we are collecting the nursery, we care about old->nursery pointers
 352         but not old->aging pointers */
 353         if(collecting_gen == NURSERY)
 354         {
 355                 mask = CARD_POINTS_TO_NURSERY;
 356
 357                 /* after the collection, no old->nursery pointers remain
 358                 anywhere, but old->aging pointers might remain in tenured
 359                 space */
 360                 if(gen == TENURED)
 361                         unmask = CARD_POINTS_TO_NURSERY;
 362                 /* after the collection, all cards in aging space can be
 363                 cleared */
 364                 else if(HAVE_AGING_P && gen == AGING)
 365                         unmask = CARD_MARK_MASK;
 366                 else
 367                 {
 368                         critical_error("bug in copy_gen_cards",gen);
 369                         return;
 370                 }
 371         }
 372         /* if we are collecting aging space into tenured space, we care about
 373         all old->nursery and old->aging pointers. no old->aging pointers can
 374         remain */
 375         else if(HAVE_AGING_P && collecting_gen == AGING)
 376         {
 377                 if(collecting_aging_again)
 378                 {
 379                         mask = CARD_POINTS_TO_AGING;
 380                         unmask = CARD_MARK_MASK;
 381                 }
 382                 /* after we collect aging space into the aging semispace, no
 383                 old->nursery pointers remain but tenured space might still have
 384                 pointers to aging space. */
 385                 else
 386                 {
 387                         mask = CARD_POINTS_TO_AGING;
 388                         unmask = CARD_POINTS_TO_NURSERY;
 389                 }
 390         }
 391         else
 392         {
 393                 critical_error("bug in copy_gen_cards",gen);
 394                 return;
 395         }
 396
 397         F_DECK *ptr;
 398
 399         for(ptr = first_deck; ptr < last_deck; ptr++)
 400         {
 401                 if(*ptr & mask)
 402                 {
 403                         copy_card_deck(ptr,gen,mask,unmask);
 404                         *ptr &= ~unmask;
 405                 }
 406         }
 407 }
 408
 409 /* Scan cards in all generations older than the one being collected, copying
 410 old->new references */
 411 void copy_cards(void)
 412 {
 413         int i;
 414         for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 415                 copy_gen_cards(i);
 416 }
 417
 418 /* Copy all tagged pointers in a range of memory */
 419 void copy_stack_elements(F_SEGMENT *region, CELL top)
 420 {
 421         CELL ptr = region->start;
 422
 423         for(; ptr <= top; ptr += CELLS)
 424                 copy_handle((CELL*)ptr);
 425 }
 426
 427 void copy_stack_frame_step(F_STACK_FRAME *frame)
 428 {
 429         mark_code_block(frame_code(frame));
 430 }
 431
 432 void copy_callstack_roots(F_CONTEXT *stacks)
 433 {
 434         if(collecting_gen == TENURED)
 435         {
 436                 CELL top = (CELL)stacks->callstack_top;
 437                 CELL bottom = (CELL)stacks->callstack_bottom;
 438
 439                 iterate_callstack(top,bottom,copy_stack_frame_step);
 440         }
 441 }
 442
 443 void copy_registered_locals(void)
 444 {
 445         CELL ptr = gc_locals_region->start;
 446
 447         for(; ptr <= gc_locals; ptr += CELLS)
 448                 copy_handle(*(CELL **)ptr);
 449 }
 450
 451 /* Copy roots over at the start of GC, namely various constants, stacks,
 452 the user environment and extra roots registered with REGISTER_ROOT */
 453 void copy_roots(void)
 454 {
 455         copy_handle(&T);
 456         copy_handle(&bignum_zero);
 457         copy_handle(&bignum_pos_one);
 458         copy_handle(&bignum_neg_one);
 459
 460         copy_registered_locals();
 461         copy_stack_elements(extra_roots_region,extra_roots);
 462
 463         save_stacks();
 464         F_CONTEXT *stacks = stack_chain;
 465
 466         while(stacks)
 467         {
 468                 copy_stack_elements(stacks->datastack_region,stacks->datastack);
 469                 copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
 470
 471                 copy_handle(&stacks->catchstack_save);
 472                 copy_handle(&stacks->current_callback_save);
 473
 474                 copy_callstack_roots(stacks);
 475
 476                 stacks = stacks->next;
 477         }
 478
 479         int i;
 480         for(i = 0; i < USER_ENV; i++)
 481                 copy_handle(&userenv[i]);
 482 }
 483
 484 /* Given a pointer to oldspace, copy it to newspace */
 485 INLINE void *copy_untagged_object(void *pointer, CELL size)
 486 {
 487         if(newspace->here + size >= newspace->end)
 488                 longjmp(gc_jmp,1);
 489         allot_barrier(newspace->here);
 490         void *newpointer = allot_zone(newspace,size);
 491
 492         F_GC_STATS *s = &gc_stats[collecting_gen];
 493         s->object_count++;
 494         s->bytes_copied += size;
 495
 496         memcpy(newpointer,pointer,size);
 497         return newpointer;
 498 }
 499
 500 INLINE void forward_object(CELL pointer, CELL newpointer)
 501 {
 502         if(pointer != newpointer)
 503                 put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
 504 }
 505
 506 INLINE CELL copy_object_impl(CELL pointer)
 507 {
 508         CELL newpointer = (CELL)copy_untagged_object(
 509                 (void*)UNTAG(pointer),
 510                 object_size(pointer));
 511         forward_object(pointer,newpointer);
 512         return newpointer;
 513 }
 514
 515 /* Follow a chain of forwarding pointers */
 516 CELL resolve_forwarding(CELL untagged, CELL tag)
 517 {
 518         CELL header = get(untagged);
 519         /* another forwarding pointer */
 520         if(TAG(header) == GC_COLLECTED)
 521                 return resolve_forwarding(UNTAG(header),tag);
 522         /* we've found the destination */
 523         else
 524         {
 525                 CELL pointer = RETAG(untagged,tag);
 526                 if(should_copy(untagged))
 527                         pointer = RETAG(copy_object_impl(pointer),tag);
 528                 return pointer;
 529         }
 530 }
 531
 532 /* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 533 If the object has already been copied, return the forwarding
 534 pointer address without copying anything; otherwise, install
 535 a new forwarding pointer. */
 536 INLINE CELL copy_object(CELL pointer)
 537 {
 538         CELL tag = TAG(pointer);
 539         CELL header = get(UNTAG(pointer));
 540
 541         if(TAG(header) == GC_COLLECTED)
 542                 return resolve_forwarding(UNTAG(header),tag);
 543         else
 544                 return RETAG(copy_object_impl(pointer),tag);
 545 }
 546
 547 void copy_handle(CELL *handle)
 548 {
 549         CELL pointer = *handle;
 550
 551         if(!immediate_p(pointer) && should_copy(pointer))
 552                 *handle = copy_object(pointer);
 553 }
 554
 555 /* The number of cells from the start of the object which should be scanned by
 556 the GC. Some types have a binary payload at the end (string, word, DLL) which
 557 we ignore. */
 558 CELL binary_payload_start(CELL pointer)
 559 {
 560         F_TUPLE *tuple;
 561         F_TUPLE_LAYOUT *layout;
 562
 563         switch(untag_header(get(pointer)))
 564         {
 565         /* these objects do not refer to other objects at all */
 566         case FLOAT_TYPE:
 567         case BYTE_ARRAY_TYPE:
 568         case BIGNUM_TYPE:
 569         case CALLSTACK_TYPE:
 570                 return 0;
 571         /* these objects have some binary data at the end */
 572         case WORD_TYPE:
 573                 return sizeof(F_WORD) - CELLS * 3;
 574         case ALIEN_TYPE:
 575                 return CELLS * 3;
 576         case DLL_TYPE:
 577                 return CELLS * 2;
 578         case QUOTATION_TYPE:
 579                 return sizeof(F_QUOTATION) - CELLS * 2;
 580         case STRING_TYPE:
 581                 return sizeof(F_STRING);
 582         /* everything else consists entirely of pointers */
 583         case ARRAY_TYPE:
 584                 return array_size(array_capacity((F_ARRAY*)pointer));
 585         case TUPLE_TYPE:
 586                 tuple = untag_object(pointer);
 587                 layout = untag_object(tuple->layout);
 588                 return tuple_size(layout);
 589         case RATIO_TYPE:
 590                 return sizeof(F_RATIO);
 591         case COMPLEX_TYPE:
 592                 return sizeof(F_COMPLEX);
 593         case WRAPPER_TYPE:
 594                 return sizeof(F_WRAPPER);
 595         default:
 596                 critical_error("Invalid header",pointer);
 597                 return -1; /* can't happen */
 598         }
 599 }
 600
 601 void do_code_slots(CELL scan)
 602 {
 603         F_WORD *word;
 604         F_QUOTATION *quot;
 605         F_CALLSTACK *stack;
 606
 607         switch(object_type(scan))
 608         {
 609         case WORD_TYPE:
 610                 word = (F_WORD *)scan;
 611                 mark_code_block(word->code);
 612                 if(word->profiling)
 613                         mark_code_block(word->profiling);
 614                 break;
 615         case QUOTATION_TYPE:
 616                 quot = (F_QUOTATION *)scan;
 617                 if(quot->compiledp != F)
 618                         mark_code_block(quot->code);
 619                 break;
 620         case CALLSTACK_TYPE:
 621                 stack = (F_CALLSTACK *)scan;
 622                 iterate_callstack_object(stack,copy_stack_frame_step);
 623                 break;
 624         }
 625 }
 626
 627 CELL copy_next_from_nursery(CELL scan)
 628 {
 629         CELL *obj = (CELL *)scan;
 630         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 631
 632         if(obj != end)
 633         {
 634                 obj++;
 635
 636                 CELL nursery_start = nursery.start;
 637                 CELL nursery_end = nursery.end;
 638
 639                 for(; obj < end; obj++)
 640                 {
 641                         CELL pointer = *obj;
 642
 643                         if(!immediate_p(pointer)
 644                                 && (pointer >= nursery_start && pointer < nursery_end))
 645                                 *obj = copy_object(pointer);
 646                 }
 647         }
 648
 649         return scan + untagged_object_size(scan);
 650 }
 651
 652 CELL copy_next_from_aging(CELL scan)
 653 {
 654         CELL *obj = (CELL *)scan;
 655         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 656
 657         if(obj != end)
 658         {
 659                 obj++;
 660
 661                 CELL tenured_start = data_heap->generations[TENURED].start;
 662                 CELL tenured_end = data_heap->generations[TENURED].end;
 663
 664                 CELL newspace_start = newspace->start;
 665                 CELL newspace_end = newspace->end;
 666
 667                 for(; obj < end; obj++)
 668                 {
 669                         CELL pointer = *obj;
 670
 671                         if(!immediate_p(pointer)
 672                                 && !(pointer >= newspace_start && pointer < newspace_end)
 673                                 && !(pointer >= tenured_start && pointer < tenured_end))
 674                                 *obj = copy_object(pointer);
 675                 }
 676         }
 677
 678         return scan + untagged_object_size(scan);
 679 }
 680
 681 CELL copy_next_from_tenured(CELL scan)
 682 {
 683         CELL *obj = (CELL *)scan;
 684         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 685
 686         if(obj != end)
 687         {
 688                 obj++;
 689
 690                 CELL newspace_start = newspace->start;
 691                 CELL newspace_end = newspace->end;
 692
 693                 for(; obj < end; obj++)
 694                 {
 695                         CELL pointer = *obj;
 696
 697                         if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
 698                                 *obj = copy_object(pointer);
 699                 }
 700         }
 701
 702         do_code_slots(scan);
 703
 704         return scan + untagged_object_size(scan);
 705 }
 706
 707 void copy_reachable_objects(CELL scan, CELL *end)
 708 {
 709         if(HAVE_NURSERY_P && collecting_gen == NURSERY)
 710         {
 711                 while(scan < *end)
 712                         scan = copy_next_from_nursery(scan);
 713         }
 714         else if(HAVE_AGING_P && collecting_gen == AGING)
 715         {
 716                 while(scan < *end)
 717                         scan = copy_next_from_aging(scan);
 718         }
 719         else if(collecting_gen == TENURED)
 720         {
 721                 while(scan < *end)
 722                         scan = copy_next_from_tenured(scan);
 723         }
 724 }
 725
 726 INLINE void reset_generation(CELL i)
 727 {
 728         F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
 729
 730         z->here = z->start;
 731         if(secure_gc)
 732                 memset((void*)z->start,69,z->size);
 733 }
 734
 735 /* After garbage collection, any generations which are now empty need to have
 736 their allocation pointers and cards reset. */
 737 void reset_generations(CELL from, CELL to)
 738 {
 739         CELL i;
 740         for(i = from; i <= to; i++)
 741                 reset_generation(i);
 742
 743         clear_cards(from,to);
 744         clear_decks(from,to);
 745         clear_allot_markers(from,to);
 746 }
 747
 748 /* Prepare to start copying reachable objects into an unused zone */
 749 void begin_gc(CELL requested_bytes)
 750 {
 751         if(growing_data_heap)
 752         {
 753                 if(collecting_gen != TENURED)
 754                         critical_error("Invalid parameters to begin_gc",0);
 755
 756                 old_data_heap = data_heap;
 757                 set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
 758                 newspace = &data_heap->generations[TENURED];
 759         }
 760         else if(collecting_accumulation_gen_p())
 761         {
 762                 /* when collecting one of these generations, rotate it
 763                 with the semispace */
 764                 F_ZONE z = data_heap->generations[collecting_gen];
 765                 data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
 766                 data_heap->semispaces[collecting_gen] = z;
 767                 reset_generation(collecting_gen);
 768                 newspace = &data_heap->generations[collecting_gen];
 769                 clear_cards(collecting_gen,collecting_gen);
 770                 clear_decks(collecting_gen,collecting_gen);
 771                 clear_allot_markers(collecting_gen,collecting_gen);
 772         }
 773         else
 774         {
 775                 /* when collecting a younger generation, we copy
 776                 reachable objects to the next oldest generation,
 777                 so we set the newspace so the next generation. */
 778                 newspace = &data_heap->generations[collecting_gen + 1];
 779         }
 780 }
 781
 782 void end_gc(CELL gc_elapsed)
 783 {
 784         F_GC_STATS *s = &gc_stats[collecting_gen];
 785
 786         s->collections++;
 787         s->gc_time += gc_elapsed;
 788         if(s->max_gc_time < gc_elapsed)
 789                 s->max_gc_time = gc_elapsed;
 790
 791         if(growing_data_heap)
 792         {
 793                 dealloc_data_heap(old_data_heap);
 794                 old_data_heap = NULL;
 795                 growing_data_heap = false;
 796         }
 797
 798         if(collecting_accumulation_gen_p())
 799         {
 800                 /* all younger generations except are now empty.
 801                 if collecting_gen == NURSERY here, we only have 1 generation;
 802                 old-school Cheney collector */
 803                 if(collecting_gen != NURSERY)
 804                         reset_generations(NURSERY,collecting_gen - 1);
 805         }
 806         else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
 807         {
 808                 nursery.here = nursery.start;
 809         }
 810         else
 811         {
 812                 /* all generations up to and including the one
 813                 collected are now empty */
 814                 reset_generations(NURSERY,collecting_gen);
 815         }
 816
 817         if(collecting_gen == TENURED)
 818         {
 819                 /* now that all reachable code blocks have been marked,
 820                 deallocate the rest */
 821                 free_unmarked(&code_heap);
 822         }
 823
 824         collecting_aging_again = false;
 825 }
 826
 827 /* Collect gen and all younger generations.
 828 If growing_data_heap_ is true, we must grow the data heap to such a size that
 829 an allocation of requested_bytes won't fail */
 830 void garbage_collection(CELL gen,
 831         bool growing_data_heap_,
 832         CELL requested_bytes)
 833 {
 834         if(gc_off)
 835         {
 836                 critical_error("GC disabled",gen);
 837                 return;
 838         }
 839
 840         s64 start = current_micros();
 841
 842         performing_gc = true;
 843         growing_data_heap = growing_data_heap_;
 844         collecting_gen = gen;
 845
 846         /* we come back here if a generation is full */
 847         if(setjmp(gc_jmp))
 848         {
 849                 /* We have no older generations we can try collecting, so we
 850                 resort to growing the data heap */
 851                 if(collecting_gen == TENURED)
 852                 {
 853                         growing_data_heap = true;
 854
 855                         /* see the comment in unmark_marked() */
 856                         unmark_marked(&code_heap);
 857                 }
 858                 /* we try collecting AGING space twice before going on to
 859                 collect TENURED */
 860                 else if(HAVE_AGING_P
 861                         && collecting_gen == AGING
 862                         && !collecting_aging_again)
 863                 {
 864                         collecting_aging_again = true;
 865                 }
 866                 /* Collect the next oldest generation */
 867                 else
 868                 {
 869                         collecting_gen++;
 870                 }
 871         }
 872
 873         begin_gc(requested_bytes);
 874
 875         /* initialize chase pointer */
 876         CELL scan = newspace->here;
 877
 878         /* collect objects referenced from stacks and environment */
 879         copy_roots();
 880         /* collect objects referenced from older generations */
 881         copy_cards();
 882         /* do some tracing */
 883         copy_reachable_objects(scan,&newspace->here);
 884
 885         /* don't scan code heap unless it has pointers to this
 886         generation or younger */
 887         if(collecting_gen >= last_code_heap_scan)
 888         {
 889                 code_heap_scans++;
 890
 891                 if(collecting_gen == TENURED)
 892                         update_code_heap_roots();
 893                 else
 894                         copy_code_heap_roots();
 895
 896                 if(collecting_accumulation_gen_p())
 897                         last_code_heap_scan = collecting_gen;
 898                 else
 899                         last_code_heap_scan = collecting_gen + 1;
 900         }
 901
 902         CELL gc_elapsed = (current_micros() - start);
 903
 904         end_gc(gc_elapsed);
 905
 906         performing_gc = false;
 907 }
 908
 909 void gc(void)
 910 {
 911         garbage_collection(TENURED,false,0);
 912 }
 913
 914 void minor_gc(void)
 915 {
 916         garbage_collection(NURSERY,false,0);
 917 }
 918
 919 void primitive_gc(void)
 920 {
 921         gc();
 922 }
 923
 924 void primitive_gc_stats(void)
 925 {
 926         GROWABLE_ARRAY(stats);
 927
 928         CELL i;
 929         u64 total_gc_time = 0;
 930
 931         for(i = 0; i < MAX_GEN_COUNT; i++)
 932         {
 933                 F_GC_STATS *s = &gc_stats[i];
 934                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
 935                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
 936                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
 937                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
 938                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
 939                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
 940
 941                 total_gc_time += s->gc_time;
 942         }
 943
 944         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time)));
 945         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
 946         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
 947         GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
 948
 949         GROWABLE_ARRAY_TRIM(stats);
 950         dpush(stats);
 951 }
 952
 953 void primitive_gc_reset(void)
 954 {
 955         gc_reset();
 956 }
 957
 958 void primitive_become(void)
 959 {
 960         F_ARRAY *new_objects = untag_array(dpop());
 961         F_ARRAY *old_objects = untag_array(dpop());
 962
 963         CELL capacity = array_capacity(new_objects);
 964         if(capacity != array_capacity(old_objects))
 965                 critical_error("bad parameters to become",0);
 966
 967         CELL i;
 968
 969         for(i = 0; i < capacity; i++)
 970         {
 971                 CELL old_obj = array_nth(old_objects,i);
 972                 CELL new_obj = array_nth(new_objects,i);
 973
 974                 forward_object(old_obj,new_obj);
 975         }
 976
 977         gc();
 978
 979         compile_all_words();
 980 }
 981
 982 CELL find_all_words(void)
 983 {
 984         GROWABLE_ARRAY(words);
 985
 986         begin_scan();
 987
 988         CELL obj;
 989         while((obj = next_object()) != F)
 990         {
 991                 if(type_of(obj) == WORD_TYPE)
 992                         GROWABLE_ARRAY_ADD(words,obj);
 993         }
 994
 995         /* End heap scan */
 996         gc_off = false;
 997
 998         GROWABLE_ARRAY_TRIM(words);
 999
1000         return words;
1001 }