src/gc/gc_gms.c

   1 /*
   2 Copyright (C) 2001-2007, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/gc/gc_gms.c - Generational mark and sweep garbage collection
   8
   9 =head1 OVERVIEW
  10
  11 The following comments describe a generational garbage collection
  12 scheme for Parrot.
  13
  14 Keywords:
  15
  16  - non-copying, mark & sweep
  17  - generational
  18  - implicit reclamation, treadmill
  19
  20 =head1 DESCRIPTION
  21
  22 A plain mark & sweep collector performs work depending on the amount
  23 of all allocated objects. The advantage of a generational GC is
  24 achieved by not processing all objects. This is based on the weak
  25 generational hypothesis, which states that young objects are likely to
  26 die early. Old objects, which have survived a few GC cycles tend to be
  27 long-lived.
  28
  29 The terms young and old objects imply that there is some ordering in
  30 object creation time and the ordering is also followed by object
  31 references.
  32
  33 Specifically object references have to follow the marking direction.
  34 In pure functional programming languages this can be a very simple
  35 scheme:
  36
  37         +------------+    object references
  38         v            |
  39    old   .... young .... youngest
  40                             |
  41                    <--------  scan direction
  42
  43 If (simplified) the only reference-like operation of the interpreter
  44 is:
  45
  46    cons = (car, cdr)
  47
  48 and the object references "car" and "cdr" are created prior to the
  49 "aggregate" "cons", all object references point always to older
  50 objects.  By scanning from the youngest to the oldest objects, all
  51 non-marked objects can be reclaimed immediately. And the scan can be
  52 aborted at any time after some processing, creating a generational GC
  53 in a trivial way.
  54
  55 But the programming languages we are serving are working basically the
  56 other direction, when it comes to object history:
  57
  58   @a[$i] = $n
  59
  60 A reference operation like this needs first an aggregate and then the
  61 contents of it. So the scan direction is from old objects to younger
  62 ones.  In such a scheme it's a bit more complicated to skip parts of
  63 the objects.
  64
  65 To take advantage of not processing all the objects, these are divided
  66 into generations, e.g.:
  67
  68    old               young := nursery
  69    generation 0      generation 1
  70
  71 A mark phase now processes the root set and only objects from the
  72 young generation. When all objects are either referenced by the root
  73 set or only by the young generation, the algorithm is correct and
  74 complete.
  75
  76 But there is of course the possibilty that a young object is
  77 stored into an aggregate of an older generation. This case is tracked
  78 by the write barrier, which remembers all such operations in the IGP
  79 (inter generational pointer) list. When now generation 1 is marked,
  80 the IGP list can be considered as an extension to the root set, so
  81 that again all live objects of the young generation are detected.
  82
  83
  84 =head2 Structures
  85
  86 =over 4
  87
  88 =item C<typedef struct _gc_gms_gen Gc_gms_gen>
  89
  90 Describes the state of one generation for one pool.
  91
  92 =item C<typedef struct _gc_gms_hdr Gc_gms_hdr>
  93
  94 This header is in front of all Parrot objects. It forms a doubly-linked
  95 list of all objects in one pool and points to its generation.
  96
  97 =item PObj_to_GMSH(o)
  98
  99 =item GMSH_to_PObj(p)
 100
 101 These two macros convert from and to headers and objects.
 102
 103 =item C<typedef struct _gc_gms_hdr_list Gc_gms_hdr_list>
 104
 105 A chained list of headers used e.g. for the IGP list.
 106
 107 =back
 108
 109 =cut
 110
 111 */
 112
 113 #include "parrot/parrot.h"
 114 #include "parrot/dod.h"
 115
 116 #if PARROT_GC_GMS
 117
 118 typedef struct Gc_gms_private {
 119     UINTVAL current_gen_no;             /* the nursery generation number */
 120 } Gc_gms_private;
 121
 122 /* HEADERIZER HFILE: include/parrot/dod.h */
 123
 124 /* HEADERIZER BEGIN: static */
 125 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
 126
 127 static int end_cycle_cb(PARROT_INTERP,
 128     ARGMOD(Small_Object_Pool *pool),
 129     int flag,
 130     SHIM(void *arg))
 131         __attribute__nonnull__(1)
 132         __attribute__nonnull__(2)
 133         FUNC_MODIFIES(*pool);
 134
 135 static void gc_gms_add_free_object(PARROT_INTERP,
 136     SHIM(Small_Object_Pool *pool),
 137     SHIM(PObj *to_add))
 138         __attribute__nonnull__(1);
 139
 140 static void gc_gms_alloc_objects(PARROT_INTERP,
 141     ARGMOD(Small_Object_Pool *pool))
 142         __attribute__nonnull__(1)
 143         __attribute__nonnull__(2)
 144         FUNC_MODIFIES(*pool);
 145
 146 static void gc_gms_chain_objects(PARROT_INTERP,
 147     ARGMOD(Small_Object_Pool *pool),
 148     ARGIN(Small_Object_Arena *new_arena),
 149     size_t real_size)
 150         __attribute__nonnull__(1)
 151         __attribute__nonnull__(2)
 152         __attribute__nonnull__(3)
 153         FUNC_MODIFIES(*pool);
 154
 155 static void gc_gms_clear_hdr_list(PARROT_INTERP, ARGMOD(Gc_gms_hdr_list *l))
 156         __attribute__nonnull__(1)
 157         __attribute__nonnull__(2)
 158         FUNC_MODIFIES(*l);
 159
 160 static void gc_gms_clear_igp(PARROT_INTERP, ARGIN(Gc_gms_gen *gen))
 161         __attribute__nonnull__(1)
 162         __attribute__nonnull__(2);
 163
 164 PARROT_MALLOC
 165 PARROT_CANNOT_RETURN_NULL
 166 static Gc_gms_gen * gc_gms_create_gen(PARROT_INTERP,
 167     ARGMOD(Small_Object_Pool *pool),
 168     size_t gen_no)
 169         __attribute__nonnull__(1)
 170         __attribute__nonnull__(2)
 171         FUNC_MODIFIES(*pool);
 172
 173 static void gc_gms_end_cycle(PARROT_INTERP)
 174         __attribute__nonnull__(1);
 175
 176 PARROT_WARN_UNUSED_RESULT
 177 PARROT_CANNOT_RETURN_NULL
 178 static Gc_gms_gen * gc_gms_find_gen(PARROT_INTERP,
 179     ARGIN(const Gc_gms_hdr *h),
 180     UINTVAL gen_no)
 181         __attribute__nonnull__(1)
 182         __attribute__nonnull__(2);
 183
 184 PARROT_WARN_UNUSED_RESULT
 185 PARROT_CANNOT_RETURN_NULL
 186 static PObj * gc_gms_get_free_object(PARROT_INTERP,
 187     ARGMOD(Small_Object_Pool *pool))
 188         __attribute__nonnull__(1)
 189         __attribute__nonnull__(2)
 190         FUNC_MODIFIES(*pool);
 191
 192 static void gc_gms_init_gen(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 193         __attribute__nonnull__(1)
 194         __attribute__nonnull__(2)
 195         FUNC_MODIFIES(*pool);
 196
 197 static void gc_gms_init_mark(PARROT_INTERP)
 198         __attribute__nonnull__(1);
 199
 200 static void gc_gms_merge_gen(PARROT_INTERP,
 201     ARGMOD(Small_Object_Pool *pool),
 202     int flag,
 203     SHIM(Gc_gms_plan *plan))
 204         __attribute__nonnull__(1)
 205         __attribute__nonnull__(2)
 206         FUNC_MODIFIES(*pool);
 207
 208 static void gc_gms_more_objects(PARROT_INTERP,
 209     ARGMOD(Small_Object_Pool *pool))
 210         __attribute__nonnull__(1)
 211         __attribute__nonnull__(2)
 212         FUNC_MODIFIES(*pool);
 213
 214 static void gc_gms_pool_init(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 215         __attribute__nonnull__(1)
 216         __attribute__nonnull__(2)
 217         FUNC_MODIFIES(*pool);
 218
 219 static void gc_gms_promote(PARROT_INTERP,
 220     ARGIN(Gc_gms_hdr *h),
 221     UINTVAL gen_no)
 222         __attribute__nonnull__(1)
 223         __attribute__nonnull__(2);
 224
 225 static void gc_gms_set_gen(PARROT_INTERP)
 226         __attribute__nonnull__(1);
 227
 228 static void gc_gms_setto_black(PARROT_INTERP,
 229     ARGMOD(Gc_gms_hdr *h),
 230     int priority)
 231         __attribute__nonnull__(1)
 232         __attribute__nonnull__(2)
 233         FUNC_MODIFIES(*h);
 234
 235 static void gc_gms_setto_gray(PARROT_INTERP,
 236     ARGIN(Gc_gms_hdr *h),
 237     int priority)
 238         __attribute__nonnull__(1)
 239         __attribute__nonnull__(2);
 240
 241 static void gc_gms_store_hdr_list(PARROT_INTERP,
 242     ARGMOD(Gc_gms_hdr_list *l),
 243     ARGIN(Gc_gms_hdr *h))
 244         __attribute__nonnull__(1)
 245         __attribute__nonnull__(2)
 246         __attribute__nonnull__(3)
 247         FUNC_MODIFIES(*l);
 248
 249 static void gc_gms_store_igp(PARROT_INTERP, ARGIN(Gc_gms_hdr *h))
 250         __attribute__nonnull__(1)
 251         __attribute__nonnull__(2);
 252
 253 static void gc_gms_sweep(PARROT_INTERP)
 254         __attribute__nonnull__(1);
 255
 256 static int gc_gms_trace_children(PARROT_INTERP)
 257         __attribute__nonnull__(1);
 258
 259 static int gc_gms_trace_root(PARROT_INTERP, int trace_stack)
 260         __attribute__nonnull__(1);
 261
 262 static void gc_gms_use_gen(PARROT_INTERP,
 263     ARGMOD(Small_Object_Pool *pool),
 264     int flag,
 265     ARGIN(const Gc_gms_plan *plan))
 266         __attribute__nonnull__(1)
 267         __attribute__nonnull__(2)
 268         __attribute__nonnull__(4)
 269         FUNC_MODIFIES(*pool);
 270
 271 static void gms_debug_verify(PARROT_INTERP,
 272     ARGMOD(Small_Object_Pool *pool),
 273     ARGIN(const char *action))
 274         __attribute__nonnull__(1)
 275         __attribute__nonnull__(2)
 276         __attribute__nonnull__(3)
 277         FUNC_MODIFIES(*pool);
 278
 279 static int init_mark_cb(PARROT_INTERP,
 280     ARGMOD(Small_Object_Pool *pool),
 281     int flag,
 282     ARGIN(void *arg))
 283         __attribute__nonnull__(1)
 284         __attribute__nonnull__(2)
 285         __attribute__nonnull__(4)
 286         FUNC_MODIFIES(*pool);
 287
 288 static void parrot_gc_gms_deinit(PARROT_INTERP)
 289         __attribute__nonnull__(1);
 290
 291 static void parrot_gc_gms_run(PARROT_INTERP, int flags)
 292         __attribute__nonnull__(1);
 293
 294 PARROT_WARN_UNUSED_RESULT
 295 static int set_gen_cb(PARROT_INTERP,
 296     ARGIN(Small_Object_Pool *pool),
 297     int flag,
 298     ARGIN(void *arg))
 299         __attribute__nonnull__(1)
 300         __attribute__nonnull__(2)
 301         __attribute__nonnull__(4);
 302
 303 static int sweep_cb_buf(PARROT_INTERP,
 304     ARGMOD(Small_Object_Pool *pool),
 305     int flag,
 306     SHIM(void *arg))
 307         __attribute__nonnull__(1)
 308         __attribute__nonnull__(2)
 309         FUNC_MODIFIES(*pool);
 310
 311 static int sweep_cb_pmc(PARROT_INTERP,
 312     ARGIN(Small_Object_Pool *pool),
 313     int flag,
 314     SHIM(void *arg))
 315         __attribute__nonnull__(1)
 316         __attribute__nonnull__(2);
 317
 318 static int trace_children_cb(PARROT_INTERP,
 319     ARGIN(Small_Object_Pool *pool),
 320     int flag,
 321     SHIM(void *arg))
 322         __attribute__nonnull__(1)
 323         __attribute__nonnull__(2);
 324
 325 static int trace_igp_cb(PARROT_INTERP,
 326     ARGIN(Small_Object_Pool *pool),
 327     int flag,
 328     SHIM(void *arg))
 329         __attribute__nonnull__(1)
 330         __attribute__nonnull__(2);
 331
 332 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
 333 /* HEADERIZER END: static */
 334
 335
 336 /*
 337
 338 =pod
 339
 340  * XXX
 341
 342 Main problem TODO 1):
 343
 344  [ PCont ]       ... continuation object in old generation
 345     |
 346     v
 347  [ Stack chunk ] --> [ e.g. P register frame ]  ... new generation
 348
 349 By pushing a new stack chunk onto the (old) existing stack frame,
 350 we'd need a WRITE_BARRIER that promotes the stack chunk to the old
 351 generation of the continuation.
 352 This would also need an IGP entry for the stack chunk buffer. But -
 353 as buffers aren't really containers in Parrot - this isn't possible.
 354
 355 To get that right, the code needs better support by the running
 356 interpreter.
 357  - never promote continuations (and stacks) in the current stack frame
 358    to an old generation
 359  - create scope_enter / scope_exit opcodes
 360
 361 A scope_enter happens on a subroutine call *and' with new_pad /
 362 push_pad opcodes. Each lexical scope must have its distinct register
 363 frame, else timely destruction can't work.
 364 If the frame needs active destruction, the old frame should be
 365 converted to the (new-1) generation, the inner frame is the nursery.
 366 On scope exit the newest (nursery) generation is collected and the
 367 current generation number is reset back to (new-1).
 368
 369 If the scope_enter doesn't indicate timely destruction, generation
 370 promoting should be done only, if object statistics indicate the
 371 presence of a fair amount of live objects.
 372
 373 TODO 2) in lazy sweep
 374 If timely destruction didn't find (all) eager objects, go back to
 375 older generations, until all these objects have been seen.
 376
 377 TODO 3) interpreter startup
 378 After all internal structures are created, promote interpreter state
 379 into initial first old generation by running one GC cycle before
 380 program execution begins (or just treat all objects as being alive).
 381
 382 =cut
 383
 384 */
 385
 386 /*
 387  * call code to verify chain of pointers after each change
 388  * this is very expensive, but should be used during development
 389  */
 390 #  define GC_GMS_DEBUG 0
 391
 392 #  define UNITS_PER_ALLOC_GROWTH_FACTOR 1.75
 393 #  define POOL_MAX_BYTES 65536*128
 394
 395 /*
 396
 397 =head2 Initialization functions
 398
 399 =over 4
 400
 401 =item C<static void parrot_gc_gms_deinit>
 402
 403 Free used resources.
 404
 405 =cut
 406
 407 */
 408
 409 static void
 410 parrot_gc_gms_deinit(PARROT_INTERP)
 411 {
 412     Arenas * const arena_base = interp->arena_base;
 413
 414     /*
 415      * TODO free generations
 416      */
 417     mem_sys_free(arena_base->gc_private);
 418     arena_base->gc_private = NULL;
 419 }
 420
 421 /*
 422
 423 =item C<static void gc_gms_pool_init>
 424
 425 Initialize pool variables. This function must set the pool function pointers
 426 for C<add_free_object>, C<get_free_object>, C<alloc_objects>, and
 427 C<more_objects>.
 428
 429 =cut
 430
 431 */
 432
 433 static void
 434 gc_gms_pool_init(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 435 {
 436     pool->add_free_object = gc_gms_add_free_object;
 437     pool->get_free_object = gc_gms_get_free_object;
 438     pool->alloc_objects   = gc_gms_alloc_objects;
 439     pool->more_objects    = gc_gms_more_objects;
 440
 441     /* initialize generations */
 442     gc_gms_init_gen(interp, pool);
 443     pool->white = pool->white_fin = pool->free_list = &pool->marker;
 444
 445     pool->object_size += sizeof (Gc_gms_hdr);
 446 }
 447
 448 /*
 449
 450 =item C<void Parrot_gc_gms_init>
 451
 452 Initialize the state structures of the gc system. Called immediately before
 453 creation of memory pools.
 454
 455 =cut
 456
 457 */
 458
 459 PARROT_API
 460 void
 461 Parrot_gc_gms_init(PARROT_INTERP)
 462 {
 463     Arenas * const arena_base = interp->arena_base;
 464
 465     arena_base->gc_private = mem_sys_allocate_zeroed(sizeof (Gc_gms_private));
 466
 467     /*
 468      * set function hooks according to pdd09
 469      */
 470     arena_base->do_gc_mark         = parrot_gc_gms_run;
 471     arena_base->finalize_gc_system = parrot_gc_gms_deinit;
 472     arena_base->init_pool          = gc_gms_pool_init;
 473
 474 }
 475
 476 /*
 477
 478 =back
 479
 480 =head2 Interface functions
 481
 482 =over 4
 483
 484 =item C<static void gc_gms_add_free_object>
 485
 486 Unused. White (dead) objects are added in a bunch to the free_list.
 487
 488 =cut
 489
 490 */
 491
 492 static void
 493 gc_gms_add_free_object(PARROT_INTERP, SHIM(Small_Object_Pool *pool),
 494         SHIM(PObj *to_add))
 495 {
 496     real_exception(interp, NULL, 1, "gms abuse");
 497 }
 498
 499
 500 /*
 501
 502 =item C<static void gc_gms_chain_objects>
 503
 504 TODO: interfere active_destroy and put these items into a
 505 separate white area, so that a sweep has just to run through these
 506 objects
 507
 508 Header chain layout:
 509 - all objects are chained together forming a circular list
 510 - pool->marker is the "anchor" of the circle (shown twice below)
 511
 512  1) object allocation
 513
 514  1a) one bunch of allocated objects was consumed: the free ptr did
 515      hit the marker
 516
 517  +===+---+---+---+---+---+===+
 518  I M I w | w | w | w | w I M I
 519  +   +---+---+---+---+---+   +
 520        ^                   ^
 521        |                   |
 522        white               free == marker
 523
 524  All these pointer ranges include the first element, but not the last one.
 525
 526   [white ... free_list)   is the list of all whites
 527
 528  1b) after allocating another bunch of objects
 529
 530  +===+---+---+---+---+---+---+---+---+---+---+===+
 531  I M I w | w | w | w | w | f | f | f | f | f I M I
 532  +   +---+---+---+---+---+---+---+---+---+---+   +
 533        ^                   ^                   ^
 534        |                   |                   |
 535        white               free                marker
 536
 537 =cut
 538
 539 */
 540
 541 static void
 542 gc_gms_chain_objects(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool),
 543         ARGIN(Small_Object_Arena *new_arena), size_t real_size)
 544 {
 545     Gc_gms_hdr *next, *prev;
 546     size_t i, n;
 547
 548     Gc_gms_hdr *p = new_arena->start_objects;
 549     Gc_gms_hdr * const marker = &pool->marker;
 550
 551     PARROT_ASSERT(pool->free_list == marker);
 552
 553     /* update pool statistics */
 554     n = new_arena->total_objects;
 555     pool->total_objects += n;
 556     pool->num_free_objects += n;
 557     new_arena->used = n;
 558     /* initially all is pointing to marker */
 559     if (pool->white == marker) {
 560         /* set origin of first allocation */
 561         marker->next = p;
 562         p->prev = marker;
 563         pool->white = pool->white_fin = p;
 564         prev = marker;
 565     }
 566     else
 567         prev = marker->prev;
 568     /* chain objects together by inserting to the left of marker */
 569
 570     /* point to end of last object */
 571     p = (void*) ((char*) p + real_size * n);
 572     next = marker;
 573     for (i = 0; i < n; ++i) {
 574         p = (void*) ((char *)p - real_size);
 575         p->next = next;
 576         next->prev = p;
 577 #  ifndef NDEBUG
 578         p->gen = (void *)0xdeadbeef;
 579 #  endif
 580         next = p;
 581     }
 582     PARROT_ASSERT(p == new_arena->start_objects);
 583     p->prev = prev;
 584     prev->next = p;
 585     pool->free_list = p;
 586     PARROT_ASSERT(p != marker);
 587 }
 588
 589 /*
 590
 591 =item C<static void gc_gms_alloc_objects>
 592
 593 Allocate new objects for the given pool.
 594
 595 =cut
 596
 597 */
 598
 599 static void
 600 gc_gms_alloc_objects(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 601 {
 602     const size_t real_size = pool->object_size;
 603     Small_Object_Arena * const new_arena = mem_internal_allocate(sizeof (Small_Object_Arena));
 604     const size_t size = real_size * pool->objects_per_alloc;
 605
 606     new_arena->start_objects = mem_internal_allocate(size);
 607     /* insert arena in list */
 608     Parrot_append_arena_in_pool(interp, pool, new_arena, size);
 609     /* create chain of objects, set free pointer */
 610     gc_gms_chain_objects(interp, pool, new_arena, real_size);
 611
 612     /* allocate more next time */
 613     pool->objects_per_alloc = (UINTVAL) pool->objects_per_alloc *
 614         UNITS_PER_ALLOC_GROWTH_FACTOR;
 615     size = real_size * pool->objects_per_alloc;
 616     if (size > POOL_MAX_BYTES) {
 617         pool->objects_per_alloc = POOL_MAX_BYTES / real_size;
 618     }
 619 }
 620
 621 /*
 622
 623 =item C<static void gc_gms_more_objects>
 624
 625 Run a GC cycle or allocate new objects for the given pool.
 626
 627 =cut
 628
 629 */
 630
 631 static void
 632 gc_gms_more_objects(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 633 {
 634     if (pool->skip)
 635         pool->skip = 0;
 636     else if (pool->last_Arena) {
 637         Parrot_do_dod_run(interp, GC_trace_stack_FLAG);
 638         if (pool->num_free_objects <= pool->replenish_level)
 639             pool->skip = 1;
 640     }
 641
 642     if (pool->free_list == &pool->marker) {
 643         (*pool->alloc_objects) (interp, pool);
 644     }
 645 }
 646
 647 /*
 648
 649 =item C<static PObj * gc_gms_get_free_object>
 650
 651 Get a new object off the free_list in the given pool.
 652
 653 2) object consumption
 654    the free ptr moves towards the marker
 655
 656 =cut
 657
 658 */
 659
 660 PARROT_WARN_UNUSED_RESULT
 661 PARROT_CANNOT_RETURN_NULL
 662 static PObj *
 663 gc_gms_get_free_object(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 664 {
 665     PObj *ptr;
 666     Gc_gms_hdr *hdr;
 667
 668     hdr = pool->free_list;
 669     if (hdr == &pool->marker)
 670         (pool->more_objects)(interp, pool);
 671
 672     hdr = pool->free_list;
 673     pool->free_list = hdr->next;
 674     hdr->gen = pool->last_gen;
 675     ptr = GMSH_to_PObj(hdr);
 676     PObj_flags_SETTO((PObj*) ptr, 0);
 677     return ptr;
 678 }
 679
 680 /*
 681
 682 =back
 683
 684 =head2 Generation handling functions
 685
 686 overall header chain layout
 687
 688            gen 0         gen 1      ...    gen N
 689   marker [first last) [first last)  ...   [first last)  marker
 690
 691 The last (youngest) generation N holds these (pool) pointers:
 692
 693   [ black ... gray )          during marking
 694   [ gray ... white )          during marking
 695   [ white ... free_list )     allocated items
 696   [ free_list ... marker )    free items
 697
 698 The black, white, and generation ranges have additionally (TODO)
 699 *fin variants, which refer to PMCs that need destruction/finalization.
 700 These are always in front of the ranges to be processed first.
 701
 702 =over 4
 703
 704 =item C<static Gc_gms_gen * gc_gms_create_gen>
 705
 706 Create a generation structure for the given generation number.
 707
 708 =cut
 709
 710 */
 711
 712 PARROT_MALLOC
 713 PARROT_CANNOT_RETURN_NULL
 714 static Gc_gms_gen *
 715 gc_gms_create_gen(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool), size_t gen_no)
 716 {
 717     Gc_gms_gen * const gen = mem_sys_allocate(sizeof (*gen));
 718
 719     gen->gen_no = gen_no;
 720     gen->pool = pool;
 721     gen->timely_destruct_obj_sofar = 0;
 722     gen->black_color = b_PObj_live_FLAG;
 723     gen->prev = NULL;
 724     gen->next = NULL;
 725     gen->first = gen->last = gen->fin = &pool->marker;
 726     gen->igp.first = NULL;
 727     gen->igp.last = NULL;
 728
 729     return gen;
 730 }
 731
 732 /*
 733
 734 =item C<static void gc_gms_init_gen>
 735
 736 Initalize the generation system by creating the first two generations.
 737
 738 =cut
 739
 740 */
 741
 742 static void
 743 gc_gms_init_gen(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool))
 744 {
 745     Gc_gms_private *gmsp;
 746     /*
 747      * Generations are numbered beginning at zero
 748      * 0 ... oldest
 749      * 1 ... next oldest
 750      *
 751      * If a constant hash PMC refers to non-constant header buffers or
 752      * items, these items can be placed in the constant generation 0
 753      * XXX: OTOH this would work only for this GC subsystem.
 754      */
 755     pool->first_gen = gc_gms_create_gen(interp, pool, 0);
 756     pool->last_gen = pool->first_gen;
 757     gmsp = interp->arena_base->gc_private;
 758     gmsp->current_gen_no = 0;
 759 }
 760
 761 /*
 762
 763 =item C<static Gc_gms_gen * gc_gms_find_gen>
 764
 765 RT #48260: Not yet documented!!!
 766
 767 =cut
 768
 769 */
 770
 771 PARROT_WARN_UNUSED_RESULT
 772 PARROT_CANNOT_RETURN_NULL
 773 static Gc_gms_gen *
 774 gc_gms_find_gen(PARROT_INTERP, ARGIN(const Gc_gms_hdr *h), UINTVAL gen_no)
 775 {
 776     Gc_gms_gen *gen;
 777     const Small_Object_Pool * const pool = h->gen->pool;
 778
 779     PARROT_ASSERT(pool);
 780
 781     for (gen = pool->first_gen; gen; gen = gen->next) {
 782         if (gen_no == gen->gen_no)
 783             return gen;
 784         if (gen->gen_no > gen_no) {
 785             gen = NULL;
 786             break;
 787         }
 788     }
 789     /* we could create generations lazily - not all object sizes
 790      * might exist in every generation
 791      *
 792      * TODO insert generation
 793      */
 794     real_exception(interp, NULL, 1, "generation %d not found for hdr %p",
 795             gen_no, h);
 796 }
 797
 798 /*
 799
 800 =item C<static void gc_gms_promote>
 801
 802 RT #48260: Not yet documented!!!
 803
 804 =cut
 805
 806 */
 807
 808 static void
 809 gc_gms_promote(PARROT_INTERP, ARGIN(Gc_gms_hdr *h), UINTVAL gen_no)
 810 {
 811     Gc_gms_gen *gen;
 812     Gc_gms_hdr *prev, *next;
 813     Small_Object_Pool * const pool = h->gen->pool;
 814
 815     /* unsnap from current generation */
 816     prev = h->prev;
 817     next = h->next;
 818     if (h == pool->white) {
 819         pool->white = next;
 820     }
 821     prev->next = next;
 822     next->prev = prev;
 823
 824     /* locate generation pointer */
 825     gen = gc_gms_find_gen(interp, h, gen_no);
 826     PARROT_ASSERT(gen->last);
 827     PARROT_ASSERT(gen->first);
 828
 829     /* TODO if it needs destroy put it in front */
 830     next = gen->last;
 831     if (h == next)
 832         next = gen->last = h->next;
 833     prev = next->prev;
 834     if (gen->first == &pool->marker)
 835         gen->first = h;
 836     h->prev = prev;
 837     h->next = next;
 838     prev->next = h;
 839     next->prev = h;
 840 #  if GC_GMS_DEBUG
 841     gms_debug_verify(interp, pool, "promote");
 842 #  endif
 843 }
 844
 845 /*
 846
 847 =item C<static void gc_gms_store_hdr_list>
 848
 849 RT #48260: Not yet documented!!!
 850
 851 =cut
 852
 853 */
 854
 855 static void
 856 gc_gms_store_hdr_list(PARROT_INTERP, ARGMOD(Gc_gms_hdr_list *l), ARGIN(Gc_gms_hdr *h))
 857 {
 858     Gc_gms_hdr_store * const s = l->last;
 859
 860     /* if it's not created or if it's full allocate new store */
 861     if (!s || s->ptr == &s->store[GC_GMS_STORE_SIZE]) {
 862         s = mem_sys_allocate(sizeof (Gc_gms_hdr_store));
 863         s->ptr = &s->store[0];
 864         s->next = NULL;
 865         /* chain new store to old one */
 866         if (l->first) {
 867             PARROT_ASSERT(l->last);
 868             l->last->next = s;
 869         }
 870         else {
 871             l->first = s;
 872         }
 873         l->last = s;
 874     }
 875     *(s->ptr)++ = h;
 876 }
 877
 878 /*
 879
 880 =item C<static void gc_gms_clear_hdr_list>
 881
 882 RT #48260: Not yet documented!!!
 883
 884 =cut
 885
 886 */
 887
 888 static void
 889 gc_gms_clear_hdr_list(PARROT_INTERP, ARGMOD(Gc_gms_hdr_list *l))
 890 {
 891     Gc_gms_hdr_store *s, *next;
 892
 893     for (s = l->first; s; s = next) {
 894         next = s->next;
 895         mem_sys_free(s);
 896     }
 897     l->first = l->last = NULL;
 898 }
 899
 900 /*
 901
 902 =item C<static void gc_gms_store_igp>
 903
 904 RT #48260: Not yet documented!!!
 905
 906 =cut
 907
 908 */
 909
 910 static void
 911 gc_gms_store_igp(PARROT_INTERP, ARGIN(Gc_gms_hdr *h))
 912 {
 913     Gc_gms_gen * const gen = h->gen;
 914     Gc_gms_hdr_list * const igp = &gen->igp;
 915
 916     gc_gms_store_hdr_list(interp, igp, h);
 917 }
 918
 919 /*
 920
 921 =item C<static void gc_gms_clear_igp>
 922
 923 RT #48260: Not yet documented!!!
 924
 925 =cut
 926
 927 */
 928
 929 static void
 930 gc_gms_clear_igp(PARROT_INTERP, ARGIN(Gc_gms_gen *gen))
 931 {
 932     Gc_gms_hdr_list * const igp = &gen->igp;
 933
 934     gc_gms_clear_hdr_list(interp, igp);
 935 }
 936
 937 /*
 938
 939 =item C<void parrot_gc_gms_wb>
 940
 941 Called by the write barrier. The aggregate belongs to an older generation
 942 then the I<new> value written into it. Put the header of the new value
 943 onto the IGP list for the current generation, if it contains pointers
 944 to other items, and promote it to the old generation.
 945
 946 =cut
 947
 948 */
 949
 950 void
 951 parrot_gc_gms_wb(PARROT_INTERP, ARGIN(PMC *agg), ARGIN(void *old),
 952     ARGIN(void *_new))
 953 {
 954     Gc_gms_hdr * const nh = PObj_to_GMSH(_new);
 955     Gc_gms_hdr * const ah = PObj_to_GMSH(agg);
 956
 957     /* if this may be an aggregate store it in IGP list, thus making
 958      * it a possible root for this generation
 959      */
 960     if (PObj_is_PMC_TEST((PObj *)_new) && ((PMC *)_new)->pmc_ext)
 961         gc_gms_store_igp(interp, nh);
 962
 963     /* promote RHS to old generation of aggregate */
 964     gc_gms_promote(interp, nh, ah->gen->gen_no);
 965
 966     /*
 967      * TODO check old - its overwritten, increment overwrite count,
 968      * if it's an aggregate all contents *may* be dead now, so
 969      * increment overwrite count by elements
 970      */
 971 }
 972
 973 /*
 974
 975 =item C<void parrot_gc_gms_wb_key>
 976
 977 RT #48260: Not yet documented!!!
 978
 979 =cut
 980
 981 */
 982
 983 void
 984 parrot_gc_gms_wb_key(PARROT_INTERP, ARGIN(PMC *agg), ARGIN(void *old),
 985     ARGIN(void *old_key), ARGIN(void *_new), ARGIN(void *new_key))
 986 {
 987     Gc_gms_hdr *nh, *ah;
 988
 989     /* handle hash values */
 990     parrot_gc_gms_wb(interp, agg, old, _new);
 991
 992     /* if hash keys are PObj* then promote new key too */
 993
 994     /* TODO: check if key is a PObj */
 995
 996     nh = PObj_to_GMSH(new_key);
 997     ah = PObj_to_GMSH(agg);
 998
 999     /* promote new key to old generation of aggregate */
1000     gc_gms_promote(interp, nh, ah->gen->gen_no);
1001 }
1002
1003 typedef struct Gc_gms_plan {
1004     int merge_gen;
1005     int gen_no;
1006 } Gc_gms_plan;
1007
1008 /*
1009
1010 =item C<static void gc_gms_merge_gen>
1011
1012 RT #48260: Not yet documented!!!
1013
1014 =cut
1015
1016 */
1017
1018 static void
1019 gc_gms_merge_gen(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool),
1020         int flag, SHIM(Gc_gms_plan *plan))
1021 {
1022     Gc_gms_hdr *h;
1023
1024     /* run through the blacks and set their generation pointer
1025      * to the previous generation
1026      */
1027     Gc_gms_gen * const gen = pool->last_gen;
1028     Gc_gms_gen * const prev = gen->prev;
1029
1030     for (h = pool->black; h != pool->free_list; h = h->next) {
1031         h->gen = prev;
1032         /* TODO update statistics */
1033         /* TODO merge hdrs that need finalization */
1034     }
1035     prev->last = pool->free_list;
1036     /*
1037      * clear IGP for gen
1038      */
1039     gc_gms_clear_igp(interp, gen);
1040 }
1041
1042 /*
1043
1044 =item C<static void gc_gms_use_gen>
1045
1046 RT #48260: Not yet documented!!!
1047
1048 =cut
1049
1050 */
1051
1052 static void
1053 gc_gms_use_gen(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool),
1054         int flag, ARGIN(const Gc_gms_plan *plan))
1055 {
1056     Gc_gms_gen *gen, *prev;
1057     UINTVAL next_gen;
1058
1059     /* set hdr pointers in last generation */
1060     gen        = pool->last_gen;
1061     gen->first = pool->black;
1062     gen->fin   = pool->black_fin;
1063     gen->last  = pool->free_list;
1064
1065     /* create and append a new generation */
1066     next_gen       = plan->gen_no + 1;
1067     gen            = gc_gms_create_gen(interp, pool, next_gen);
1068     prev           = pool->last_gen;
1069     pool->last_gen = gen;
1070     prev->next     = gen;
1071     gen->prev      = prev;
1072
1073     /* set generation in interpreter */
1074     interp->gc_generation = next_gen;
1075 }
1076
1077 /*
1078
1079 =item C<static int set_gen_cb>
1080
1081 RT #48260: Not yet documented!!!
1082
1083 =cut
1084
1085 */
1086
1087 PARROT_WARN_UNUSED_RESULT
1088 static int
1089 set_gen_cb(PARROT_INTERP, ARGIN(Small_Object_Pool *pool), int flag, ARGIN(void *arg))
1090 {
1091     Gc_gms_plan * const plan = (Gc_gms_plan *)arg;
1092
1093     if (plan->merge_gen)
1094         gc_gms_merge_gen(interp, pool, flag, plan);
1095     else
1096         gc_gms_use_gen(interp, pool, flag, plan);
1097     return 0;
1098 }
1099
1100 /*
1101
1102 =item C<static void gc_gms_set_gen>
1103
1104 RT #48260: Not yet documented!!!
1105
1106 =cut
1107
1108 */
1109
1110 static void
1111 gc_gms_set_gen(PARROT_INTERP)
1112 {
1113     Gc_gms_plan plan;
1114     Gc_gms_private *gmsp;
1115     /*
1116      * there are these basic plans
1117      * 1) Use the black as the next old generation
1118      * 2) Merge the blacks to the existing older generation
1119      *    The plan to use depends on the interpreter, specifically, if
1120      *    we are doing a lazy run, entering a new scope, or what not.
1121      * 3) If we are leaving a scope (denoted by a lazy DOD run
1122      *    and we had created one or more generations in this scope
1123      *    go back by resetting the generation number to the outer
1124      *    scope's generation
1125      * 4) Check the overwrite count of older generations. If there is
1126      *    a significant percentage of possibly dead objects, scan
1127      *    older generations too.
1128      *
1129      * TODO only 1 and 2 done for now
1130      *      3) and 4) need to reset live flags of the previous generation(s)
1131      *      or better use the per-generation black_color for marking
1132      */
1133     gmsp = interp->arena_base->gc_private;
1134     plan.merge_gen = 0;
1135     plan.gen_no = gmsp->current_gen_no;
1136     if (gmsp->current_gen_no > 0)
1137         plan.merge_gen = 1;
1138     else
1139         gmsp->current_gen_no = 1;
1140     Parrot_forall_header_pools(interp, POOL_ALL, &plan, set_gen_cb);
1141 }
1142
1143 /*
1144
1145 =back
1146
1147 =head2 Marking functions
1148
1149 Header chain layout
1150
1151 Init: gray := black := white
1152
1153  3) marking the root set
1154
1155  3a) the white 'h' is to be set to gray to be scanned for children
1156
1157  +---+---+---+---+---+---+->      +---+->
1158  | b | b | g | g | g | w          | h |
1159  +---+---+---+---+---+---+      <-+---+
1160    ^       ^           ^
1161    |       |           |
1162    black   gray        white
1163
1164  3b) DFS if 'h' needs timely destruction
1165
1166  +---+---+---+---+---+---+---+->
1167  | b | b | h | g | g | g | w
1168  +---+---+---+---+---+---+---+
1169    ^       ^               ^
1170    |       |               |
1171    black   gray            white
1172
1173
1174  3c) BFS in the normal case
1175
1176  +---+---+---+---+---+---+---+->
1177  | b | b | g | g | g | h | w
1178  +---+---+---+---+---+---+---+
1179    ^       ^               ^
1180    |       |               |
1181    black   gray            white
1182
1183  3d) the white is a scalar and immediately blackened
1184
1185
1186  +---+---+---+---+---+---+---+->
1187  | b | b | h | g | g | g | w
1188  +---+---+---+---+---+---+---+
1189    ^           ^           ^
1190    |           |           |
1191    black       gray        white
1192
1193  3e) blacken the gray 'h' during trace_children
1194
1195  +---+---+---+---+---+---+---+->
1196  | b | b | h | g | g | g | w
1197  +---+---+---+---+---+---+---+
1198    ^       ^               ^
1199    |       |               |
1200    black   gray            white
1201
1202
1203  +---+---+---+---+---+---+---+->
1204  | b | b | h | g | g | g | w
1205  +---+---+---+---+---+---+---+
1206    ^           ^           ^
1207    |           |           |
1208    black       gray        white
1209
1210 =over 4
1211
1212 =cut
1213
1214 */
1215
1216 /*
1217
1218 =item C<static void gc_gms_setto_gray>
1219
1220 Set the white header C<h> to gray.
1221
1222 =cut
1223
1224 */
1225
1226 static void
1227 gc_gms_setto_gray(PARROT_INTERP, ARGIN(Gc_gms_hdr *h), int priority)
1228 {
1229     Small_Object_Pool * const pool = h->gen->pool;
1230     /*
1231      * TODO high_priority like in src/dod.c
1232      */
1233     /*
1234      * if the white is adjacent to gray, move pointer
1235      */
1236     if (pool->white == h && (!priority || pool->white == pool->gray))
1237         pool->white = h->next;
1238     else {
1239         Gc_gms_hdr *next, *prev;
1240
1241         prev = h->prev;
1242         next = h->next;
1243         if (h == pool->white)
1244             pool->white = next;
1245         prev->next = next;
1246         next->prev = prev;
1247
1248         if (priority) {
1249             /* insert at gray */
1250             next = pool->gray;       /* DFS */
1251             pool->gray = h;
1252         }
1253         else {
1254             /* insert before white */
1255             next = pool->white;                  /* BFS */
1256         }
1257         prev = next->prev;
1258         h->next = next;
1259         h->prev = prev;
1260         next->prev = h;
1261         prev->next = h;
1262
1263         /* if there wasn't any gray or black before */
1264         if (pool->gray == pool->white) {
1265             pool->gray = h;
1266             if (pool->black == pool->white) {
1267                 pool->black = h;
1268             }
1269         }
1270     }
1271     PARROT_ASSERT(h != pool->white);
1272     /* verify all these pointer moves */
1273 #  if GC_GMS_DEBUG
1274     gms_debug_verify(interp, pool, "to_gray");
1275 #  endif
1276 }
1277
1278 /*
1279
1280 =item C<static void gc_gms_setto_black>
1281
1282 Set the white header C<h> to black.
1283
1284 =cut
1285
1286 */
1287
1288 static void
1289 gc_gms_setto_black(PARROT_INTERP, ARGMOD(Gc_gms_hdr *h), int priority)
1290 {
1291     Small_Object_Pool * const pool = h->gen->pool;
1292
1293     /*
1294      * TODO high_priority like src/dod.c
1295      * TODO if h needs destructions insert in front of chain
1296      */
1297     /*
1298      * if the white is adjacent to black, move pointer
1299      */
1300     if (pool->black == h) {
1301         PARROT_ASSERT(pool->gray == h);
1302         PARROT_ASSERT(pool->white == h);
1303         pool->white = h->next;
1304         pool->gray = h->next;
1305     }
1306     else {
1307         Gc_gms_hdr *next, *prev;
1308
1309         prev = h->prev;
1310         next = h->next;
1311         if (h == pool->white) {
1312             pool->white = next;
1313             if (h == pool->gray)
1314                 pool->gray = next;
1315         }
1316         prev->next = next;
1317         next->prev = prev;
1318
1319         /* insert before gray */
1320         next = pool->gray;
1321         prev = next->prev;
1322         h->next = next;
1323         h->prev = prev;
1324         next->prev = h;
1325         prev->next = h;
1326         if (pool->black == pool->gray) {
1327             pool->black = h;
1328         }
1329     }
1330     PARROT_ASSERT(h != pool->white);
1331     PARROT_ASSERT(h != pool->gray);
1332 #  if GC_GMS_DEBUG
1333     gms_debug_verify(interp, pool, "to_black");
1334 #  endif
1335 }
1336
1337 /*
1338
1339 =item C<void parrot_gc_gms_pobject_lives>
1340
1341 Set the object live - called by the pobject_lives macro
1342
1343 =cut
1344
1345 */
1346
1347 PARROT_API
1348 void
1349 parrot_gc_gms_pobject_lives(PARROT_INTERP, ARGMOD(PObj *obj))
1350 {
1351     Gc_gms_hdr *h;
1352     int priority;
1353
1354     PObj_live_SET(obj);
1355     priority =  PObj_needs_early_DOD_TEST(obj);
1356     if (priority)
1357         ++interp->arena_base->num_early_PMCs_seen;
1358     h = PObj_to_GMSH(obj);
1359     /* unsnap it from white, put it into gray or black */
1360     if (PObj_is_PMC_TEST(obj) && ((PMC*)obj)->pmc_ext)
1361         gc_gms_setto_gray(interp, h, priority);
1362     else
1363         gc_gms_setto_black(interp, h, priority);
1364 }
1365
1366 /*
1367
1368 =item C<static int init_mark_cb>
1369
1370 RT #48260: Not yet documented!!!
1371
1372 =cut
1373
1374 */
1375
1376 static int
1377 init_mark_cb(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool), int flag, ARGIN(void *arg))
1378 {
1379     pool->gray = pool->black = pool->black_fin = pool->white;
1380 #  if GC_GMS_DEBUG
1381     gms_debug_verify(interp, pool, "init_mark");
1382 #  endif
1383     return 0;
1384 }
1385
1386 /*
1387
1388 =item C<static void gc_gms_init_mark>
1389
1390 Initialize the mark phase of GC.
1391
1392 =cut
1393
1394 */
1395
1396 static void
1397 gc_gms_init_mark(PARROT_INTERP)
1398 {
1399     Arenas * const arena_base = interp->arena_base;
1400
1401     arena_base->dod_trace_ptr = NULL;
1402     arena_base->dod_mark_start = NULL;
1403     arena_base->num_early_PMCs_seen = 0;
1404     arena_base->num_extended_PMCs = 0;
1405
1406     Parrot_forall_header_pools(interp, POOL_ALL, 0, init_mark_cb);
1407 }
1408
1409 /*
1410
1411 =item C<static int trace_igp_cb>
1412
1413 RT #48260: Not yet documented!!!
1414
1415 =cut
1416
1417 */
1418
1419 static int
1420 trace_igp_cb(PARROT_INTERP, ARGIN(Small_Object_Pool *pool), int flag, SHIM(void *arg))
1421 {
1422     Gc_gms_hdr_store *s;
1423     Gc_gms_gen * const gen = pool->last_gen;
1424     Gc_gms_hdr_list * const igp = &gen->igp;
1425
1426     for (s = igp->first; s; s = s->next) {
1427         const Gc_gms_hdr **p;
1428         for (p = s->store; p < s->ptr; ++p) {
1429             Gc_gms_hdr * const h = *p;
1430             pobject_lives(interp, GMSH_to_PObj(h));
1431         }
1432     }
1433     return 0;
1434 }
1435
1436 /*
1437
1438 =item C<static int gc_gms_trace_root>
1439
1440 Trace the root set. If C<trace_stack> is true, trace system areas.
1441
1442 =cut
1443
1444 */
1445
1446 static int
1447 gc_gms_trace_root(PARROT_INTERP, int trace_stack)
1448 {
1449     const int ret = Parrot_dod_trace_root(interp, trace_stack);
1450
1451     if (ret == 0)
1452         return 0;
1453     Parrot_forall_header_pools(interp, POOL_ALL, 0, trace_igp_cb);
1454     return ret;
1455 }
1456
1457 /*
1458
1459 =item C<static int trace_children_cb>
1460
1461 RT #48260: Not yet documented!!!
1462
1463 =cut
1464
1465 */
1466
1467 static int
1468 trace_children_cb(PARROT_INTERP, ARGIN(Small_Object_Pool *pool), int flag, SHIM(void *arg))
1469 {
1470     Arenas * const arena_base = interp->arena_base;
1471     const int lazy_dod = arena_base->lazy_dod;
1472     const UINTVAL mask = PObj_data_is_PMC_array_FLAG | PObj_custom_mark_FLAG;
1473     Gc_gms_hdr *h;
1474
1475     for (h = pool->gray; h != pool->white;) {
1476         PMC * const current = (PMC*)GMSH_to_PObj(h);
1477         UINTVAL bits;
1478
1479         if (lazy_dod && arena_base->num_early_PMCs_seen >=
1480                 arena_base->num_early_DOD_PMCs) {
1481             return 1;
1482         }
1483         /* TODO propagate flag in pobject_lives */
1484         arena_base->dod_trace_ptr = current;
1485         if (!PObj_needs_early_DOD_TEST(current))
1486             PObj_high_priority_DOD_CLEAR(current);
1487         /* mark children */
1488         bits = PObj_get_FLAGS(current) & mask;
1489         if (bits) {
1490             if (bits == PObj_data_is_PMC_array_FLAG) {
1491                 /* malloced array of PMCs */
1492                 PMC ** const data = PMC_data(current);
1493
1494                 if (data) {
1495                     INTVAL i;
1496                     for (i = 0; i < PMC_int_val(current); i++) {
1497                         if (data[i]) {
1498                             pobject_lives(interp, (PObj *)data[i]);
1499                         }
1500                     }
1501                 }
1502             }
1503             else {
1504                 /* All that's left is the custom */
1505                 VTABLE_mark(interp, current);
1506             }
1507         }
1508         if (h != pool->gray) {
1509             /* if a gray was inserted DFS, it is next */
1510             h = pool->gray;
1511         }
1512         else {
1513             h = h->next;
1514             pool->gray = h;
1515         }
1516     }
1517     return 0;
1518 }
1519
1520 /*
1521
1522 =item C<static int gc_gms_trace_children>
1523
1524 Traverse gray objects: mark and blacken. Returns 0 if the trace was aborted
1525 lazily.
1526
1527 =cut
1528
1529 */
1530
1531 static int
1532 gc_gms_trace_children(PARROT_INTERP)
1533 {
1534     return !Parrot_forall_header_pools(interp, POOL_PMC, 0,
1535             trace_children_cb);
1536 }
1537
1538 /*
1539
1540 =item C<static int sweep_cb_pmc>
1541
1542 move everything from white up to the free_list to the free_list
1543 scan for active destroy objects
1544 TODO put these in front of the pool at pool->white_fin
1545
1546 =cut
1547
1548 */
1549
1550 static int
1551 sweep_cb_pmc(PARROT_INTERP, ARGIN(Small_Object_Pool *pool), int flag, SHIM(void *arg))
1552 {
1553     Gc_gms_hdr *h;
1554     Arenas * const arena_base = interp->arena_base;
1555
1556     /* TODO object stats */
1557
1558     for (h = pool->white; h != pool->free_list; h = h->next) {
1559         PMC * const obj = (PMC*)GMSH_to_PObj(h);
1560         if (PObj_needs_early_DOD_TEST(obj))
1561             --arena_base->num_early_DOD_PMCs;
1562         if (PObj_active_destroy_TEST(obj))
1563             VTABLE_destroy(interp, (PMC *)obj);
1564         if (PObj_is_PMC_EXT_TEST(obj) && obj->pmc_ext) {
1565             /* if the PMC has a PMC_EXT structure,
1566              * return it to the pool
1567              */
1568             Small_Object_Pool * const ext_pool = arena_base->pmc_ext_pool;
1569             ext_pool->add_free_object(interp, ext_pool, obj->pmc_ext);
1570         }
1571
1572     }
1573     pool->free_list = pool->white;
1574     return 0;
1575 }
1576
1577 /*
1578
1579 =item C<static int sweep_cb_buf>
1580
1581 RT #48260: Not yet documented!!!
1582
1583 =cut
1584
1585 */
1586
1587 static int
1588 sweep_cb_buf(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool), int flag, SHIM(void *arg))
1589 {
1590     Gc_gms_hdr *h;
1591
1592     /* TODO object stats */
1593
1594     for (h = pool->white; h != pool->free_list; h = h->next) {
1595         PObj * const obj = GMSH_to_PObj(h);
1596         /*
1597          * this is ugly, we still have to sweep all buffers
1598          */
1599         if (PObj_sysmem_TEST(obj) && PObj_bufstart(obj)) {
1600             /* has sysmem allocated, e.g. string_pin */
1601             mem_sys_free(PObj_bufstart(obj));
1602             PObj_bufstart(obj) = NULL;
1603             PObj_buflen(obj) = 0;
1604         }
1605         else {
1606 #  ifdef GC_IS_MALLOC
1607             /* free allocated space at (int*)bufstart - 1,
1608              * but not if it is used COW or external
1609              */
1610             if (PObj_bufstart(obj) &&
1611                     !PObj_is_external_or_free_TESTALL(obj)) {
1612                 if (PObj_COW_TEST(obj)) {
1613                     INTVAL *refcount = PObj_bufrefcountptr(obj);
1614
1615                     if (!--(*refcount))
1616                         free(refcount); /* the actual bufstart */
1617                 }
1618                 else
1619                     free(PObj_bufrefcountptr(obj));
1620             }
1621 #  else
1622             /*
1623              * XXX Jarkko did report that on irix pool->mem_pool
1624              *     was NULL, which really shouldn't happen
1625              */
1626             if (pool->mem_pool) {
1627                 if (!PObj_COW_TEST(obj)) {
1628                     ((Memory_Pool *)
1629                      pool->mem_pool)->guaranteed_reclaimable +=
1630                         PObj_buflen(obj);
1631                 }
1632                 ((Memory_Pool *)
1633                  pool->mem_pool)->possibly_reclaimable +=
1634                     PObj_buflen(obj);
1635             }
1636 #  endif
1637             PObj_buflen(obj) = 0;
1638         }
1639     }
1640     pool->free_list = pool->white;
1641     return 0;
1642 }
1643
1644 /*
1645
1646 =item C<static void gc_gms_sweep>
1647
1648 Free unused resources, put white objects onto free_list.
1649
1650 =cut
1651
1652 */
1653
1654 static void
1655 gc_gms_sweep(PARROT_INTERP)
1656 {
1657     Parrot_forall_header_pools(interp, POOL_PMC, 0, sweep_cb_pmc);
1658     Parrot_forall_header_pools(interp, POOL_BUFFER, 0, sweep_cb_buf);
1659 }
1660
1661 /*
1662
1663 =item C<static int end_cycle_cb>
1664
1665 RT #48260: Not yet documented!!!
1666
1667 =cut
1668
1669 */
1670
1671 static int
1672 end_cycle_cb(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool), int flag, SHIM(void *arg))
1673 {
1674     Gc_gms_hdr *h;
1675     /*
1676      * clear live flags
1677      * TODO just swap black and white
1678      */
1679     if (!pool->black || pool->black == &pool->marker)
1680         return 0;
1681     for (h = pool->black; h != pool->white; h = h->next)
1682         PObj_live_CLEAR(GMSH_to_PObj(h));
1683     pool->black = pool->black_fin = pool->gray = pool->white;
1684     return 0;
1685 }
1686
1687 /*
1688
1689 =item C<static void gc_gms_end_cycle>
1690
1691 RT #48260: Not yet documented!!!
1692
1693 =cut
1694
1695 */
1696
1697 static void
1698 gc_gms_end_cycle(PARROT_INTERP)
1699 {
1700     Parrot_forall_header_pools(interp, POOL_ALL, 0, end_cycle_cb);
1701 }
1702
1703 /*
1704
1705 =back
1706
1707 =head2 Interface function main entry
1708
1709 =over 4
1710
1711 =item C<static void parrot_gc_gms_run>
1712
1713 Interface to C<Parrot_do_dod_run>. C<flags> is one of:
1714
1715   GC_lazy_FLAG   ... timely destruction
1716   GC_finish_FLAG ... run a final sweep to destruct objects at
1717                       interpreter shutdown
1718
1719 =cut
1720
1721 */
1722
1723 static void
1724 parrot_gc_gms_run(PARROT_INTERP, int flags)
1725 {
1726     Arenas * const arena_base = interp->arena_base;
1727     Gc_gms_private *g_gms;
1728
1729     if (arena_base->DOD_block_level) {
1730         return;
1731     }
1732     ++arena_base->DOD_block_level;
1733     g_gms = arena_base->gc_private;
1734     if (flags & GC_finish_FLAG) {
1735         Small_Object_Pool * const pool = arena_base->pmc_pool;
1736
1737         pool->white = pool->marker.next;
1738         /* XXX need to sweep over objects that have finalizers only */
1739         Parrot_forall_header_pools(interp, POOL_PMC, 0, sweep_cb_pmc);
1740         gc_gms_end_cycle(interp);
1741         --arena_base->DOD_block_level;
1742         return;
1743     }
1744
1745     /* normal or lazy DOD run */
1746     arena_base->dod_runs++;
1747     arena_base->lazy_dod = (flags & GC_lazy_FLAG);
1748     gc_gms_init_mark(interp);
1749     if (gc_gms_trace_root(interp, !arena_base->lazy_dod) &&
1750             gc_gms_trace_children(interp)) {
1751         gc_gms_sweep(interp);
1752         gc_gms_set_gen(interp);
1753     }
1754     else {
1755         /*
1756          * successful lazy DOD run
1757          */
1758         ++arena_base->lazy_dod_runs;
1759     }
1760     gc_gms_end_cycle(interp);
1761     --arena_base->DOD_block_level;
1762 }
1763
1764 /*
1765
1766 =item C<static void gms_debug_verify>
1767
1768 RT #48260: Not yet documented!!!
1769
1770 =cut
1771
1772 */
1773
1774 #  if GC_GMS_DEBUG
1775 static void
1776 gms_debug_verify(PARROT_INTERP, ARGMOD(Small_Object_Pool *pool), ARGIN(const char *action))
1777 {
1778     Gc_gms_hdr *h;
1779     int bf, gf, wf, ff;
1780     size_t i;
1781
1782     const size_t n = pool->total_objects;
1783
1784     bf = gf = wf = ff = 0;
1785
1786
1787     for (i = 0, h = &pool->marker; i <= n + 10; ++i) {
1788         if (i && h == &pool->marker)
1789             break;
1790         if (h == pool->black)
1791             bf++;
1792         if (h == pool->gray)
1793             gf++;
1794         if (h == pool->white)
1795             wf++;
1796         if (h == pool->free_list)
1797             ff++;
1798         h = h->next;
1799     }
1800     if (i != n + 1)
1801         fprintf(stderr, "gms_verify %s: chain corrupt %u objs %u total\n",
1802                 action, i, n);
1803     if (bf != 1)
1804         fprintf(stderr, "gms_verify %s: found %u blacks\n", action, bf);
1805     if (gf != 1)
1806         fprintf(stderr, "gms_verify %s: found %u grays\n", action, gf);
1807     if (wf != 1)
1808         fprintf(stderr, "gms_verify %s: found %u whites\n", action, wf);
1809     if (ff != 1)
1810         fprintf(stderr, "gms_verify %s: found %u frees\n", action, ff);
1811 }
1812
1813
1814 #  endif  /* GC_GMS_DEBUG */
1815
1816 #endif  /* PARROT_GC_GMS */
1817
1818 /*
1819
1820 =back
1821
1822 =head1 SEE ALSO
1823
1824 F<src/gc/dod.c>, F<include/parrot/dod.h>, F<include/parrot/pobj.h>,
1825 F<src/gc/gc_ims.c>
1826
1827 =head1 HISTORY
1828
1829 Initial version by leo (2005.01.12 - 2005.01.30)
1830
1831 =cut
1832
1833 */
1834
1835
1836 /*
1837  * Local variables:
1838  *   c-file-style: "parrot"
1839  * End:
1840  * vim: expandtab shiftwidth=4:
1841  */