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_cards_offset(void)
  12 {
  13         cards_offset = (CELL)data_heap->cards
  14                 - (data_heap->segment->start >> CARD_BITS);
  15 }
  16
  17 F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
  18 {
  19         young_size = align_page(young_size);
  20         aging_size = align_page(aging_size);
  21
  22         F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
  23         data_heap->young_size = young_size;
  24         data_heap->aging_size = aging_size;
  25         data_heap->gen_count = gens;
  26
  27         CELL total_size;
  28         if(data_heap->gen_count == 1)
  29                 total_size = 2 * aging_size;
  30         else if(data_heap->gen_count == 2)
  31                 total_size = (gens - 1) * young_size + 2 * aging_size;
  32         else if(data_heap->gen_count == 3)
  33                 total_size = gens * young_size + 2 * aging_size;
  34         else
  35         {
  36                 fatal_error("Invalid number of generations",data_heap->gen_count);
  37                 return NULL; /* can't happen */
  38         }
  39
  40         data_heap->segment = alloc_segment(total_size);
  41
  42         data_heap->generations = safe_malloc(sizeof(F_ZONE) * gens);
  43         data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * gens);
  44
  45         CELL cards_size = total_size / CARD_SIZE;
  46         data_heap->cards = safe_malloc(cards_size);
  47         data_heap->cards_end = data_heap->cards + cards_size;
  48
  49         CELL alloter = data_heap->segment->start;
  50
  51         alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
  52
  53         alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter);
  54         alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter);
  55
  56         int i;
  57
  58         if(data_heap->gen_count > 2)
  59         {
  60                 alloter = init_zone(&data_heap->generations[AGING],young_size,alloter);
  61                 alloter = init_zone(&data_heap->semispaces[AGING],young_size,alloter);
  62
  63                 for(i = gens - 3; i >= 0; i--)
  64                 {
  65                         alloter = init_zone(&data_heap->generations[i],
  66                                 young_size,alloter);
  67                 }
  68         }
  69         else
  70         {
  71                 for(i = gens - 2; i >= 0; i--)
  72                 {
  73                         alloter = init_zone(&data_heap->generations[i],
  74                                 young_size,alloter);
  75                 }
  76         }
  77
  78         if(alloter != data_heap->segment->end)
  79                 critical_error("Bug in alloc_data_heap",alloter);
  80
  81         return data_heap;
  82 }
  83
  84 F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
  85 {
  86         CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
  87         CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
  88
  89         return alloc_data_heap(data_heap->gen_count,
  90                 new_young_size,
  91                 new_aging_size);
  92 }
  93
  94 void dealloc_data_heap(F_DATA_HEAP *data_heap)
  95 {
  96         dealloc_segment(data_heap->segment);
  97         free(data_heap->generations);
  98         free(data_heap->semispaces);
  99         free(data_heap->cards);
 100         free(data_heap);
 101 }
 102
 103 /* Every card stores the offset of the first object in that card, which must be
 104 cleared when a generation has been cleared */
 105 void clear_cards(CELL from, CELL to)
 106 {
 107         /* NOTE: reverse order due to heap layout. */
 108         F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
 109         F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start);
 110         for(; ptr < last_card; ptr++)
 111                 clear_card(ptr);
 112 }
 113
 114 void set_data_heap(F_DATA_HEAP *data_heap_)
 115 {
 116         data_heap = data_heap_;
 117         nursery = &data_heap->generations[NURSERY];
 118         init_cards_offset();
 119         clear_cards(NURSERY,TENURED);
 120 }
 121
 122 void init_data_heap(CELL gens,
 123         CELL young_size,
 124         CELL aging_size,
 125         bool secure_gc_)
 126 {
 127         set_data_heap(alloc_data_heap(gens,young_size,aging_size));
 128
 129         extra_roots_region = alloc_segment(getpagesize());
 130         extra_roots = extra_roots_region->start - CELLS;
 131
 132         gc_time = 0;
 133         minor_collections = 0;
 134         cards_scanned = 0;
 135         secure_gc = secure_gc_;
 136 }
 137
 138 /* Size of the object pointed to by a tagged pointer */
 139 CELL object_size(CELL tagged)
 140 {
 141         if(immediate_p(tagged))
 142                 return 0;
 143         else
 144                 return untagged_object_size(UNTAG(tagged));
 145 }
 146
 147 /* Size of the object pointed to by an untagged pointer */
 148 CELL untagged_object_size(CELL pointer)
 149 {
 150         return align8(unaligned_object_size(pointer));
 151 }
 152
 153 /* Size of the data area of an object pointed to by an untagged pointer */
 154 CELL unaligned_object_size(CELL pointer)
 155 {
 156         switch(untag_header(get(pointer)))
 157         {
 158         case ARRAY_TYPE:
 159         case TUPLE_TYPE:
 160         case BIGNUM_TYPE:
 161                 return array_size(array_capacity((F_ARRAY*)pointer));
 162         case BYTE_ARRAY_TYPE:
 163                 return byte_array_size(
 164                         byte_array_capacity((F_BYTE_ARRAY*)pointer));
 165         case BIT_ARRAY_TYPE:
 166                 return bit_array_size(
 167                         bit_array_capacity((F_BIT_ARRAY*)pointer));
 168         case FLOAT_ARRAY_TYPE:
 169                 return float_array_size(
 170                         float_array_capacity((F_FLOAT_ARRAY*)pointer));
 171         case STRING_TYPE:
 172                 return string_size(string_capacity((F_STRING*)pointer));
 173         case QUOTATION_TYPE:
 174                 return sizeof(F_QUOTATION);
 175         case WORD_TYPE:
 176                 return sizeof(F_WORD);
 177         case HASHTABLE_TYPE:
 178                 return sizeof(F_HASHTABLE);
 179         case VECTOR_TYPE:
 180                 return sizeof(F_VECTOR);
 181         case SBUF_TYPE:
 182                 return sizeof(F_SBUF);
 183         case RATIO_TYPE:
 184                 return sizeof(F_RATIO);
 185         case FLOAT_TYPE:
 186                 return sizeof(F_FLOAT);
 187         case COMPLEX_TYPE:
 188                 return sizeof(F_COMPLEX);
 189         case DLL_TYPE:
 190                 return sizeof(F_DLL);
 191         case ALIEN_TYPE:
 192                 return sizeof(F_ALIEN);
 193         case WRAPPER_TYPE:
 194                 return sizeof(F_WRAPPER);
 195         case CURRY_TYPE:
 196                 return sizeof(F_CURRY);
 197         case CALLSTACK_TYPE:
 198                 return callstack_size(
 199                         untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
 200         default:
 201                 critical_error("Invalid header",pointer);
 202                 return -1; /* can't happen */
 203         }
 204 }
 205
 206 DEFINE_PRIMITIVE(size)
 207 {
 208         box_unsigned_cell(object_size(dpop()));
 209 }
 210
 211 /* Push memory usage statistics in data heap */
 212 DEFINE_PRIMITIVE(data_room)
 213 {
 214         F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
 215         int gen;
 216
 217         dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
 218
 219         for(gen = 0; gen < data_heap->gen_count; gen++)
 220         {
 221                 F_ZONE *z = &data_heap->generations[gen];
 222                 set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
 223                 set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
 224         }
 225
 226         dpush(tag_object(a));
 227 }
 228
 229 /* Disables GC and activates next-object ( -- obj ) primitive */
 230 void begin_scan(void)
 231 {
 232         heap_scan_ptr = data_heap->generations[TENURED].start;
 233         gc_off = true;
 234 }
 235
 236 DEFINE_PRIMITIVE(begin_scan)
 237 {
 238         data_gc();
 239         begin_scan();
 240 }
 241
 242 CELL next_object(void)
 243 {
 244         if(!gc_off)
 245                 general_error(ERROR_HEAP_SCAN,F,F,NULL);
 246
 247         CELL value = get(heap_scan_ptr);
 248         CELL obj = heap_scan_ptr;
 249         CELL type;
 250
 251         if(heap_scan_ptr >= data_heap->generations[TENURED].here)
 252                 return F;
 253
 254         type = untag_header(value);
 255         heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 256
 257         return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
 258 }
 259
 260 /* Push object at heap scan cursor and advance; pushes f when done */
 261 DEFINE_PRIMITIVE(next_object)
 262 {
 263         dpush(next_object());
 264 }
 265
 266 /* Re-enables GC */
 267 DEFINE_PRIMITIVE(end_scan)
 268 {
 269         gc_off = false;
 270 }
 271
 272 /* Scan all the objects in the card */
 273 INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
 274 {
 275         F_CARD c = *ptr;
 276         CELL offset = (c & CARD_BASE_MASK);
 277
 278         if(offset == CARD_BASE_MASK)
 279         {
 280                 if(c == 0xff)
 281                         critical_error("bad card",(CELL)ptr);
 282                 else
 283                         return;
 284         }
 285
 286         CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
 287         CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
 288
 289         while(card_scan < card_end && card_scan < here)
 290                 card_scan = collect_next(card_scan);
 291
 292         cards_scanned++;
 293 }
 294
 295 /* Copy all newspace objects referenced from marked cards to the destination */
 296 INLINE void collect_gen_cards(CELL gen)
 297 {
 298         F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start);
 299         CELL here = data_heap->generations[gen].here;
 300         F_CARD *last_card = ADDR_TO_CARD(here - 1);
 301
 302         CELL mask, unmask;
 303
 304         /* if we are collecting the nursery, we care about old->nursery pointers
 305         but not old->aging pointers */
 306         if(collecting_gen == NURSERY)
 307         {
 308                 mask = CARD_POINTS_TO_NURSERY;
 309
 310                 /* after the collection, no old->nursery pointers remain
 311                 anywhere, but old->aging pointers might remain in tenured
 312                 space */
 313                 if(gen == TENURED)
 314                         unmask = CARD_POINTS_TO_NURSERY;
 315                 /* after the collection, all cards in aging space can be
 316                 cleared */
 317                 else if(HAVE_AGING_P && gen == AGING)
 318                         unmask = CARD_MARK_MASK;
 319                 else
 320                 {
 321                         critical_error("bug in collect_gen_cards",gen);
 322                         return;
 323                 }
 324         }
 325         /* if we are collecting aging space into tenured space, we care about
 326         all old->nursery and old->aging pointers. no old->aging pointers can
 327         remain */
 328         else if(HAVE_AGING_P && collecting_gen == AGING)
 329         {
 330                 if(collecting_aging_again)
 331                 {
 332                         mask = CARD_POINTS_TO_AGING;
 333                         unmask = CARD_MARK_MASK;
 334                 }
 335                 /* after we collect aging space into the aging semispace, no
 336                 old->nursery pointers remain but tenured space might still have
 337                 pointers to aging space. */
 338                 else
 339                 {
 340                         mask = CARD_POINTS_TO_AGING;
 341                         unmask = CARD_POINTS_TO_NURSERY;
 342                 }
 343         }
 344         else
 345         {
 346                 critical_error("bug in collect_gen_cards",gen);
 347                 return;
 348         }
 349
 350         for(; ptr <= last_card; ptr++)
 351         {
 352                 if(*ptr & mask)
 353                 {
 354                         collect_card(ptr,gen,here);
 355                         *ptr &= ~unmask;
 356                 }
 357         }
 358 }
 359
 360 /* Scan cards in all generations older than the one being collected, copying
 361 old->new references */
 362 void collect_cards(void)
 363 {
 364         int i;
 365         for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 366                 collect_gen_cards(i);
 367 }
 368
 369 /* Copy all tagged pointers in a range of memory */
 370 void collect_stack(F_SEGMENT *region, CELL top)
 371 {
 372         CELL bottom = region->start;
 373         CELL ptr;
 374
 375         for(ptr = bottom; ptr <= top; ptr += CELLS)
 376                 copy_handle((CELL*)ptr);
 377 }
 378
 379 void collect_stack_frame(F_STACK_FRAME *frame)
 380 {
 381         if(frame_type(frame) == QUOTATION_TYPE)
 382         {
 383                 CELL scan = frame->scan - frame->array;
 384                 copy_handle(&frame->array);
 385                 frame->scan = scan + frame->array;
 386         }
 387
 388         if(collecting_code)
 389                 recursive_mark(frame->xt);
 390 }
 391
 392 /* The base parameter allows us to adjust for a heap-allocated
 393 callstack snapshot */
 394 void collect_callstack(F_CONTEXT *stacks)
 395 {
 396         CELL top = (CELL)stacks->callstack_top;
 397         CELL bottom = (CELL)stacks->callstack_bottom;
 398         CELL base = bottom;
 399         iterate_callstack(top,bottom,base,collect_stack_frame);
 400 }
 401
 402 /* Copy roots over at the start of GC, namely various constants, stacks,
 403 the user environment and extra roots registered with REGISTER_ROOT */
 404 void collect_roots(void)
 405 {
 406         int i;
 407         F_CONTEXT *stacks;
 408
 409         copy_handle(&T);
 410         copy_handle(&bignum_zero);
 411         copy_handle(&bignum_pos_one);
 412         copy_handle(&bignum_neg_one);
 413
 414         collect_stack(extra_roots_region,extra_roots);
 415
 416         save_stacks();
 417         stacks = stack_chain;
 418
 419         while(stacks)
 420         {
 421                 collect_stack(stacks->datastack_region,stacks->datastack);
 422                 collect_stack(stacks->retainstack_region,stacks->retainstack);
 423
 424                 copy_handle(&stacks->catchstack_save);
 425                 copy_handle(&stacks->current_callback_save);
 426
 427                 collect_callstack(stacks);
 428
 429                 stacks = stacks->next;
 430         }
 431
 432         for(i = 0; i < USER_ENV; i++)
 433                 copy_handle(&userenv[i]);
 434 }
 435
 436 /* Given a pointer to oldspace, copy it to newspace */
 437 INLINE void *copy_untagged_object(void *pointer, CELL size)
 438 {
 439         void *newpointer;
 440         if(newspace->here + size >= newspace->end)
 441                 longjmp(gc_jmp,1);
 442         allot_barrier(newspace->here);
 443         newpointer = allot_zone(newspace,size);
 444         memcpy(newpointer,pointer,size);
 445         return newpointer;
 446 }
 447
 448 INLINE void forward_object(CELL pointer, CELL newpointer)
 449 {
 450         put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
 451 }
 452
 453 INLINE CELL copy_object_impl(CELL pointer)
 454 {
 455         CELL newpointer = (CELL)copy_untagged_object(
 456                 (void*)UNTAG(pointer),
 457                 object_size(pointer));
 458         forward_object(pointer,newpointer);
 459         return newpointer;
 460 }
 461
 462 /* Follow a chain of forwarding pointers */
 463 CELL resolve_forwarding(CELL untagged, CELL tag)
 464 {
 465         CELL header = get(untagged);
 466         /* another forwarding pointer */
 467         if(TAG(header) == GC_COLLECTED)
 468                 return resolve_forwarding(UNTAG(header),tag);
 469         /* we've found the destination */
 470         else
 471         {
 472                 CELL pointer = RETAG(untagged,tag);
 473                 if(should_copy(untagged))
 474                         pointer = RETAG(copy_object_impl(pointer),tag);
 475                 return pointer;
 476         }
 477 }
 478
 479 /* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 480 If the object has already been copied, return the forwarding
 481 pointer address without copying anything; otherwise, install
 482 a new forwarding pointer. */
 483 INLINE CELL copy_object(CELL pointer)
 484 {
 485         CELL tag = TAG(pointer);
 486         CELL header = get(UNTAG(pointer));
 487
 488         if(TAG(header) == GC_COLLECTED)
 489                 return resolve_forwarding(UNTAG(header),tag);
 490         else
 491                 return RETAG(copy_object_impl(pointer),tag);
 492 }
 493
 494 void copy_handle(CELL *handle)
 495 {
 496         CELL pointer = *handle;
 497
 498         if(!immediate_p(pointer) && should_copy(pointer))
 499                 *handle = copy_object(pointer);
 500 }
 501
 502 /* The number of cells from the start of the object which should be scanned by
 503 the GC. Some types have a binary payload at the end (string, word, DLL) which
 504 we ignore. */
 505 CELL binary_payload_start(CELL pointer)
 506 {
 507         switch(untag_header(get(pointer)))
 508         {
 509         /* these objects do not refer to other objects at all */
 510         case STRING_TYPE:
 511         case FLOAT_TYPE:
 512         case BYTE_ARRAY_TYPE:
 513         case BIT_ARRAY_TYPE:
 514         case FLOAT_ARRAY_TYPE:
 515         case BIGNUM_TYPE:
 516         case CALLSTACK_TYPE:
 517                 return 0;
 518         /* these objects have some binary data at the end */
 519         case WORD_TYPE:
 520                 return sizeof(F_WORD) - CELLS;
 521         case ALIEN_TYPE:
 522                 return CELLS * 3;
 523         case DLL_TYPE:
 524                 return CELLS * 2;
 525         case QUOTATION_TYPE:
 526                 return sizeof(F_QUOTATION) - CELLS;
 527         /* everything else consists entirely of pointers */
 528         default:
 529                 return unaligned_object_size(pointer);
 530         }
 531 }
 532
 533 void collect_callstack_object(F_CALLSTACK *callstack)
 534 {
 535         iterate_callstack_object(callstack,collect_stack_frame);
 536 }
 537
 538 CELL collect_next(CELL scan)
 539 {
 540         do_slots(scan,copy_handle);
 541
 542         /* Special behaviors */
 543         F_WORD *word;
 544         F_QUOTATION *quot;
 545         F_CALLSTACK *stack;
 546
 547         switch(object_type(scan))
 548         {
 549         case WORD_TYPE:
 550                 word = (F_WORD *)scan;
 551                 if(collecting_code && word->compiledp != F)
 552                         recursive_mark(word->xt);
 553                 break;
 554         case QUOTATION_TYPE:
 555                 quot = (F_QUOTATION *)scan;
 556                 if(collecting_code && quot->xt != NULL)
 557                         recursive_mark(quot->xt);
 558                 break;
 559         case CALLSTACK_TYPE:
 560                 stack = (F_CALLSTACK *)scan;
 561                 collect_callstack_object(stack);
 562                 break;
 563         }
 564
 565         return scan + untagged_object_size(scan);
 566 }
 567
 568 INLINE void reset_generation(CELL i)
 569 {
 570         F_ZONE *z = &data_heap->generations[i];
 571         z->here = z->start;
 572         if(secure_gc)
 573                 memset((void*)z->start,69,z->size);
 574 }
 575
 576 /* After garbage collection, any generations which are now empty need to have
 577 their allocation pointers and cards reset. */
 578 void reset_generations(CELL from, CELL to)
 579 {
 580         CELL i;
 581         for(i = from; i <= to; i++) reset_generation(i);
 582         clear_cards(from,to);
 583 }
 584
 585 /* Prepare to start copying reachable objects into an unused zone */
 586 void begin_gc(CELL requested_bytes)
 587 {
 588         if(growing_data_heap)
 589         {
 590                 if(collecting_gen != TENURED)
 591                         critical_error("Invalid parameters to begin_gc",0);
 592
 593                 old_data_heap = data_heap;
 594                 set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
 595                 newspace = &data_heap->generations[collecting_gen];
 596         }
 597         else if(collecting_accumulation_gen_p())
 598         {
 599                 /* when collecting one of these generations, rotate it
 600                 with the semispace */
 601                 F_ZONE z = data_heap->generations[collecting_gen];
 602                 data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
 603                 data_heap->semispaces[collecting_gen] = z;
 604                 reset_generation(collecting_gen);
 605                 newspace = &data_heap->generations[collecting_gen];
 606                 clear_cards(collecting_gen,collecting_gen);
 607         }
 608         else
 609         {
 610                 /* when collecting a younger generation, we copy
 611                 reachable objects to the next oldest generation,
 612                 so we set the newspace so the next generation. */
 613                 newspace = &data_heap->generations[collecting_gen + 1];
 614         }
 615 }
 616
 617 void major_gc_message(void)
 618 {
 619         fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
 620                 collecting_code ? "Code and data" : "Data",
 621                 minor_collections,cards_scanned);
 622         fflush(stderr);
 623         minor_collections = 0;
 624         cards_scanned = 0;
 625 }
 626
 627 void end_gc(void)
 628 {
 629         if(growing_data_heap)
 630         {
 631                 dealloc_data_heap(old_data_heap);
 632                 old_data_heap = NULL;
 633                 growing_data_heap = false;
 634
 635                 fprintf(stderr,"*** Data heap resized to %lu bytes\n",
 636                         data_heap->segment->size);
 637         }
 638
 639         if(collecting_accumulation_gen_p())
 640         {
 641                 /* all younger generations except are now empty.
 642                 if collecting_gen == NURSERY here, we only have 1 generation;
 643                 old-school Cheney collector */
 644                 if(collecting_gen != NURSERY)
 645                         reset_generations(NURSERY,collecting_gen - 1);
 646
 647                 if(collecting_gen == TENURED)
 648                         major_gc_message();
 649                 else if(HAVE_AGING_P && collecting_gen == AGING)
 650                         minor_collections++;
 651         }
 652         else
 653         {
 654                 /* all generations up to and including the one
 655                 collected are now empty */
 656                 reset_generations(NURSERY,collecting_gen);
 657
 658                 minor_collections++;
 659         }
 660
 661         if(collecting_code)
 662         {
 663                 /* now that all reachable code blocks have been marked,
 664                 deallocate the rest */
 665                 free_unmarked(&code_heap);
 666         }
 667
 668         collecting_aging_again = false;
 669 }
 670
 671 /* Collect gen and all younger generations.
 672 If growing_data_heap_ is true, we must grow the data heap to such a size that
 673 an allocation of requested_bytes won't fail */
 674 void garbage_collection(CELL gen,
 675         bool code_gc,
 676         bool growing_data_heap_,
 677         CELL requested_bytes)
 678 {
 679         if(gc_off)
 680         {
 681                 critical_error("GC disabled",gen);
 682                 return;
 683         }
 684
 685         s64 start = current_millis();
 686
 687         performing_gc = true;
 688         collecting_code = code_gc;
 689         growing_data_heap = growing_data_heap_;
 690         collecting_gen = gen;
 691
 692         /* we come back here if a generation is full */
 693         if(setjmp(gc_jmp))
 694         {
 695                 /* We have no older generations we can try collecting, so we
 696                 resort to growing the data heap */
 697                 if(collecting_gen == TENURED)
 698                 {
 699                         growing_data_heap = true;
 700
 701                         /* see the comment in unmark_marked() */
 702                         if(collecting_code)
 703                                 unmark_marked(&code_heap);
 704                 }
 705                 /* we try collecting AGING space twice before going on to
 706                 collect TENURED */
 707                 else if(HAVE_AGING_P
 708                         && collecting_gen == AGING
 709                         && !collecting_aging_again)
 710                 {
 711                         collecting_aging_again = true;
 712                 }
 713                 /* Collect the next oldest generation */
 714                 else
 715                 {
 716                         collecting_gen++;
 717                 }
 718         }
 719
 720         begin_gc(requested_bytes);
 721
 722         /* initialize chase pointer */
 723         CELL scan = newspace->here;
 724
 725         /* collect objects referenced from stacks and environment */
 726         collect_roots();
 727
 728         /* collect objects referenced from older generations */
 729         collect_cards();
 730
 731         if(!collecting_code)
 732         {
 733                 /* don't scan code heap unless it has pointers to this
 734                 generation or younger */
 735                 if(collecting_gen >= last_code_heap_scan)
 736                 {
 737                         /* if we are doing code GC, then we will copy over
 738                         literals from any code block which gets marked as live.
 739                         if we are not doing code GC, just consider all literals
 740                         as roots. */
 741                         collect_literals();
 742                         if(collecting_accumulation_gen_p())
 743                                 last_code_heap_scan = collecting_gen;
 744                         else
 745                                 last_code_heap_scan = collecting_gen + 1;
 746                 }
 747         }
 748
 749         while(scan < newspace->here)
 750                 scan = collect_next(scan);
 751
 752         end_gc();
 753
 754         gc_time += (current_millis() - start);
 755         performing_gc = false;
 756 }
 757
 758 void data_gc(void)
 759 {
 760         garbage_collection(TENURED,false,false,0);
 761 }
 762
 763 DEFINE_PRIMITIVE(data_gc)
 764 {
 765         data_gc();
 766 }
 767
 768 /* Push total time spent on GC */
 769 DEFINE_PRIMITIVE(gc_time)
 770 {
 771         box_unsigned_8(gc_time);
 772 }
 773
 774 void simple_gc(void)
 775 {
 776         maybe_gc(0);
 777 }
 778
 779 DEFINE_PRIMITIVE(become)
 780 {
 781         F_ARRAY *new_objects = untag_array(dpop());
 782         F_ARRAY *old_objects = untag_array(dpop());
 783
 784         CELL capacity = array_capacity(new_objects);
 785         if(capacity != array_capacity(old_objects))
 786                 critical_error("bad parameters to become",0);
 787
 788         CELL i;
 789
 790         for(i = 0; i < capacity; i++)
 791         {
 792                 CELL old_obj = array_nth(old_objects,i);
 793                 CELL new_obj = array_nth(new_objects,i);
 794
 795                 forward_object(old_obj,new_obj);
 796         }
 797
 798         data_gc();
 799 }