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 collect_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         collect_next_loop(card_scan,&card_end);
 308
 309         cards_scanned++;
 310 }
 311
 312 void collect_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                                         collect_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 collect_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 collect_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 collect_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                         collect_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 collect_cards(void)
 412 {
 413         int i;
 414         for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 415                 collect_gen_cards(i);
 416 }
 417
 418 /* Copy all tagged pointers in a range of memory */
 419 void collect_stack(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 collect_stack_frame(F_STACK_FRAME *frame)
 428 {
 429         recursive_mark(compiled_to_block(frame_code(frame)));
 430 }
 431
 432 /* The base parameter allows us to adjust for a heap-allocated
 433 callstack snapshot */
 434 void collect_callstack(F_CONTEXT *stacks)
 435 {
 436         if(collecting_gen == TENURED)
 437         {
 438                 CELL top = (CELL)stacks->callstack_top;
 439                 CELL bottom = (CELL)stacks->callstack_bottom;
 440
 441                 iterate_callstack(top,bottom,collect_stack_frame);
 442         }
 443 }
 444
 445 void collect_gc_locals(void)
 446 {
 447         CELL ptr = gc_locals_region->start;
 448
 449         for(; ptr <= gc_locals; ptr += CELLS)
 450                 copy_handle(*(CELL **)ptr);
 451 }
 452
 453 /* Copy roots over at the start of GC, namely various constants, stacks,
 454 the user environment and extra roots registered with REGISTER_ROOT */
 455 void collect_roots(void)
 456 {
 457         copy_handle(&T);
 458         copy_handle(&bignum_zero);
 459         copy_handle(&bignum_pos_one);
 460         copy_handle(&bignum_neg_one);
 461
 462         collect_gc_locals();
 463         collect_stack(extra_roots_region,extra_roots);
 464
 465         save_stacks();
 466         F_CONTEXT *stacks = stack_chain;
 467
 468         while(stacks)
 469         {
 470                 collect_stack(stacks->datastack_region,stacks->datastack);
 471                 collect_stack(stacks->retainstack_region,stacks->retainstack);
 472
 473                 copy_handle(&stacks->catchstack_save);
 474                 copy_handle(&stacks->current_callback_save);
 475
 476                 collect_callstack(stacks);
 477
 478                 stacks = stacks->next;
 479         }
 480
 481         int i;
 482         for(i = 0; i < USER_ENV; i++)
 483                 copy_handle(&userenv[i]);
 484 }
 485
 486 /* Given a pointer to oldspace, copy it to newspace */
 487 INLINE void *copy_untagged_object(void *pointer, CELL size)
 488 {
 489         if(newspace->here + size >= newspace->end)
 490                 longjmp(gc_jmp,1);
 491         allot_barrier(newspace->here);
 492         void *newpointer = allot_zone(newspace,size);
 493
 494         F_GC_STATS *s = &gc_stats[collecting_gen];
 495         s->object_count++;
 496         s->bytes_copied += size;
 497
 498         memcpy(newpointer,pointer,size);
 499         return newpointer;
 500 }
 501
 502 INLINE void forward_object(CELL pointer, CELL newpointer)
 503 {
 504         if(pointer != newpointer)
 505                 put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
 506 }
 507
 508 INLINE CELL copy_object_impl(CELL pointer)
 509 {
 510         CELL newpointer = (CELL)copy_untagged_object(
 511                 (void*)UNTAG(pointer),
 512                 object_size(pointer));
 513         forward_object(pointer,newpointer);
 514         return newpointer;
 515 }
 516
 517 /* Follow a chain of forwarding pointers */
 518 CELL resolve_forwarding(CELL untagged, CELL tag)
 519 {
 520         CELL header = get(untagged);
 521         /* another forwarding pointer */
 522         if(TAG(header) == GC_COLLECTED)
 523                 return resolve_forwarding(UNTAG(header),tag);
 524         /* we've found the destination */
 525         else
 526         {
 527                 CELL pointer = RETAG(untagged,tag);
 528                 if(should_copy(untagged))
 529                         pointer = RETAG(copy_object_impl(pointer),tag);
 530                 return pointer;
 531         }
 532 }
 533
 534 /* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
 535 If the object has already been copied, return the forwarding
 536 pointer address without copying anything; otherwise, install
 537 a new forwarding pointer. */
 538 INLINE CELL copy_object(CELL pointer)
 539 {
 540         CELL tag = TAG(pointer);
 541         CELL header = get(UNTAG(pointer));
 542
 543         if(TAG(header) == GC_COLLECTED)
 544                 return resolve_forwarding(UNTAG(header),tag);
 545         else
 546                 return RETAG(copy_object_impl(pointer),tag);
 547 }
 548
 549 void copy_handle(CELL *handle)
 550 {
 551         CELL pointer = *handle;
 552
 553         if(!immediate_p(pointer) && should_copy(pointer))
 554                 *handle = copy_object(pointer);
 555 }
 556
 557 /* The number of cells from the start of the object which should be scanned by
 558 the GC. Some types have a binary payload at the end (string, word, DLL) which
 559 we ignore. */
 560 CELL binary_payload_start(CELL pointer)
 561 {
 562         F_TUPLE *tuple;
 563         F_TUPLE_LAYOUT *layout;
 564
 565         switch(untag_header(get(pointer)))
 566         {
 567         /* these objects do not refer to other objects at all */
 568         case FLOAT_TYPE:
 569         case BYTE_ARRAY_TYPE:
 570         case BIGNUM_TYPE:
 571         case CALLSTACK_TYPE:
 572                 return 0;
 573         /* these objects have some binary data at the end */
 574         case WORD_TYPE:
 575                 return sizeof(F_WORD) - CELLS * 3;
 576         case ALIEN_TYPE:
 577                 return CELLS * 3;
 578         case DLL_TYPE:
 579                 return CELLS * 2;
 580         case QUOTATION_TYPE:
 581                 return sizeof(F_QUOTATION) - CELLS * 2;
 582         case STRING_TYPE:
 583                 return sizeof(F_STRING);
 584         /* everything else consists entirely of pointers */
 585         case ARRAY_TYPE:
 586                 return array_size(array_capacity((F_ARRAY*)pointer));
 587         case TUPLE_TYPE:
 588                 tuple = untag_object(pointer);
 589                 layout = untag_object(tuple->layout);
 590                 return tuple_size(layout);
 591         case RATIO_TYPE:
 592                 return sizeof(F_RATIO);
 593         case COMPLEX_TYPE:
 594                 return sizeof(F_COMPLEX);
 595         case WRAPPER_TYPE:
 596                 return sizeof(F_WRAPPER);
 597         default:
 598                 critical_error("Invalid header",pointer);
 599                 return -1; /* can't happen */
 600         }
 601 }
 602
 603 void do_code_slots(CELL scan)
 604 {
 605         F_WORD *word;
 606         F_QUOTATION *quot;
 607         F_CALLSTACK *stack;
 608
 609         switch(object_type(scan))
 610         {
 611         case WORD_TYPE:
 612                 word = (F_WORD *)scan;
 613                 recursive_mark(compiled_to_block(word->code));
 614                 if(word->profiling)
 615                         recursive_mark(compiled_to_block(word->profiling));
 616                 break;
 617         case QUOTATION_TYPE:
 618                 quot = (F_QUOTATION *)scan;
 619                 if(quot->compiledp != F)
 620                         recursive_mark(compiled_to_block(quot->code));
 621                 break;
 622         case CALLSTACK_TYPE:
 623                 stack = (F_CALLSTACK *)scan;
 624                 iterate_callstack_object(stack,collect_stack_frame);
 625                 break;
 626         }
 627 }
 628
 629 CELL collect_next_nursery(CELL scan)
 630 {
 631         CELL *obj = (CELL *)scan;
 632         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 633
 634         if(obj != end)
 635         {
 636                 obj++;
 637
 638                 CELL nursery_start = nursery.start;
 639                 CELL nursery_end = nursery.end;
 640
 641                 for(; obj < end; obj++)
 642                 {
 643                         CELL pointer = *obj;
 644
 645                         if(!immediate_p(pointer)
 646                                 && (pointer >= nursery_start && pointer < nursery_end))
 647                                 *obj = copy_object(pointer);
 648                 }
 649         }
 650
 651         return scan + untagged_object_size(scan);
 652 }
 653
 654 CELL collect_next_aging(CELL scan)
 655 {
 656         CELL *obj = (CELL *)scan;
 657         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 658
 659         if(obj != end)
 660         {
 661                 obj++;
 662
 663                 CELL tenured_start = data_heap->generations[TENURED].start;
 664                 CELL tenured_end = data_heap->generations[TENURED].end;
 665
 666                 CELL newspace_start = newspace->start;
 667                 CELL newspace_end = newspace->end;
 668
 669                 for(; obj < end; obj++)
 670                 {
 671                         CELL pointer = *obj;
 672
 673                         if(!immediate_p(pointer)
 674                                 && !(pointer >= newspace_start && pointer < newspace_end)
 675                                 && !(pointer >= tenured_start && pointer < tenured_end))
 676                                 *obj = copy_object(pointer);
 677                 }
 678         }
 679
 680         return scan + untagged_object_size(scan);
 681 }
 682
 683 /* This function is performance-critical */
 684 CELL collect_next_tenured(CELL scan)
 685 {
 686         CELL *obj = (CELL *)scan;
 687         CELL *end = (CELL *)(scan + binary_payload_start(scan));
 688
 689         if(obj != end)
 690         {
 691                 obj++;
 692
 693                 CELL newspace_start = newspace->start;
 694                 CELL newspace_end = newspace->end;
 695
 696                 for(; obj < end; obj++)
 697                 {
 698                         CELL pointer = *obj;
 699
 700                         if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
 701                                 *obj = copy_object(pointer);
 702                 }
 703         }
 704
 705         do_code_slots(scan);
 706
 707         return scan + untagged_object_size(scan);
 708 }
 709
 710 void collect_next_loop(CELL scan, CELL *end)
 711 {
 712         if(HAVE_NURSERY_P && collecting_gen == NURSERY)
 713         {
 714                 while(scan < *end)
 715                         scan = collect_next_nursery(scan);
 716         }
 717         else if(HAVE_AGING_P && collecting_gen == AGING)
 718         {
 719                 while(scan < *end)
 720                         scan = collect_next_aging(scan);
 721         }
 722         else if(collecting_gen == TENURED)
 723         {
 724                 while(scan < *end)
 725                         scan = collect_next_tenured(scan);
 726         }
 727 }
 728
 729 INLINE void reset_generation(CELL i)
 730 {
 731         F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
 732
 733         z->here = z->start;
 734         if(secure_gc)
 735                 memset((void*)z->start,69,z->size);
 736 }
 737
 738 /* After garbage collection, any generations which are now empty need to have
 739 their allocation pointers and cards reset. */
 740 void reset_generations(CELL from, CELL to)
 741 {
 742         CELL i;
 743         for(i = from; i <= to; i++)
 744                 reset_generation(i);
 745
 746         clear_cards(from,to);
 747         clear_decks(from,to);
 748         clear_allot_markers(from,to);
 749 }
 750
 751 /* Prepare to start copying reachable objects into an unused zone */
 752 void begin_gc(CELL requested_bytes)
 753 {
 754         if(growing_data_heap)
 755         {
 756                 if(collecting_gen != TENURED)
 757                         critical_error("Invalid parameters to begin_gc",0);
 758
 759                 old_data_heap = data_heap;
 760                 set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
 761                 newspace = &data_heap->generations[TENURED];
 762         }
 763         else if(collecting_accumulation_gen_p())
 764         {
 765                 /* when collecting one of these generations, rotate it
 766                 with the semispace */
 767                 F_ZONE z = data_heap->generations[collecting_gen];
 768                 data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
 769                 data_heap->semispaces[collecting_gen] = z;
 770                 reset_generation(collecting_gen);
 771                 newspace = &data_heap->generations[collecting_gen];
 772                 clear_cards(collecting_gen,collecting_gen);
 773                 clear_decks(collecting_gen,collecting_gen);
 774                 clear_allot_markers(collecting_gen,collecting_gen);
 775         }
 776         else
 777         {
 778                 /* when collecting a younger generation, we copy
 779                 reachable objects to the next oldest generation,
 780                 so we set the newspace so the next generation. */
 781                 newspace = &data_heap->generations[collecting_gen + 1];
 782         }
 783 }
 784
 785 void end_gc(CELL gc_elapsed)
 786 {
 787         F_GC_STATS *s = &gc_stats[collecting_gen];
 788
 789         s->collections++;
 790         s->gc_time += gc_elapsed;
 791         if(s->max_gc_time < gc_elapsed)
 792                 s->max_gc_time = gc_elapsed;
 793
 794         if(growing_data_heap)
 795         {
 796                 dealloc_data_heap(old_data_heap);
 797                 old_data_heap = NULL;
 798                 growing_data_heap = false;
 799         }
 800
 801         if(collecting_accumulation_gen_p())
 802         {
 803                 /* all younger generations except are now empty.
 804                 if collecting_gen == NURSERY here, we only have 1 generation;
 805                 old-school Cheney collector */
 806                 if(collecting_gen != NURSERY)
 807                         reset_generations(NURSERY,collecting_gen - 1);
 808         }
 809         else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
 810         {
 811                 nursery.here = nursery.start;
 812         }
 813         else
 814         {
 815                 /* all generations up to and including the one
 816                 collected are now empty */
 817                 reset_generations(NURSERY,collecting_gen);
 818         }
 819
 820         if(collecting_gen == TENURED)
 821         {
 822                 /* now that all reachable code blocks have been marked,
 823                 deallocate the rest */
 824                 free_unmarked(&code_heap);
 825         }
 826
 827         collecting_aging_again = false;
 828 }
 829
 830 /* Collect gen and all younger generations.
 831 If growing_data_heap_ is true, we must grow the data heap to such a size that
 832 an allocation of requested_bytes won't fail */
 833 void garbage_collection(CELL gen,
 834         bool growing_data_heap_,
 835         CELL requested_bytes)
 836 {
 837         if(gc_off)
 838         {
 839                 critical_error("GC disabled",gen);
 840                 return;
 841         }
 842
 843         s64 start = current_micros();
 844
 845         performing_gc = true;
 846         growing_data_heap = growing_data_heap_;
 847         collecting_gen = gen;
 848
 849         /* we come back here if a generation is full */
 850         if(setjmp(gc_jmp))
 851         {
 852                 /* We have no older generations we can try collecting, so we
 853                 resort to growing the data heap */
 854                 if(collecting_gen == TENURED)
 855                 {
 856                         growing_data_heap = true;
 857
 858                         /* see the comment in unmark_marked() */
 859                         unmark_marked(&code_heap);
 860                 }
 861                 /* we try collecting AGING space twice before going on to
 862                 collect TENURED */
 863                 else if(HAVE_AGING_P
 864                         && collecting_gen == AGING
 865                         && !collecting_aging_again)
 866                 {
 867                         collecting_aging_again = true;
 868                 }
 869                 /* Collect the next oldest generation */
 870                 else
 871                 {
 872                         collecting_gen++;
 873                 }
 874         }
 875
 876         begin_gc(requested_bytes);
 877
 878         /* initialize chase pointer */
 879         CELL scan = newspace->here;
 880
 881         /* collect objects referenced from stacks and environment */
 882         collect_roots();
 883         /* collect objects referenced from older generations */
 884         collect_cards();
 885
 886         /* don't scan code heap unless it has pointers to this
 887         generation or younger */
 888         if(collecting_gen >= last_code_heap_scan)
 889         {
 890                 if(collecting_gen != TENURED)
 891                 {
 892
 893                         /* if we are doing code GC, then we will copy over
 894                         literals from any code block which gets marked as live.
 895                         if we are not doing code GC, just consider all literals
 896                         as roots. */
 897                         code_heap_scans++;
 898
 899                         collect_literals();
 900                 }
 901
 902                 if(collecting_accumulation_gen_p())
 903                         last_code_heap_scan = collecting_gen;
 904                 else
 905                         last_code_heap_scan = collecting_gen + 1;
 906         }
 907
 908         collect_next_loop(scan,&newspace->here);
 909
 910         CELL gc_elapsed = (current_micros() - start);
 911
 912         end_gc(gc_elapsed);
 913
 914         performing_gc = false;
 915 }
 916
 917 void gc(void)
 918 {
 919         garbage_collection(TENURED,false,0);
 920 }
 921
 922 void minor_gc(void)
 923 {
 924         garbage_collection(NURSERY,false,0);
 925 }
 926
 927 void primitive_gc(void)
 928 {
 929         gc();
 930 }
 931
 932 void primitive_gc_stats(void)
 933 {
 934         GROWABLE_ARRAY(stats);
 935
 936         CELL i;
 937         u64 total_gc_time = 0;
 938
 939         for(i = 0; i < MAX_GEN_COUNT; i++)
 940         {
 941                 F_GC_STATS *s = &gc_stats[i];
 942                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
 943                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
 944                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
 945                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
 946                 GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
 947                 GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
 948
 949                 total_gc_time += s->gc_time;
 950         }
 951
 952         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time)));
 953         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
 954         GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
 955         GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
 956
 957         GROWABLE_ARRAY_TRIM(stats);
 958         dpush(stats);
 959 }
 960
 961 void primitive_gc_reset(void)
 962 {
 963         gc_reset();
 964 }
 965
 966 void primitive_become(void)
 967 {
 968         F_ARRAY *new_objects = untag_array(dpop());
 969         F_ARRAY *old_objects = untag_array(dpop());
 970
 971         CELL capacity = array_capacity(new_objects);
 972         if(capacity != array_capacity(old_objects))
 973                 critical_error("bad parameters to become",0);
 974
 975         CELL i;
 976
 977         for(i = 0; i < capacity; i++)
 978         {
 979                 CELL old_obj = array_nth(old_objects,i);
 980                 CELL new_obj = array_nth(new_objects,i);
 981
 982                 forward_object(old_obj,new_obj);
 983         }
 984
 985         gc();
 986
 987         compile_all_words();
 988 }
 989
 990 CELL find_all_words(void)
 991 {
 992         GROWABLE_ARRAY(words);
 993
 994         begin_scan();
 995
 996         CELL obj;
 997         while((obj = next_object()) != F)
 998         {
 999                 if(type_of(obj) == WORD_TYPE)
1000                         GROWABLE_ARRAY_ADD(words,obj);
1001         }
1002
1003         /* End heap scan */
1004         gc_off = false;
1005
1006         GROWABLE_ARRAY_TRIM(words);
1007
1008         return words;
1009 }