ghc/rts/RetainerProfile.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RetainerProfile.c,v 1.12 2004/09/03 15:28:38 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 2001
   5  * Author: Sungwoo Park
   6  *
   7  * Retainer profiling.
   8  *
   9  * ---------------------------------------------------------------------------*/
  10
  11 #ifdef PROFILING
  12
  13 // Turn off inlining when debugging - it obfuscates things
  14 #ifdef DEBUG
  15 #define INLINE
  16 #else
  17 #define INLINE inline
  18 #endif
  19
  20 #include "Rts.h"
  21 #include "RtsUtils.h"
  22 #include "RetainerProfile.h"
  23 #include "RetainerSet.h"
  24 #include "Schedule.h"
  25 #include "Printer.h"
  26 #include "Storage.h"
  27 #include "RtsFlags.h"
  28 #include "Weak.h"
  29 #include "Sanity.h"
  30 #include "Profiling.h"
  31 #include "Stats.h"
  32 #include "BlockAlloc.h"
  33 #include "ProfHeap.h"
  34 #include "Apply.h"
  35
  36 /*
  37   Note: what to change in order to plug-in a new retainer profiling scheme?
  38     (1) type retainer in ../includes/StgRetainerProf.h
  39     (2) retainer function R(), i.e., getRetainerFrom()
  40     (3) the two hashing functions, hashKeySingleton() and hashKeyAddElement(),
  41         in RetainerSet.h, if needed.
  42     (4) printRetainer() and printRetainerSetShort() in RetainerSet.c.
  43  */
  44
  45 /* -----------------------------------------------------------------------------
  46  * Declarations...
  47  * -------------------------------------------------------------------------- */
  48
  49 static nat retainerGeneration;  // generation
  50
  51 static nat numObjectVisited;    // total number of objects visited
  52 static nat timesAnyObjectVisited; // number of times any objects are visited
  53
  54 /*
  55   The rs field in the profile header of any object points to its retainer
  56   set in an indirect way: if flip is 0, it points to the retainer set;
  57   if flip is 1, it points to the next byte after the retainer set (even
  58   for NULL pointers). Therefore, with flip 1, (rs ^ 1) is the actual
  59   pointer. See retainerSetOf().
  60  */
  61
  62 StgWord flip = 0;     // flip bit
  63                       // must be 0 if DEBUG_RETAINER is on (for static closures)
  64
  65 #define setRetainerSetToNull(c)   \
  66   (c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
  67
  68 static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
  69 static void retainClosure(StgClosure *, StgClosure *, retainer);
  70 #ifdef DEBUG_RETAINER
  71 static void belongToHeap(StgPtr p);
  72 #endif
  73
  74 #ifdef DEBUG_RETAINER
  75 /*
  76   cStackSize records how many times retainStack() has been invoked recursively,
  77   that is, the number of activation records for retainStack() on the C stack.
  78   maxCStackSize records its max value.
  79   Invariants:
  80     cStackSize <= maxCStackSize
  81  */
  82 static nat cStackSize, maxCStackSize;
  83
  84 static nat sumOfNewCost;        // sum of the cost of each object, computed
  85                                 // when the object is first visited
  86 static nat sumOfNewCostExtra;   // for those objects not visited during
  87                                 // retainer profiling, e.g., MUT_VAR
  88 static nat costArray[N_CLOSURE_TYPES];
  89
  90 nat sumOfCostLinear;            // sum of the costs of all object, computed
  91                                 // when linearly traversing the heap after
  92                                 // retainer profiling
  93 nat costArrayLinear[N_CLOSURE_TYPES];
  94 #endif
  95
  96 /* -----------------------------------------------------------------------------
  97  * Retainer stack - header
  98  *   Note:
  99  *     Although the retainer stack implementation could be separated *
 100  *     from the retainer profiling engine, there does not seem to be
 101  *     any advantage in doing that; retainer stack is an integral part
 102  *     of retainer profiling engine and cannot be use elsewhere at
 103  *     all.
 104  * -------------------------------------------------------------------------- */
 105
 106 typedef enum {
 107     posTypeStep,
 108     posTypePtrs,
 109     posTypeSRT,
 110     posTypeLargeSRT,
 111 } nextPosType;
 112
 113 typedef union {
 114     // fixed layout or layout specified by a field in the closure
 115     StgWord step;
 116
 117     // layout.payload
 118     struct {
 119     // See StgClosureInfo in InfoTables.h
 120 #if SIZEOF_VOID_P == 8
 121         StgWord32 pos;
 122         StgWord32 ptrs;
 123 #else
 124         StgWord16 pos;
 125         StgWord16 ptrs;
 126 #endif
 127         StgPtr payload;
 128     } ptrs;
 129
 130     // SRT
 131     struct {
 132         StgClosure **srt;
 133         StgWord    srt_bitmap;
 134     } srt;
 135
 136     // Large SRT
 137     struct {
 138         StgLargeSRT *srt;
 139         StgWord offset;
 140     } large_srt;
 141
 142 } nextPos;
 143
 144 typedef struct {
 145     nextPosType type;
 146     nextPos next;
 147 } stackPos;
 148
 149 typedef struct {
 150     StgClosure *c;
 151     retainer c_child_r;
 152     stackPos info;
 153 } stackElement;
 154
 155 /*
 156   Invariants:
 157     firstStack points to the first block group.
 158     currentStack points to the block group currently being used.
 159     currentStack->free == stackLimit.
 160     stackTop points to the topmost byte in the stack of currentStack.
 161     Unless the whole stack is empty, stackTop must point to the topmost
 162     object (or byte) in the whole stack. Thus, it is only when the whole stack
 163     is empty that stackTop == stackLimit (not during the execution of push()
 164     and pop()).
 165     stackBottom == currentStack->start.
 166     stackLimit == currentStack->start + BLOCK_SIZE_W * currentStack->blocks.
 167   Note:
 168     When a current stack becomes empty, stackTop is set to point to
 169     the topmost element on the previous block group so as to satisfy
 170     the invariants described above.
 171  */
 172 static bdescr *firstStack = NULL;
 173 static bdescr *currentStack;
 174 static stackElement *stackBottom, *stackTop, *stackLimit;
 175
 176 /*
 177   currentStackBoundary is used to mark the current stack chunk.
 178   If stackTop == currentStackBoundary, it means that the current stack chunk
 179   is empty. It is the responsibility of the user to keep currentStackBoundary
 180   valid all the time if it is to be employed.
 181  */
 182 static stackElement *currentStackBoundary;
 183
 184 /*
 185   stackSize records the current size of the stack.
 186   maxStackSize records its high water mark.
 187   Invariants:
 188     stackSize <= maxStackSize
 189   Note:
 190     stackSize is just an estimate measure of the depth of the graph. The reason
 191     is that some heap objects have only a single child and may not result
 192     in a new element being pushed onto the stack. Therefore, at the end of
 193     retainer profiling, maxStackSize + maxCStackSize is some value no greater
 194     than the actual depth of the graph.
 195  */
 196 #ifdef DEBUG_RETAINER
 197 static int stackSize, maxStackSize;
 198 #endif
 199
 200 // number of blocks allocated for one stack
 201 #define BLOCKS_IN_STACK 1
 202
 203 /* -----------------------------------------------------------------------------
 204  * Add a new block group to the stack.
 205  * Invariants:
 206  *  currentStack->link == s.
 207  * -------------------------------------------------------------------------- */
 208 static INLINE void
 209 newStackBlock( bdescr *bd )
 210 {
 211     currentStack = bd;
 212     stackTop     = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
 213     stackBottom  = (stackElement *)bd->start;
 214     stackLimit   = (stackElement *)stackTop;
 215     bd->free     = (StgPtr)stackLimit;
 216 }
 217
 218 /* -----------------------------------------------------------------------------
 219  * Return to the previous block group.
 220  * Invariants:
 221  *   s->link == currentStack.
 222  * -------------------------------------------------------------------------- */
 223 static INLINE void
 224 returnToOldStack( bdescr *bd )
 225 {
 226     currentStack = bd;
 227     stackTop = (stackElement *)bd->free;
 228     stackBottom = (stackElement *)bd->start;
 229     stackLimit = (stackElement *)(bd->start + BLOCK_SIZE_W * bd->blocks);
 230     bd->free = (StgPtr)stackLimit;
 231 }
 232
 233 /* -----------------------------------------------------------------------------
 234  *  Initializes the traverse stack.
 235  * -------------------------------------------------------------------------- */
 236 static void
 237 initializeTraverseStack( void )
 238 {
 239     if (firstStack != NULL) {
 240         freeChain(firstStack);
 241     }
 242
 243     firstStack = allocGroup(BLOCKS_IN_STACK);
 244     firstStack->link = NULL;
 245     firstStack->u.back = NULL;
 246
 247     newStackBlock(firstStack);
 248 }
 249
 250 /* -----------------------------------------------------------------------------
 251  * Frees all the block groups in the traverse stack.
 252  * Invariants:
 253  *   firstStack != NULL
 254  * -------------------------------------------------------------------------- */
 255 static void
 256 closeTraverseStack( void )
 257 {
 258     freeChain(firstStack);
 259     firstStack = NULL;
 260 }
 261
 262 /* -----------------------------------------------------------------------------
 263  * Returns rtsTrue if the whole stack is empty.
 264  * -------------------------------------------------------------------------- */
 265 static INLINE rtsBool
 266 isEmptyRetainerStack( void )
 267 {
 268     return (firstStack == currentStack) && stackTop == stackLimit;
 269 }
 270
 271 /* -----------------------------------------------------------------------------
 272  * Returns size of stack
 273  * -------------------------------------------------------------------------- */
 274 #ifdef DEBUG
 275 lnat
 276 retainerStackBlocks( void )
 277 {
 278     bdescr* bd;
 279     lnat res = 0;
 280
 281     for (bd = firstStack; bd != NULL; bd = bd->link)
 282       res += bd->blocks;
 283
 284     return res;
 285 }
 286 #endif
 287
 288 /* -----------------------------------------------------------------------------
 289  * Returns rtsTrue if stackTop is at the stack boundary of the current stack,
 290  * i.e., if the current stack chunk is empty.
 291  * -------------------------------------------------------------------------- */
 292 static INLINE rtsBool
 293 isOnBoundary( void )
 294 {
 295     return stackTop == currentStackBoundary;
 296 }
 297
 298 /* -----------------------------------------------------------------------------
 299  * Initializes *info from ptrs and payload.
 300  * Invariants:
 301  *   payload[] begins with ptrs pointers followed by non-pointers.
 302  * -------------------------------------------------------------------------- */
 303 static INLINE void
 304 init_ptrs( stackPos *info, nat ptrs, StgPtr payload )
 305 {
 306     info->type              = posTypePtrs;
 307     info->next.ptrs.pos     = 0;
 308     info->next.ptrs.ptrs    = ptrs;
 309     info->next.ptrs.payload = payload;
 310 }
 311
 312 /* -----------------------------------------------------------------------------
 313  * Find the next object from *info.
 314  * -------------------------------------------------------------------------- */
 315 static INLINE StgClosure *
 316 find_ptrs( stackPos *info )
 317 {
 318     if (info->next.ptrs.pos < info->next.ptrs.ptrs) {
 319         return (StgClosure *)info->next.ptrs.payload[info->next.ptrs.pos++];
 320     } else {
 321         return NULL;
 322     }
 323 }
 324
 325 /* -----------------------------------------------------------------------------
 326  *  Initializes *info from SRT information stored in *infoTable.
 327  * -------------------------------------------------------------------------- */
 328 static INLINE void
 329 init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
 330 {
 331     if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
 332         info->type = posTypeLargeSRT;
 333         info->next.large_srt.srt = (StgLargeSRT *)infoTable->f.srt;
 334         info->next.large_srt.offset = 0;
 335     } else {
 336         info->type = posTypeSRT;
 337         info->next.srt.srt = (StgClosure **)(infoTable->f.srt);
 338         info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
 339     }
 340 }
 341
 342 static INLINE void
 343 init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
 344 {
 345     if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
 346         info->type = posTypeLargeSRT;
 347         info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
 348         info->next.large_srt.offset = 0;
 349     } else {
 350         info->type = posTypeSRT;
 351         info->next.srt.srt = (StgClosure **)(infoTable->srt);
 352         info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
 353     }
 354 }
 355
 356 /* -----------------------------------------------------------------------------
 357  * Find the next object from *info.
 358  * -------------------------------------------------------------------------- */
 359 static INLINE StgClosure *
 360 find_srt( stackPos *info )
 361 {
 362     StgClosure *c;
 363     StgWord bitmap;
 364
 365     if (info->type == posTypeSRT) {
 366         // Small SRT bitmap
 367         bitmap = info->next.srt.srt_bitmap;
 368         while (bitmap != 0) {
 369             if ((bitmap & 1) != 0) {
 370 #ifdef ENABLE_WIN32_DLL_SUPPORT
 371
 372                 if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
 373                     c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
 374                 else
 375                     c = *(info->next.srt.srt);
 376 #else
 377                 c = *(info->next.srt.srt);
 378 #endif
 379                 bitmap = bitmap >> 1;
 380                 info->next.srt.srt++;
 381                 info->next.srt.srt_bitmap = bitmap;
 382                 return c;
 383             }
 384             bitmap = bitmap >> 1;
 385             info->next.srt.srt++;
 386         }
 387         // bitmap is now zero...
 388         return NULL;
 389     }
 390     else {
 391         // Large SRT bitmap
 392         nat i = info->next.large_srt.offset;
 393         StgWord bitmap;
 394
 395         // Follow the pattern from GC.c:scavenge_large_srt_bitmap().
 396         bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
 397         bitmap = bitmap >> (i % BITS_IN(StgWord));
 398         while (i < info->next.large_srt.srt->l.size) {
 399             if ((bitmap & 1) != 0) {
 400                 c = ((StgClosure **)info->next.large_srt.srt->srt)[i];
 401                 i++;
 402                 info->next.large_srt.offset = i;
 403                 return c;
 404             }
 405             i++;
 406             if (i % BITS_IN(W_) == 0) {
 407                 bitmap = info->next.large_srt.srt->l.bitmap[i / BITS_IN(W_)];
 408             } else {
 409                 bitmap = bitmap >> 1;
 410             }
 411         }
 412         // reached the end of this bitmap.
 413         info->next.large_srt.offset = i;
 414         return NULL;
 415     }
 416 }
 417
 418 /* -----------------------------------------------------------------------------
 419  *  push() pushes a stackElement representing the next child of *c
 420  *  onto the traverse stack. If *c has no child, *first_child is set
 421  *  to NULL and nothing is pushed onto the stack. If *c has only one
 422  *  child, *c_chlid is set to that child and nothing is pushed onto
 423  *  the stack.  If *c has more than two children, *first_child is set
 424  *  to the first child and a stackElement representing the second
 425  *  child is pushed onto the stack.
 426
 427  *  Invariants:
 428  *     *c_child_r is the most recent retainer of *c's children.
 429  *     *c is not any of TSO, AP, PAP, AP_STACK, which means that
 430  *        there cannot be any stack objects.
 431  *  Note: SRTs are considered to  be children as well.
 432  * -------------------------------------------------------------------------- */
 433 static INLINE void
 434 push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 435 {
 436     stackElement se;
 437     bdescr *nbd;      // Next Block Descriptor
 438
 439 #ifdef DEBUG_RETAINER
 440     // debugBelch("push(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
 441 #endif
 442
 443     ASSERT(get_itbl(c)->type != TSO);
 444     ASSERT(get_itbl(c)->type != AP_STACK);
 445
 446     //
 447     // fill in se
 448     //
 449
 450     se.c = c;
 451     se.c_child_r = c_child_r;
 452
 453     // fill in se.info
 454     switch (get_itbl(c)->type) {
 455         // no child, no SRT
 456     case CONSTR_0_1:
 457     case CONSTR_0_2:
 458     case CAF_BLACKHOLE:
 459     case BLACKHOLE:
 460     case SE_BLACKHOLE:
 461     case SE_CAF_BLACKHOLE:
 462     case ARR_WORDS:
 463         *first_child = NULL;
 464         return;
 465
 466         // one child (fixed), no SRT
 467     case MUT_VAR:
 468     case MUT_CONS:
 469         *first_child = ((StgMutVar *)c)->var;
 470         return;
 471     case BLACKHOLE_BQ:
 472         // blocking_queue must be TSO and the head of a linked list of TSOs.
 473         // Shoule it be a child? Seems to be yes.
 474         *first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
 475         return;
 476     case THUNK_SELECTOR:
 477         *first_child = ((StgSelector *)c)->selectee;
 478         return;
 479     case IND_PERM:
 480     case IND_OLDGEN_PERM:
 481     case IND_OLDGEN:
 482         *first_child = ((StgIndOldGen *)c)->indirectee;
 483         return;
 484     case CONSTR_1_0:
 485     case CONSTR_1_1:
 486         *first_child = c->payload[0];
 487         return;
 488
 489         // For CONSTR_2_0 and MVAR, we use se.info.step to record the position
 490         // of the next child. We do not write a separate initialization code.
 491         // Also we do not have to initialize info.type;
 492
 493         // two children (fixed), no SRT
 494         // need to push a stackElement, but nothing to store in se.info
 495     case CONSTR_2_0:
 496         *first_child = c->payload[0];         // return the first pointer
 497         // se.info.type = posTypeStep;
 498         // se.info.next.step = 2;            // 2 = second
 499         break;
 500
 501         // three children (fixed), no SRT
 502         // need to push a stackElement
 503     case MVAR:
 504         // head must be TSO and the head of a linked list of TSOs.
 505         // Shoule it be a child? Seems to be yes.
 506         *first_child = (StgClosure *)((StgMVar *)c)->head;
 507         // se.info.type = posTypeStep;
 508         se.info.next.step = 2;            // 2 = second
 509         break;
 510
 511         // three children (fixed), no SRT
 512     case WEAK:
 513         *first_child = ((StgWeak *)c)->key;
 514         // se.info.type = posTypeStep;
 515         se.info.next.step = 2;
 516         break;
 517
 518         // layout.payload.ptrs, no SRT
 519     case CONSTR:
 520     case FOREIGN:
 521     case STABLE_NAME:
 522     case BCO:
 523     case CONSTR_STATIC:
 524         init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs,
 525                   (StgPtr)c->payload);
 526         *first_child = find_ptrs(&se.info);
 527         if (*first_child == NULL)
 528             return;   // no child
 529         break;
 530
 531         // StgMutArrPtr.ptrs, no SRT
 532     case MUT_ARR_PTRS:
 533     case MUT_ARR_PTRS_FROZEN:
 534         init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
 535                   (StgPtr)(((StgMutArrPtrs *)c)->payload));
 536         *first_child = find_ptrs(&se.info);
 537         if (*first_child == NULL)
 538             return;
 539         break;
 540
 541     // layout.payload.ptrs, SRT
 542     case FUN:           // *c is a heap object.
 543     case FUN_2_0:
 544         init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
 545         *first_child = find_ptrs(&se.info);
 546         if (*first_child == NULL)
 547             // no child from ptrs, so check SRT
 548             goto fun_srt_only;
 549         break;
 550
 551     case THUNK:
 552     case THUNK_2_0:
 553         init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
 554         *first_child = find_ptrs(&se.info);
 555         if (*first_child == NULL)
 556             // no child from ptrs, so check SRT
 557             goto thunk_srt_only;
 558         break;
 559
 560         // 1 fixed child, SRT
 561     case FUN_1_0:
 562     case FUN_1_1:
 563         *first_child = c->payload[0];
 564         ASSERT(*first_child != NULL);
 565         init_srt_fun(&se.info, get_fun_itbl(c));
 566         break;
 567
 568     case THUNK_1_0:
 569     case THUNK_1_1:
 570         *first_child = c->payload[0];
 571         ASSERT(*first_child != NULL);
 572         init_srt_thunk(&se.info, get_thunk_itbl(c));
 573         break;
 574
 575     case FUN_STATIC:      // *c is a heap object.
 576         ASSERT(get_itbl(c)->srt_bitmap != 0);
 577     case FUN_0_1:
 578     case FUN_0_2:
 579     fun_srt_only:
 580         init_srt_fun(&se.info, get_fun_itbl(c));
 581         *first_child = find_srt(&se.info);
 582         if (*first_child == NULL)
 583             return;     // no child
 584         break;
 585
 586     // SRT only
 587     case THUNK_STATIC:
 588         ASSERT(get_itbl(c)->srt_bitmap != 0);
 589     case THUNK_0_1:
 590     case THUNK_0_2:
 591     thunk_srt_only:
 592         init_srt_thunk(&se.info, get_thunk_itbl(c));
 593         *first_child = find_srt(&se.info);
 594         if (*first_child == NULL)
 595             return;     // no child
 596         break;
 597
 598         // cannot appear
 599     case PAP:
 600     case AP:
 601     case AP_STACK:
 602     case TSO:
 603     case IND_STATIC:
 604     case CONSTR_INTLIKE:
 605     case CONSTR_CHARLIKE:
 606     case CONSTR_NOCAF_STATIC:
 607         // stack objects
 608     case UPDATE_FRAME:
 609     case CATCH_FRAME:
 610     case STOP_FRAME:
 611     case RET_DYN:
 612     case RET_BCO:
 613     case RET_SMALL:
 614     case RET_VEC_SMALL:
 615     case RET_BIG:
 616     case RET_VEC_BIG:
 617         // invalid objects
 618     case IND:
 619     case BLOCKED_FETCH:
 620     case FETCH_ME:
 621     case FETCH_ME_BQ:
 622     case RBH:
 623     case REMOTE_REF:
 624     case EVACUATED:
 625     case INVALID_OBJECT:
 626     default:
 627         barf("Invalid object *c in push()");
 628         return;
 629     }
 630
 631     if (stackTop - 1 < stackBottom) {
 632 #ifdef DEBUG_RETAINER
 633         // debugBelch("push() to the next stack.\n");
 634 #endif
 635         // currentStack->free is updated when the active stack is switched
 636         // to the next stack.
 637         currentStack->free = (StgPtr)stackTop;
 638
 639         if (currentStack->link == NULL) {
 640             nbd = allocGroup(BLOCKS_IN_STACK);
 641             nbd->link = NULL;
 642             nbd->u.back = currentStack;
 643             currentStack->link = nbd;
 644         } else
 645             nbd = currentStack->link;
 646
 647         newStackBlock(nbd);
 648     }
 649
 650     // adjust stackTop (acutal push)
 651     stackTop--;
 652     // If the size of stackElement was huge, we would better replace the
 653     // following statement by either a memcpy() call or a switch statement
 654     // on the type of the element. Currently, the size of stackElement is
 655     // small enough (5 words) that this direct assignment seems to be enough.
 656     *stackTop = se;
 657
 658 #ifdef DEBUG_RETAINER
 659     stackSize++;
 660     if (stackSize > maxStackSize) maxStackSize = stackSize;
 661     // ASSERT(stackSize >= 0);
 662     // debugBelch("stackSize = %d\n", stackSize);
 663 #endif
 664 }
 665
 666 /* -----------------------------------------------------------------------------
 667  *  popOff() and popOffReal(): Pop a stackElement off the traverse stack.
 668  *  Invariants:
 669  *    stackTop cannot be equal to stackLimit unless the whole stack is
 670  *    empty, in which case popOff() is not allowed.
 671  *  Note:
 672  *    You can think of popOffReal() as a part of popOff() which is
 673  *    executed at the end of popOff() in necessary. Since popOff() is
 674  *    likely to be executed quite often while popOffReal() is not, we
 675  *    separate popOffReal() from popOff(), which is declared as an
 676  *    INLINE function (for the sake of execution speed).  popOffReal()
 677  *    is called only within popOff() and nowhere else.
 678  * -------------------------------------------------------------------------- */
 679 static void
 680 popOffReal(void)
 681 {
 682     bdescr *pbd;    // Previous Block Descriptor
 683
 684 #ifdef DEBUG_RETAINER
 685     // debugBelch("pop() to the previous stack.\n");
 686 #endif
 687
 688     ASSERT(stackTop + 1 == stackLimit);
 689     ASSERT(stackBottom == (stackElement *)currentStack->start);
 690
 691     if (firstStack == currentStack) {
 692         // The stack is completely empty.
 693         stackTop++;
 694         ASSERT(stackTop == stackLimit);
 695 #ifdef DEBUG_RETAINER
 696         stackSize--;
 697         if (stackSize > maxStackSize) maxStackSize = stackSize;
 698         /*
 699           ASSERT(stackSize >= 0);
 700           debugBelch("stackSize = %d\n", stackSize);
 701         */
 702 #endif
 703         return;
 704     }
 705
 706     // currentStack->free is updated when the active stack is switched back
 707     // to the previous stack.
 708     currentStack->free = (StgPtr)stackLimit;
 709
 710     // find the previous block descriptor
 711     pbd = currentStack->u.back;
 712     ASSERT(pbd != NULL);
 713
 714     returnToOldStack(pbd);
 715
 716 #ifdef DEBUG_RETAINER
 717     stackSize--;
 718     if (stackSize > maxStackSize) maxStackSize = stackSize;
 719     /*
 720       ASSERT(stackSize >= 0);
 721       debugBelch("stackSize = %d\n", stackSize);
 722     */
 723 #endif
 724 }
 725
 726 static INLINE void
 727 popOff(void) {
 728 #ifdef DEBUG_RETAINER
 729     // debugBelch("\tpopOff(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
 730 #endif
 731
 732     ASSERT(stackTop != stackLimit);
 733     ASSERT(!isEmptyRetainerStack());
 734
 735     // <= (instead of <) is wrong!
 736     if (stackTop + 1 < stackLimit) {
 737         stackTop++;
 738 #ifdef DEBUG_RETAINER
 739         stackSize--;
 740         if (stackSize > maxStackSize) maxStackSize = stackSize;
 741         /*
 742           ASSERT(stackSize >= 0);
 743           debugBelch("stackSize = %d\n", stackSize);
 744         */
 745 #endif
 746         return;
 747     }
 748
 749     popOffReal();
 750 }
 751
 752 /* -----------------------------------------------------------------------------
 753  *  Finds the next object to be considered for retainer profiling and store
 754  *  its pointer to *c.
 755  *  Test if the topmost stack element indicates that more objects are left,
 756  *  and if so, retrieve the first object and store its pointer to *c. Also,
 757  *  set *cp and *r appropriately, both of which are stored in the stack element.
 758  *  The topmost stack element then is overwritten so as for it to now denote
 759  *  the next object.
 760  *  If the topmost stack element indicates no more objects are left, pop
 761  *  off the stack element until either an object can be retrieved or
 762  *  the current stack chunk becomes empty, indicated by rtsTrue returned by
 763  *  isOnBoundary(), in which case *c is set to NULL.
 764  *  Note:
 765  *    It is okay to call this function even when the current stack chunk
 766  *    is empty.
 767  * -------------------------------------------------------------------------- */
 768 static INLINE void
 769 pop( StgClosure **c, StgClosure **cp, retainer *r )
 770 {
 771     stackElement *se;
 772
 773 #ifdef DEBUG_RETAINER
 774     // debugBelch("pop(): stackTop = 0x%x, currentStackBoundary = 0x%x\n", stackTop, currentStackBoundary);
 775 #endif
 776
 777     do {
 778         if (isOnBoundary()) {     // if the current stack chunk is depleted
 779             *c = NULL;
 780             return;
 781         }
 782
 783         se = stackTop;
 784
 785         switch (get_itbl(se->c)->type) {
 786             // two children (fixed), no SRT
 787             // nothing in se.info
 788         case CONSTR_2_0:
 789             *c = se->c->payload[1];
 790             *cp = se->c;
 791             *r = se->c_child_r;
 792             popOff();
 793             return;
 794
 795             // three children (fixed), no SRT
 796             // need to push a stackElement
 797         case MVAR:
 798             if (se->info.next.step == 2) {
 799                 *c = (StgClosure *)((StgMVar *)se->c)->tail;
 800                 se->info.next.step++;             // move to the next step
 801                 // no popOff
 802             } else {
 803                 *c = ((StgMVar *)se->c)->value;
 804                 popOff();
 805             }
 806             *cp = se->c;
 807             *r = se->c_child_r;
 808             return;
 809
 810             // three children (fixed), no SRT
 811         case WEAK:
 812             if (se->info.next.step == 2) {
 813                 *c = ((StgWeak *)se->c)->value;
 814                 se->info.next.step++;
 815                 // no popOff
 816             } else {
 817                 *c = ((StgWeak *)se->c)->finalizer;
 818                 popOff();
 819             }
 820             *cp = se->c;
 821             *r = se->c_child_r;
 822             return;
 823
 824         case CONSTR:
 825         case FOREIGN:
 826         case STABLE_NAME:
 827         case BCO:
 828         case CONSTR_STATIC:
 829             // StgMutArrPtr.ptrs, no SRT
 830         case MUT_ARR_PTRS:
 831         case MUT_ARR_PTRS_FROZEN:
 832             *c = find_ptrs(&se->info);
 833             if (*c == NULL) {
 834                 popOff();
 835                 break;
 836             }
 837             *cp = se->c;
 838             *r = se->c_child_r;
 839             return;
 840
 841             // layout.payload.ptrs, SRT
 842         case FUN:         // always a heap object
 843         case FUN_2_0:
 844             if (se->info.type == posTypePtrs) {
 845                 *c = find_ptrs(&se->info);
 846                 if (*c != NULL) {
 847                     *cp = se->c;
 848                     *r = se->c_child_r;
 849                     return;
 850                 }
 851                 init_srt_fun(&se->info, get_fun_itbl(se->c));
 852             }
 853             goto do_srt;
 854
 855         case THUNK:
 856         case THUNK_2_0:
 857             if (se->info.type == posTypePtrs) {
 858                 *c = find_ptrs(&se->info);
 859                 if (*c != NULL) {
 860                     *cp = se->c;
 861                     *r = se->c_child_r;
 862                     return;
 863                 }
 864                 init_srt_thunk(&se->info, get_thunk_itbl(se->c));
 865             }
 866             goto do_srt;
 867
 868             // SRT
 869         do_srt:
 870         case THUNK_STATIC:
 871         case FUN_STATIC:
 872         case FUN_0_1:
 873         case FUN_0_2:
 874         case THUNK_0_1:
 875         case THUNK_0_2:
 876         case FUN_1_0:
 877         case FUN_1_1:
 878         case THUNK_1_0:
 879         case THUNK_1_1:
 880             *c = find_srt(&se->info);
 881             if (*c != NULL) {
 882                 *cp = se->c;
 883                 *r = se->c_child_r;
 884                 return;
 885             }
 886             popOff();
 887             break;
 888
 889             // no child (fixed), no SRT
 890         case CONSTR_0_1:
 891         case CONSTR_0_2:
 892         case CAF_BLACKHOLE:
 893         case BLACKHOLE:
 894         case SE_BLACKHOLE:
 895         case SE_CAF_BLACKHOLE:
 896         case ARR_WORDS:
 897             // one child (fixed), no SRT
 898         case MUT_VAR:
 899         case MUT_CONS:
 900         case BLACKHOLE_BQ:
 901         case THUNK_SELECTOR:
 902         case IND_PERM:
 903         case IND_OLDGEN_PERM:
 904         case IND_OLDGEN:
 905         case CONSTR_1_1:
 906             // cannot appear
 907         case PAP:
 908         case AP:
 909         case AP_STACK:
 910         case TSO:
 911         case IND_STATIC:
 912         case CONSTR_INTLIKE:
 913         case CONSTR_CHARLIKE:
 914         case CONSTR_NOCAF_STATIC:
 915             // stack objects
 916         case RET_DYN:
 917         case UPDATE_FRAME:
 918         case CATCH_FRAME:
 919         case STOP_FRAME:
 920         case RET_BCO:
 921         case RET_SMALL:
 922         case RET_VEC_SMALL:
 923         case RET_BIG:
 924         case RET_VEC_BIG:
 925             // invalid objects
 926         case IND:
 927         case BLOCKED_FETCH:
 928         case FETCH_ME:
 929         case FETCH_ME_BQ:
 930         case RBH:
 931         case REMOTE_REF:
 932         case EVACUATED:
 933         case INVALID_OBJECT:
 934         default:
 935             barf("Invalid object *c in pop()");
 936             return;
 937         }
 938     } while (rtsTrue);
 939 }
 940
 941 /* -----------------------------------------------------------------------------
 942  * RETAINER PROFILING ENGINE
 943  * -------------------------------------------------------------------------- */
 944
 945 void
 946 initRetainerProfiling( void )
 947 {
 948     initializeAllRetainerSet();
 949     retainerGeneration = 0;
 950 }
 951
 952 /* -----------------------------------------------------------------------------
 953  *  This function must be called before f-closing prof_file.
 954  * -------------------------------------------------------------------------- */
 955 void
 956 endRetainerProfiling( void )
 957 {
 958 #ifdef SECOND_APPROACH
 959     outputAllRetainerSet(prof_file);
 960 #endif
 961 }
 962
 963 /* -----------------------------------------------------------------------------
 964  *  Returns the actual pointer to the retainer set of the closure *c.
 965  *  It may adjust RSET(c) subject to flip.
 966  *  Side effects:
 967  *    RSET(c) is initialized to NULL if its current value does not
 968  *    conform to flip.
 969  *  Note:
 970  *    Even though this function has side effects, they CAN be ignored because
 971  *    subsequent calls to retainerSetOf() always result in the same return value
 972  *    and retainerSetOf() is the only way to retrieve retainerSet of a given
 973  *    closure.
 974  *    We have to perform an XOR (^) operation each time a closure is examined.
 975  *    The reason is that we do not know when a closure is visited last.
 976  * -------------------------------------------------------------------------- */
 977 static INLINE void
 978 maybeInitRetainerSet( StgClosure *c )
 979 {
 980     if (!isRetainerSetFieldValid(c)) {
 981         setRetainerSetToNull(c);
 982     }
 983 }
 984
 985 /* -----------------------------------------------------------------------------
 986  * Returns rtsTrue if *c is a retainer.
 987  * -------------------------------------------------------------------------- */
 988 static INLINE rtsBool
 989 isRetainer( StgClosure *c )
 990 {
 991     switch (get_itbl(c)->type) {
 992         //
 993         //  True case
 994         //
 995         // TSOs MUST be retainers: they constitute the set of roots.
 996     case TSO:
 997
 998         // mutable objects
 999     case MVAR:
1000     case MUT_VAR:
1001     case MUT_CONS:
1002     case MUT_ARR_PTRS:
1003     case MUT_ARR_PTRS_FROZEN:
1004
1005         // thunks are retainers.
1006     case THUNK:
1007     case THUNK_1_0:
1008     case THUNK_0_1:
1009     case THUNK_2_0:
1010     case THUNK_1_1:
1011     case THUNK_0_2:
1012     case THUNK_SELECTOR:
1013     case AP:
1014     case AP_STACK:
1015
1016         // Static thunks, or CAFS, are obviously retainers.
1017     case THUNK_STATIC:
1018
1019         // WEAK objects are roots; there is separate code in which traversing
1020         // begins from WEAK objects.
1021     case WEAK:
1022         return rtsTrue;
1023
1024         //
1025         // False case
1026         //
1027
1028         // constructors
1029     case CONSTR:
1030     case CONSTR_1_0:
1031     case CONSTR_0_1:
1032     case CONSTR_2_0:
1033     case CONSTR_1_1:
1034     case CONSTR_0_2:
1035         // functions
1036     case FUN:
1037     case FUN_1_0:
1038     case FUN_0_1:
1039     case FUN_2_0:
1040     case FUN_1_1:
1041     case FUN_0_2:
1042         // partial applications
1043     case PAP:
1044         // blackholes
1045     case CAF_BLACKHOLE:
1046     case BLACKHOLE:
1047     case SE_BLACKHOLE:
1048     case SE_CAF_BLACKHOLE:
1049     case BLACKHOLE_BQ:
1050         // indirection
1051     case IND_PERM:
1052     case IND_OLDGEN_PERM:
1053     case IND_OLDGEN:
1054         // static objects
1055     case CONSTR_STATIC:
1056     case FUN_STATIC:
1057         // misc
1058     case FOREIGN:
1059     case STABLE_NAME:
1060     case BCO:
1061     case ARR_WORDS:
1062         return rtsFalse;
1063
1064         //
1065         // Error case
1066         //
1067         // IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
1068     case IND_STATIC:
1069         // CONSTR_INTLIKE, CONSTR_CHARLIKE, and CONSTR_NOCAF_STATIC
1070         // cannot be *c, *cp, *r in the retainer profiling loop.
1071     case CONSTR_INTLIKE:
1072     case CONSTR_CHARLIKE:
1073     case CONSTR_NOCAF_STATIC:
1074         // Stack objects are invalid because they are never treated as
1075         // legal objects during retainer profiling.
1076     case UPDATE_FRAME:
1077     case CATCH_FRAME:
1078     case STOP_FRAME:
1079     case RET_DYN:
1080     case RET_BCO:
1081     case RET_SMALL:
1082     case RET_VEC_SMALL:
1083     case RET_BIG:
1084     case RET_VEC_BIG:
1085         // other cases
1086     case IND:
1087     case BLOCKED_FETCH:
1088     case FETCH_ME:
1089     case FETCH_ME_BQ:
1090     case RBH:
1091     case REMOTE_REF:
1092     case EVACUATED:
1093     case INVALID_OBJECT:
1094     default:
1095         barf("Invalid object in isRetainer(): %d", get_itbl(c)->type);
1096         return rtsFalse;
1097     }
1098 }
1099
1100 /* -----------------------------------------------------------------------------
1101  *  Returns the retainer function value for the closure *c, i.e., R(*c).
1102  *  This function does NOT return the retainer(s) of *c.
1103  *  Invariants:
1104  *    *c must be a retainer.
1105  *  Note:
1106  *    Depending on the definition of this function, the maintenance of retainer
1107  *    sets can be made easier. If most retainer sets are likely to be created
1108  *    again across garbage collections, refreshAllRetainerSet() in
1109  *    RetainerSet.c can simply do nothing.
1110  *    If this is not the case, we can free all the retainer sets and
1111  *    re-initialize the hash table.
1112  *    See refreshAllRetainerSet() in RetainerSet.c.
1113  * -------------------------------------------------------------------------- */
1114 static INLINE retainer
1115 getRetainerFrom( StgClosure *c )
1116 {
1117     ASSERT(isRetainer(c));
1118
1119 #if defined(RETAINER_SCHEME_INFO)
1120     // Retainer scheme 1: retainer = info table
1121     return get_itbl(c);
1122 #elif defined(RETAINER_SCHEME_CCS)
1123     // Retainer scheme 2: retainer = cost centre stack
1124     return c->header.prof.ccs;
1125 #elif defined(RETAINER_SCHEME_CC)
1126     // Retainer scheme 3: retainer = cost centre
1127     return c->header.prof.ccs->cc;
1128 #endif
1129 }
1130
1131 /* -----------------------------------------------------------------------------
1132  *  Associates the retainer set *s with the closure *c, that is, *s becomes
1133  *  the retainer set of *c.
1134  *  Invariants:
1135  *    c != NULL
1136  *    s != NULL
1137  * -------------------------------------------------------------------------- */
1138 static INLINE void
1139 associate( StgClosure *c, RetainerSet *s )
1140 {
1141     // StgWord has the same size as pointers, so the following type
1142     // casting is okay.
1143     RSET(c) = (RetainerSet *)((StgWord)s | flip);
1144 }
1145
1146 /* -----------------------------------------------------------------------------
1147    Call retainClosure for each of the closures covered by a large bitmap.
1148    -------------------------------------------------------------------------- */
1149
1150 static void
1151 retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
1152                      StgClosure *c, retainer c_child_r)
1153 {
1154     nat i, b;
1155     StgWord bitmap;
1156
1157     b = 0;
1158     bitmap = large_bitmap->bitmap[b];
1159     for (i = 0; i < size; ) {
1160         if ((bitmap & 1) == 0) {
1161             retainClosure((StgClosure *)*p, c, c_child_r);
1162         }
1163         i++;
1164         p++;
1165         if (i % BITS_IN(W_) == 0) {
1166             b++;
1167             bitmap = large_bitmap->bitmap[b];
1168         } else {
1169             bitmap = bitmap >> 1;
1170         }
1171     }
1172 }
1173
1174 static INLINE StgPtr
1175 retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
1176                      StgClosure *c, retainer c_child_r)
1177 {
1178     while (size > 0) {
1179         if ((bitmap & 1) == 0) {
1180             retainClosure((StgClosure *)*p, c, c_child_r);
1181         }
1182         p++;
1183         bitmap = bitmap >> 1;
1184         size--;
1185     }
1186     return p;
1187 }
1188
1189 /* -----------------------------------------------------------------------------
1190  * Call retainClosure for each of the closures in an SRT.
1191  * ------------------------------------------------------------------------- */
1192
1193 static void
1194 retain_large_srt_bitmap (StgLargeSRT *srt, StgClosure *c, retainer c_child_r)
1195 {
1196     nat i, b, size;
1197     StgWord bitmap;
1198     StgClosure **p;
1199
1200     b = 0;
1201     p = (StgClosure **)srt->srt;
1202     size   = srt->l.size;
1203     bitmap = srt->l.bitmap[b];
1204     for (i = 0; i < size; ) {
1205         if ((bitmap & 1) != 0) {
1206             retainClosure((StgClosure *)*p, c, c_child_r);
1207         }
1208         i++;
1209         p++;
1210         if (i % BITS_IN(W_) == 0) {
1211             b++;
1212             bitmap = srt->l.bitmap[b];
1213         } else {
1214             bitmap = bitmap >> 1;
1215         }
1216     }
1217 }
1218
1219 static INLINE void
1220 retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
1221 {
1222   nat bitmap;
1223   StgClosure **p;
1224
1225   bitmap = srt_bitmap;
1226   p = srt;
1227
1228   if (bitmap == (StgHalfWord)(-1)) {
1229       retain_large_srt_bitmap( (StgLargeSRT *)srt, c, c_child_r );
1230       return;
1231   }
1232
1233   while (bitmap != 0) {
1234       if ((bitmap & 1) != 0) {
1235 #ifdef ENABLE_WIN32_DLL_SUPPORT
1236           if ( (unsigned long)(*srt) & 0x1 ) {
1237               retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
1238                             c, c_child_r);
1239           } else {
1240               retainClosure(*srt,c,c_child_r);
1241           }
1242 #else
1243           retainClosure(*srt,c,c_child_r);
1244 #endif
1245       }
1246       p++;
1247       bitmap = bitmap >> 1;
1248   }
1249 }
1250
1251 /* -----------------------------------------------------------------------------
1252  *  Process all the objects in the stack chunk from stackStart to stackEnd
1253  *  with *c and *c_child_r being their parent and their most recent retainer,
1254  *  respectively. Treat stackOptionalFun as another child of *c if it is
1255  *  not NULL.
1256  *  Invariants:
1257  *    *c is one of the following: TSO, AP_STACK.
1258  *    If *c is TSO, c == c_child_r.
1259  *    stackStart < stackEnd.
1260  *    RSET(c) and RSET(c_child_r) are valid, i.e., their
1261  *    interpretation conforms to the current value of flip (even when they
1262  *    are interpreted to be NULL).
1263  *    If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
1264  *    or ThreadKilled, which means that its stack is ready to process.
1265  *  Note:
1266  *    This code was almost plagiarzied from GC.c! For each pointer,
1267  *    retainClosure() is invoked instead of evacuate().
1268  * -------------------------------------------------------------------------- */
1269 static void
1270 retainStack( StgClosure *c, retainer c_child_r,
1271              StgPtr stackStart, StgPtr stackEnd )
1272 {
1273     stackElement *oldStackBoundary;
1274     StgPtr p;
1275     StgRetInfoTable *info;
1276     StgWord32 bitmap;
1277     nat size;
1278
1279 #ifdef DEBUG_RETAINER
1280     cStackSize++;
1281     if (cStackSize > maxCStackSize) maxCStackSize = cStackSize;
1282 #endif
1283
1284     /*
1285       Each invocation of retainStack() creates a new virtual
1286       stack. Since all such stacks share a single common stack, we
1287       record the current currentStackBoundary, which will be restored
1288       at the exit.
1289     */
1290     oldStackBoundary = currentStackBoundary;
1291     currentStackBoundary = stackTop;
1292
1293 #ifdef DEBUG_RETAINER
1294     // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
1295 #endif
1296
1297     ASSERT(get_itbl(c)->type != TSO ||
1298            (((StgTSO *)c)->what_next != ThreadRelocated &&
1299             ((StgTSO *)c)->what_next != ThreadComplete &&
1300             ((StgTSO *)c)->what_next != ThreadKilled));
1301
1302     p = stackStart;
1303     while (p < stackEnd) {
1304         info = get_ret_itbl((StgClosure *)p);
1305
1306         switch(info->i.type) {
1307
1308         case UPDATE_FRAME:
1309             retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
1310             p += sizeofW(StgUpdateFrame);
1311             continue;
1312
1313         case STOP_FRAME:
1314         case CATCH_FRAME:
1315         case RET_SMALL:
1316         case RET_VEC_SMALL:
1317             bitmap = BITMAP_BITS(info->i.layout.bitmap);
1318             size   = BITMAP_SIZE(info->i.layout.bitmap);
1319             p++;
1320             p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1321
1322         follow_srt:
1323             retainSRT((StgClosure **)info->srt, info->i.srt_bitmap, c, c_child_r);
1324             continue;
1325
1326         case RET_BCO: {
1327             StgBCO *bco;
1328
1329             p++;
1330             retainClosure((StgClosure *)*p, c, c_child_r);
1331             bco = (StgBCO *)*p;
1332             p++;
1333             size = BCO_BITMAP_SIZE(bco);
1334             retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
1335             p += size;
1336             continue;
1337         }
1338
1339             // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
1340         case RET_BIG:
1341         case RET_VEC_BIG:
1342             size = info->i.layout.large_bitmap->size;
1343             p++;
1344             retain_large_bitmap(p, info->i.layout.large_bitmap,
1345                                 size, c, c_child_r);
1346             p += size;
1347             // and don't forget to follow the SRT
1348             goto follow_srt;
1349
1350             // Dynamic bitmap: the mask is stored on the stack
1351         case RET_DYN: {
1352             StgWord dyn;
1353             dyn = ((StgRetDyn *)p)->liveness;
1354
1355             // traverse the bitmap first
1356             bitmap = RET_DYN_LIVENESS(dyn);
1357             p      = (P_)&((StgRetDyn *)p)->payload[0];
1358             size   = RET_DYN_BITMAP_SIZE;
1359             p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1360
1361             // skip over the non-ptr words
1362             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
1363
1364             // follow the ptr words
1365             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
1366                 retainClosure((StgClosure *)*p, c, c_child_r);
1367                 p++;
1368             }
1369             continue;
1370         }
1371
1372         case RET_FUN: {
1373             StgRetFun *ret_fun = (StgRetFun *)p;
1374             StgFunInfoTable *fun_info;
1375
1376             retainClosure(ret_fun->fun, c, c_child_r);
1377             fun_info = get_fun_itbl(ret_fun->fun);
1378
1379             p = (P_)&ret_fun->payload;
1380             switch (fun_info->f.fun_type) {
1381             case ARG_GEN:
1382                 bitmap = BITMAP_BITS(fun_info->f.bitmap);
1383                 size = BITMAP_SIZE(fun_info->f.bitmap);
1384                 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1385                 break;
1386             case ARG_GEN_BIG:
1387                 size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
1388                 retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
1389                                     size, c, c_child_r);
1390                 p += size;
1391                 break;
1392             default:
1393                 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1394                 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
1395                 p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
1396                 break;
1397             }
1398             goto follow_srt;
1399         }
1400
1401         default:
1402             barf("Invalid object found in retainStack(): %d",
1403                  (int)(info->i.type));
1404         }
1405     }
1406
1407     // restore currentStackBoundary
1408     currentStackBoundary = oldStackBoundary;
1409 #ifdef DEBUG_RETAINER
1410     // debugBelch("retainStack() finished: currentStackBoundary = 0x%x\n", currentStackBoundary);
1411 #endif
1412
1413 #ifdef DEBUG_RETAINER
1414     cStackSize--;
1415 #endif
1416 }
1417
1418 /* ----------------------------------------------------------------------------
1419  * Call retainClosure for each of the children of a PAP/AP
1420  * ------------------------------------------------------------------------- */
1421
1422 static INLINE StgPtr
1423 retain_PAP (StgPAP *pap, retainer c_child_r)
1424 {
1425     StgPtr p;
1426     StgWord bitmap, size;
1427     StgFunInfoTable *fun_info;
1428
1429     retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
1430     fun_info = get_fun_itbl(pap->fun);
1431     ASSERT(fun_info->i.type != PAP);
1432
1433     p = (StgPtr)pap->payload;
1434     size = pap->n_args;
1435
1436     switch (fun_info->f.fun_type) {
1437     case ARG_GEN:
1438         bitmap = BITMAP_BITS(fun_info->f.bitmap);
1439         p = retain_small_bitmap(p, pap->n_args, bitmap,
1440                                 (StgClosure *)pap, c_child_r);
1441         break;
1442     case ARG_GEN_BIG:
1443         retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
1444                             size, (StgClosure *)pap, c_child_r);
1445         p += size;
1446         break;
1447     case ARG_BCO:
1448         retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
1449                             size, (StgClosure *)pap, c_child_r);
1450         p += size;
1451         break;
1452     default:
1453         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
1454         p = retain_small_bitmap(p, pap->n_args, bitmap,
1455                                 (StgClosure *)pap, c_child_r);
1456         break;
1457     }
1458     return p;
1459 }
1460
1461 /* -----------------------------------------------------------------------------
1462  *  Compute the retainer set of *c0 and all its desecents by traversing.
1463  *  *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
1464  *  Invariants:
1465  *    c0 = cp0 = r0 holds only for root objects.
1466  *    RSET(cp0) and RSET(r0) are valid, i.e., their
1467  *    interpretation conforms to the current value of flip (even when they
1468  *    are interpreted to be NULL).
1469  *    However, RSET(c0) may be corrupt, i.e., it may not conform to
1470  *    the current value of flip. If it does not, during the execution
1471  *    of this function, RSET(c0) must be initialized as well as all
1472  *    its descendants.
1473  *  Note:
1474  *    stackTop must be the same at the beginning and the exit of this function.
1475  *    *c0 can be TSO (as well as AP_STACK).
1476  * -------------------------------------------------------------------------- */
1477 static void
1478 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
1479 {
1480     // c = Current closure
1481     // cp = Current closure's Parent
1482     // r = current closures' most recent Retainer
1483     // c_child_r = current closure's children's most recent retainer
1484     // first_child = first child of c
1485     StgClosure *c, *cp, *first_child;
1486     RetainerSet *s, *retainerSetOfc;
1487     retainer r, c_child_r;
1488     StgWord typeOfc;
1489
1490 #ifdef DEBUG_RETAINER
1491     // StgPtr oldStackTop;
1492 #endif
1493
1494 #ifdef DEBUG_RETAINER
1495     // oldStackTop = stackTop;
1496     // debugBelch("retainClosure() called: c0 = 0x%x, cp0 = 0x%x, r0 = 0x%x\n", c0, cp0, r0);
1497 #endif
1498
1499     // (c, cp, r) = (c0, cp0, r0)
1500     c = c0;
1501     cp = cp0;
1502     r = r0;
1503     goto inner_loop;
1504
1505 loop:
1506     //debugBelch("loop");
1507     // pop to (c, cp, r);
1508     pop(&c, &cp, &r);
1509
1510     if (c == NULL) {
1511 #ifdef DEBUG_RETAINER
1512         // debugBelch("retainClosure() ends: oldStackTop = 0x%x, stackTop = 0x%x\n", oldStackTop, stackTop);
1513 #endif
1514         return;
1515     }
1516
1517     //debugBelch("inner_loop");
1518
1519 inner_loop:
1520     // c  = current closure under consideration,
1521     // cp = current closure's parent,
1522     // r  = current closure's most recent retainer
1523     //
1524     // Loop invariants (on the meaning of c, cp, r, and their retainer sets):
1525     //   RSET(cp) and RSET(r) are valid.
1526     //   RSET(c) is valid only if c has been visited before.
1527     //
1528     // Loop invariants (on the relation between c, cp, and r)
1529     //   if cp is not a retainer, r belongs to RSET(cp).
1530     //   if cp is a retainer, r == cp.
1531
1532     typeOfc = get_itbl(c)->type;
1533
1534 #ifdef DEBUG_RETAINER
1535     switch (typeOfc) {
1536     case IND_STATIC:
1537     case CONSTR_INTLIKE:
1538     case CONSTR_CHARLIKE:
1539     case CONSTR_NOCAF_STATIC:
1540     case CONSTR_STATIC:
1541     case THUNK_STATIC:
1542     case FUN_STATIC:
1543         break;
1544     default:
1545         if (retainerSetOf(c) == NULL) {   // first visit?
1546             costArray[typeOfc] += cost(c);
1547             sumOfNewCost += cost(c);
1548         }
1549         break;
1550     }
1551 #endif
1552
1553     // special cases
1554     switch (typeOfc) {
1555     case TSO:
1556         if (((StgTSO *)c)->what_next == ThreadComplete ||
1557             ((StgTSO *)c)->what_next == ThreadKilled) {
1558 #ifdef DEBUG_RETAINER
1559             debugBelch("ThreadComplete or ThreadKilled encountered in retainClosure()\n");
1560 #endif
1561             goto loop;
1562         }
1563         if (((StgTSO *)c)->what_next == ThreadRelocated) {
1564 #ifdef DEBUG_RETAINER
1565             debugBelch("ThreadRelocated encountered in retainClosure()\n");
1566 #endif
1567             c = (StgClosure *)((StgTSO *)c)->link;
1568             goto inner_loop;
1569         }
1570         break;
1571
1572     case IND_STATIC:
1573         // We just skip IND_STATIC, so its retainer set is never computed.
1574         c = ((StgIndStatic *)c)->indirectee;
1575         goto inner_loop;
1576     case CONSTR_INTLIKE:
1577     case CONSTR_CHARLIKE:
1578         // static objects with no pointers out, so goto loop.
1579     case CONSTR_NOCAF_STATIC:
1580         // It is not just enough not to compute the retainer set for *c; it is
1581         // mandatory because CONSTR_NOCAF_STATIC are not reachable from
1582         // scavenged_static_objects, the list from which is assumed to traverse
1583         // all static objects after major garbage collections.
1584         goto loop;
1585     case THUNK_STATIC:
1586     case FUN_STATIC:
1587         if (get_itbl(c)->srt_bitmap == 0) {
1588             // No need to compute the retainer set; no dynamic objects
1589             // are reachable from *c.
1590             //
1591             // Static objects: if we traverse all the live closures,
1592             // including static closures, during each heap census then
1593             // we will observe that some static closures appear and
1594             // disappear.  eg. a closure may contain a pointer to a
1595             // static function 'f' which is not otherwise reachable
1596             // (it doesn't indirectly point to any CAFs, so it doesn't
1597             // appear in any SRTs), so we would find 'f' during
1598             // traversal.  However on the next sweep there may be no
1599             // closures pointing to 'f'.
1600             //
1601             // We must therefore ignore static closures whose SRT is
1602             // empty, because these are exactly the closures that may
1603             // "appear".  A closure with a non-empty SRT, and which is
1604             // still required, will always be reachable.
1605             //
1606             // But what about CONSTR_STATIC?  Surely these may be able
1607             // to appear, and they don't have SRTs, so we can't
1608             // check.  So for now, we're calling
1609             // resetStaticObjectForRetainerProfiling() from the
1610             // garbage collector to reset the retainer sets in all the
1611             // reachable static objects.
1612             goto loop;
1613         }
1614     default:
1615         break;
1616     }
1617
1618     // The above objects are ignored in computing the average number of times
1619     // an object is visited.
1620     timesAnyObjectVisited++;
1621
1622     // If this is the first visit to c, initialize its retainer set.
1623     maybeInitRetainerSet(c);
1624     retainerSetOfc = retainerSetOf(c);
1625
1626     // Now compute s:
1627     //    isRetainer(cp) == rtsTrue => s == NULL
1628     //    isRetainer(cp) == rtsFalse => s == cp.retainer
1629     if (isRetainer(cp))
1630         s = NULL;
1631     else
1632         s = retainerSetOf(cp);
1633
1634     // (c, cp, r, s) is available.
1635
1636     // (c, cp, r, s, R_r) is available, so compute the retainer set for *c.
1637     if (retainerSetOfc == NULL) {
1638         // This is the first visit to *c.
1639         numObjectVisited++;
1640
1641         if (s == NULL)
1642             associate(c, singleton(r));
1643         else
1644             // s is actually the retainer set of *c!
1645             associate(c, s);
1646
1647         // compute c_child_r
1648         c_child_r = isRetainer(c) ? getRetainerFrom(c) : r;
1649     } else {
1650         // This is not the first visit to *c.
1651         if (isMember(r, retainerSetOfc))
1652             goto loop;          // no need to process child
1653
1654         if (s == NULL)
1655             associate(c, addElement(r, retainerSetOfc));
1656         else {
1657             // s is not NULL and cp is not a retainer. This means that
1658             // each time *cp is visited, so is *c. Thus, if s has
1659             // exactly one more element in its retainer set than c, s
1660             // is also the new retainer set for *c.
1661             if (s->num == retainerSetOfc->num + 1) {
1662                 associate(c, s);
1663             }
1664             // Otherwise, just add R_r to the current retainer set of *c.
1665             else {
1666                 associate(c, addElement(r, retainerSetOfc));
1667             }
1668         }
1669
1670         if (isRetainer(c))
1671             goto loop;          // no need to process child
1672
1673         // compute c_child_r
1674         c_child_r = r;
1675     }
1676
1677     // now, RSET() of all of *c, *cp, and *r is valid.
1678     // (c, c_child_r) are available.
1679
1680     // process child
1681
1682     // Special case closures: we process these all in one go rather
1683     // than attempting to save the current position, because doing so
1684     // would be hard.
1685     switch (typeOfc) {
1686     case TSO:
1687         retainStack(c, c_child_r,
1688                     ((StgTSO *)c)->sp,
1689                     ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
1690         goto loop;
1691
1692     case PAP:
1693     case AP:
1694         retain_PAP((StgPAP *)c, c_child_r);
1695         goto loop;
1696
1697     case AP_STACK:
1698         retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
1699         retainStack(c, c_child_r,
1700                     (StgPtr)((StgAP_STACK *)c)->payload,
1701                     (StgPtr)((StgAP_STACK *)c)->payload +
1702                              ((StgAP_STACK *)c)->size);
1703         goto loop;
1704     }
1705
1706     push(c, c_child_r, &first_child);
1707
1708     // If first_child is null, c has no child.
1709     // If first_child is not null, the top stack element points to the next
1710     // object. push() may or may not push a stackElement on the stack.
1711     if (first_child == NULL)
1712         goto loop;
1713
1714     // (c, cp, r) = (first_child, c, c_child_r)
1715     r = c_child_r;
1716     cp = c;
1717     c = first_child;
1718     goto inner_loop;
1719 }
1720
1721 /* -----------------------------------------------------------------------------
1722  *  Compute the retainer set for every object reachable from *tl.
1723  * -------------------------------------------------------------------------- */
1724 static void
1725 retainRoot( StgClosure **tl )
1726 {
1727     // We no longer assume that only TSOs and WEAKs are roots; any closure can
1728     // be a root.
1729
1730     ASSERT(isEmptyRetainerStack());
1731     currentStackBoundary = stackTop;
1732
1733     if (isRetainer(*tl)) {
1734         retainClosure(*tl, *tl, getRetainerFrom(*tl));
1735     } else {
1736         retainClosure(*tl, *tl, CCS_SYSTEM);
1737     }
1738
1739     // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
1740     // *tl might be a TSO which is ThreadComplete, in which
1741     // case we ignore it for the purposes of retainer profiling.
1742 }
1743
1744 /* -----------------------------------------------------------------------------
1745  *  Compute the retainer set for each of the objects in the heap.
1746  * -------------------------------------------------------------------------- */
1747 static void
1748 computeRetainerSet( void )
1749 {
1750     StgWeak *weak;
1751     RetainerSet *rtl;
1752     nat g;
1753     StgMutClosure *ml;
1754 #ifdef DEBUG_RETAINER
1755     RetainerSet tmpRetainerSet;
1756 #endif
1757
1758     GetRoots(retainRoot);       // for scheduler roots
1759
1760     // This function is called after a major GC, when key, value, and finalizer
1761     // all are guaranteed to be valid, or reachable.
1762     //
1763     // The following code assumes that WEAK objects are considered to be roots
1764     // for retainer profilng.
1765     for (weak = weak_ptr_list; weak != NULL; weak = weak->link)
1766         // retainRoot((StgClosure *)weak);
1767         retainRoot((StgClosure **)&weak);
1768
1769     // Consider roots from the stable ptr table.
1770     markStablePtrTable(retainRoot);
1771
1772     // The following code resets the rs field of each unvisited mutable
1773     // object (computing sumOfNewCostExtra and updating costArray[] when
1774     // debugging retainer profiler).
1775     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1776         ASSERT(g != 0 ||
1777                (generations[g].mut_list == END_MUT_LIST &&
1778                 generations[g].mut_once_list == END_MUT_LIST));
1779
1780         // Todo:
1781         // I think traversing through mut_list is unnecessary.
1782         // Think about removing this part.
1783         for (ml = generations[g].mut_list; ml != END_MUT_LIST;
1784              ml = ml->mut_link) {
1785
1786             maybeInitRetainerSet((StgClosure *)ml);
1787             rtl = retainerSetOf((StgClosure *)ml);
1788
1789 #ifdef DEBUG_RETAINER
1790             if (rtl == NULL) {
1791                 // first visit to *ml
1792                 // This is a violation of the interface rule!
1793                 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1794
1795                 switch (get_itbl((StgClosure *)ml)->type) {
1796                 case IND_STATIC:
1797                     // no cost involved
1798                     break;
1799                 case CONSTR_INTLIKE:
1800                 case CONSTR_CHARLIKE:
1801                 case CONSTR_NOCAF_STATIC:
1802                 case CONSTR_STATIC:
1803                 case THUNK_STATIC:
1804                 case FUN_STATIC:
1805                     barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1806                     break;
1807                 default:
1808                     // dynamic objects
1809                     costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1810                     sumOfNewCostExtra += cost((StgClosure *)ml);
1811                     break;
1812                 }
1813             }
1814 #endif
1815         }
1816
1817         // Traversing through mut_once_list is, in contrast, necessary
1818         // because we can find MUT_VAR objects which have not been
1819         // visited during retainer profiling.
1820         for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
1821              ml = ml->mut_link) {
1822
1823             maybeInitRetainerSet((StgClosure *)ml);
1824             rtl = retainerSetOf((StgClosure *)ml);
1825 #ifdef DEBUG_RETAINER
1826             if (rtl == NULL) {
1827                 // first visit to *ml
1828                 // This is a violation of the interface rule!
1829                 RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
1830
1831                 switch (get_itbl((StgClosure *)ml)->type) {
1832                 case IND_STATIC:
1833                     // no cost involved
1834                     break;
1835                 case CONSTR_INTLIKE:
1836                 case CONSTR_CHARLIKE:
1837                 case CONSTR_NOCAF_STATIC:
1838                 case CONSTR_STATIC:
1839                 case THUNK_STATIC:
1840                 case FUN_STATIC:
1841                     barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
1842                     break;
1843                 default:
1844                     // dynamic objects
1845                     costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
1846                     sumOfNewCostExtra += cost((StgClosure *)ml);
1847                     break;
1848                 }
1849             }
1850 #endif
1851         }
1852     }
1853 }
1854
1855 /* -----------------------------------------------------------------------------
1856  *  Traverse all static objects for which we compute retainer sets,
1857  *  and reset their rs fields to NULL, which is accomplished by
1858  *  invoking maybeInitRetainerSet(). This function must be called
1859  *  before zeroing all objects reachable from scavenged_static_objects
1860  *  in the case of major gabage collections. See GarbageCollect() in
1861  *  GC.c.
1862  *  Note:
1863  *    The mut_once_list of the oldest generation must also be traversed?
1864  *    Why? Because if the evacuation of an object pointed to by a static
1865  *    indirection object fails, it is put back to the mut_once_list of
1866  *    the oldest generation.
1867  *    However, this is not necessary because any static indirection objects
1868  *    are just traversed through to reach dynamic objects. In other words,
1869  *    they are not taken into consideration in computing retainer sets.
1870  * -------------------------------------------------------------------------- */
1871 void
1872 resetStaticObjectForRetainerProfiling( void )
1873 {
1874 #ifdef DEBUG_RETAINER
1875     nat count;
1876 #endif
1877     StgClosure *p;
1878
1879 #ifdef DEBUG_RETAINER
1880     count = 0;
1881 #endif
1882     p = scavenged_static_objects;
1883     while (p != END_OF_STATIC_LIST) {
1884 #ifdef DEBUG_RETAINER
1885         count++;
1886 #endif
1887         switch (get_itbl(p)->type) {
1888         case IND_STATIC:
1889             // Since we do not compute the retainer set of any
1890             // IND_STATIC object, we don't have to reset its retainer
1891             // field.
1892             p = IND_STATIC_LINK(p);
1893             break;
1894         case THUNK_STATIC:
1895             maybeInitRetainerSet(p);
1896             p = THUNK_STATIC_LINK(p);
1897             break;
1898         case FUN_STATIC:
1899             maybeInitRetainerSet(p);
1900             p = FUN_STATIC_LINK(p);
1901             break;
1902         case CONSTR_STATIC:
1903             maybeInitRetainerSet(p);
1904             p = STATIC_LINK(get_itbl(p), p);
1905             break;
1906         default:
1907             barf("resetStaticObjectForRetainerProfiling: %p (%s)",
1908                  p, get_itbl(p)->type);
1909             break;
1910         }
1911     }
1912 #ifdef DEBUG_RETAINER
1913     // debugBelch("count in scavenged_static_objects = %d\n", count);
1914 #endif
1915 }
1916
1917 /* -----------------------------------------------------------------------------
1918  * Perform retainer profiling.
1919  * N is the oldest generation being profilied, where the generations are
1920  * numbered starting at 0.
1921  * Invariants:
1922  * Note:
1923  *   This function should be called only immediately after major garbage
1924  *   collection.
1925  * ------------------------------------------------------------------------- */
1926 void
1927 retainerProfile(void)
1928 {
1929 #ifdef DEBUG_RETAINER
1930   nat i;
1931   nat totalHeapSize;        // total raw heap size (computed by linear scanning)
1932 #endif
1933
1934 #ifdef DEBUG_RETAINER
1935   debugBelch(" < retainerProfile() invoked : %d>\n", retainerGeneration);
1936 #endif
1937
1938   stat_startRP();
1939
1940   // We haven't flipped the bit yet.
1941 #ifdef DEBUG_RETAINER
1942   debugBelch("Before traversing:\n");
1943   sumOfCostLinear = 0;
1944   for (i = 0;i < N_CLOSURE_TYPES; i++)
1945     costArrayLinear[i] = 0;
1946   totalHeapSize = checkHeapSanityForRetainerProfiling();
1947
1948   debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
1949   /*
1950   debugBelch("costArrayLinear[] = ");
1951   for (i = 0;i < N_CLOSURE_TYPES; i++)
1952     debugBelch("[%u:%u] ", i, costArrayLinear[i]);
1953   debugBelch("\n");
1954   */
1955
1956   ASSERT(sumOfCostLinear == totalHeapSize);
1957
1958 /*
1959 #define pcostArrayLinear(index) \
1960   if (costArrayLinear[index] > 0) \
1961     debugBelch("costArrayLinear[" #index "] = %u\n", costArrayLinear[index])
1962   pcostArrayLinear(THUNK_STATIC);
1963   pcostArrayLinear(FUN_STATIC);
1964   pcostArrayLinear(CONSTR_STATIC);
1965   pcostArrayLinear(CONSTR_NOCAF_STATIC);
1966   pcostArrayLinear(CONSTR_INTLIKE);
1967   pcostArrayLinear(CONSTR_CHARLIKE);
1968 */
1969 #endif
1970
1971   // Now we flips flip.
1972   flip = flip ^ 1;
1973
1974 #ifdef DEBUG_RETAINER
1975   stackSize = 0;
1976   maxStackSize = 0;
1977   cStackSize = 0;
1978   maxCStackSize = 0;
1979 #endif
1980   numObjectVisited = 0;
1981   timesAnyObjectVisited = 0;
1982
1983 #ifdef DEBUG_RETAINER
1984   debugBelch("During traversing:\n");
1985   sumOfNewCost = 0;
1986   sumOfNewCostExtra = 0;
1987   for (i = 0;i < N_CLOSURE_TYPES; i++)
1988     costArray[i] = 0;
1989 #endif
1990
1991   /*
1992     We initialize the traverse stack each time the retainer profiling is
1993     performed (because the traverse stack size varies on each retainer profiling
1994     and this operation is not costly anyhow). However, we just refresh the
1995     retainer sets.
1996    */
1997   initializeTraverseStack();
1998 #ifdef DEBUG_RETAINER
1999   initializeAllRetainerSet();
2000 #else
2001   refreshAllRetainerSet();
2002 #endif
2003   computeRetainerSet();
2004
2005 #ifdef DEBUG_RETAINER
2006   debugBelch("After traversing:\n");
2007   sumOfCostLinear = 0;
2008   for (i = 0;i < N_CLOSURE_TYPES; i++)
2009     costArrayLinear[i] = 0;
2010   totalHeapSize = checkHeapSanityForRetainerProfiling();
2011
2012   debugBelch("\tsumOfCostLinear = %d, totalHeapSize = %d\n", sumOfCostLinear, totalHeapSize);
2013   ASSERT(sumOfCostLinear == totalHeapSize);
2014
2015   // now, compare the two results
2016   /*
2017     Note:
2018       costArray[] must be exactly the same as costArrayLinear[].
2019       Known exceptions:
2020         1) Dead weak pointers, whose type is CONSTR. These objects are not
2021            reachable from any roots.
2022   */
2023   debugBelch("Comparison:\n");
2024   debugBelch("\tcostArrayLinear[] (must be empty) = ");
2025   for (i = 0;i < N_CLOSURE_TYPES; i++)
2026     if (costArray[i] != costArrayLinear[i])
2027       // nothing should be printed except MUT_VAR after major GCs
2028       debugBelch("[%u:%u] ", i, costArrayLinear[i]);
2029   debugBelch("\n");
2030
2031   debugBelch("\tsumOfNewCost = %u\n", sumOfNewCost);
2032   debugBelch("\tsumOfNewCostExtra = %u\n", sumOfNewCostExtra);
2033   debugBelch("\tcostArray[] (must be empty) = ");
2034   for (i = 0;i < N_CLOSURE_TYPES; i++)
2035     if (costArray[i] != costArrayLinear[i])
2036       // nothing should be printed except MUT_VAR after major GCs
2037       debugBelch("[%u:%u] ", i, costArray[i]);
2038   debugBelch("\n");
2039
2040   // only for major garbage collection
2041   ASSERT(sumOfNewCost + sumOfNewCostExtra == sumOfCostLinear);
2042 #endif
2043
2044   // post-processing
2045   closeTraverseStack();
2046 #ifdef DEBUG_RETAINER
2047   closeAllRetainerSet();
2048 #else
2049   // Note that there is no post-processing for the retainer sets.
2050 #endif
2051   retainerGeneration++;
2052
2053   stat_endRP(
2054     retainerGeneration - 1,   // retainerGeneration has just been incremented!
2055 #ifdef DEBUG_RETAINER
2056     maxCStackSize, maxStackSize,
2057 #endif
2058     (double)timesAnyObjectVisited / numObjectVisited);
2059 }
2060
2061 /* -----------------------------------------------------------------------------
2062  * DEBUGGING CODE
2063  * -------------------------------------------------------------------------- */
2064
2065 #ifdef DEBUG_RETAINER
2066
2067 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
2068         ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
2069         ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
2070
2071 static nat
2072 sanityCheckHeapClosure( StgClosure *c )
2073 {
2074     StgInfoTable *info;
2075
2076     ASSERT(LOOKS_LIKE_GHC_INFO(c->header.info));
2077     ASSERT(!closure_STATIC(c));
2078     ASSERT(LOOKS_LIKE_PTR(c));
2079
2080     if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
2081         if (get_itbl(c)->type == CONSTR &&
2082             !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
2083             !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
2084             debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
2085             costArray[get_itbl(c)->type] += cost(c);
2086             sumOfNewCost += cost(c);
2087         } else
2088             debugBelch(
2089                     "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
2090                     flip, c, get_itbl(c)->type,
2091                     get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
2092                     RSET(c));
2093     } else {
2094         // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
2095     }
2096
2097     info = get_itbl(c);
2098     switch (info->type) {
2099     case TSO:
2100         return tso_sizeW((StgTSO *)c);
2101
2102     case THUNK:
2103     case THUNK_1_0:
2104     case THUNK_0_1:
2105     case THUNK_2_0:
2106     case THUNK_1_1:
2107     case THUNK_0_2:
2108         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
2109
2110     case MVAR:
2111         return sizeofW(StgMVar);
2112
2113     case MUT_ARR_PTRS:
2114     case MUT_ARR_PTRS_FROZEN:
2115         return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
2116
2117     case AP:
2118     case PAP:
2119         return pap_sizeW((StgPAP *)c);
2120
2121     case AP:
2122         return ap_stack_sizeW((StgAP_STACK *)c);
2123
2124     case ARR_WORDS:
2125         return arr_words_sizeW((StgArrWords *)c);
2126
2127     case CONSTR:
2128     case CONSTR_1_0:
2129     case CONSTR_0_1:
2130     case CONSTR_2_0:
2131     case CONSTR_1_1:
2132     case CONSTR_0_2:
2133     case FUN:
2134     case FUN_1_0:
2135     case FUN_0_1:
2136     case FUN_2_0:
2137     case FUN_1_1:
2138     case FUN_0_2:
2139     case WEAK:
2140     case MUT_VAR:
2141     case MUT_CONS:
2142     case CAF_BLACKHOLE:
2143     case BLACKHOLE:
2144     case SE_BLACKHOLE:
2145     case SE_CAF_BLACKHOLE:
2146     case BLACKHOLE_BQ:
2147     case IND_PERM:
2148     case IND_OLDGEN:
2149     case IND_OLDGEN_PERM:
2150     case FOREIGN:
2151     case BCO:
2152     case STABLE_NAME:
2153         return sizeW_fromITBL(info);
2154
2155     case THUNK_SELECTOR:
2156         return sizeofW(StgHeader) + MIN_UPD_SIZE;
2157
2158         /*
2159           Error case
2160         */
2161     case IND_STATIC:
2162     case CONSTR_STATIC:
2163     case FUN_STATIC:
2164     case THUNK_STATIC:
2165     case CONSTR_INTLIKE:
2166     case CONSTR_CHARLIKE:
2167     case CONSTR_NOCAF_STATIC:
2168     case UPDATE_FRAME:
2169     case CATCH_FRAME:
2170     case STOP_FRAME:
2171     case RET_DYN:
2172     case RET_BCO:
2173     case RET_SMALL:
2174     case RET_VEC_SMALL:
2175     case RET_BIG:
2176     case RET_VEC_BIG:
2177     case IND:
2178     case BLOCKED_FETCH:
2179     case FETCH_ME:
2180     case FETCH_ME_BQ:
2181     case RBH:
2182     case REMOTE_REF:
2183     case EVACUATED:
2184     case INVALID_OBJECT:
2185     default:
2186         barf("Invalid object in sanityCheckHeapClosure(): %d",
2187              get_itbl(c)->type);
2188         return 0;
2189     }
2190 }
2191
2192 static nat
2193 heapCheck( bdescr *bd )
2194 {
2195     StgPtr p;
2196     static nat costSum, size;
2197
2198     costSum = 0;
2199     while (bd != NULL) {
2200         p = bd->start;
2201         while (p < bd->free) {
2202             size = sanityCheckHeapClosure((StgClosure *)p);
2203             sumOfCostLinear += size;
2204             costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2205             p += size;
2206             // no need for slop check; I think slops are not used currently.
2207         }
2208         ASSERT(p == bd->free);
2209         costSum += bd->free - bd->start;
2210         bd = bd->link;
2211     }
2212
2213     return costSum;
2214 }
2215
2216 static nat
2217 smallObjectPoolCheck(void)
2218 {
2219     bdescr *bd;
2220     StgPtr p;
2221     static nat costSum, size;
2222
2223     bd = small_alloc_list;
2224     costSum = 0;
2225
2226     // first block
2227     if (bd == NULL)
2228         return costSum;
2229
2230     p = bd->start;
2231     while (p < alloc_Hp) {
2232         size = sanityCheckHeapClosure((StgClosure *)p);
2233         sumOfCostLinear += size;
2234         costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2235         p += size;
2236     }
2237     ASSERT(p == alloc_Hp);
2238     costSum += alloc_Hp - bd->start;
2239
2240     bd = bd->link;
2241     while (bd != NULL) {
2242         p = bd->start;
2243         while (p < bd->free) {
2244             size = sanityCheckHeapClosure((StgClosure *)p);
2245             sumOfCostLinear += size;
2246             costArrayLinear[get_itbl((StgClosure *)p)->type] += size;
2247             p += size;
2248         }
2249         ASSERT(p == bd->free);
2250         costSum += bd->free - bd->start;
2251         bd = bd->link;
2252     }
2253
2254     return costSum;
2255 }
2256
2257 static nat
2258 chainCheck(bdescr *bd)
2259 {
2260     nat costSum, size;
2261
2262     costSum = 0;
2263     while (bd != NULL) {
2264         // bd->free - bd->start is not an accurate measurement of the
2265         // object size.  Actually it is always zero, so we compute its
2266         // size explicitly.
2267         size = sanityCheckHeapClosure((StgClosure *)bd->start);
2268         sumOfCostLinear += size;
2269         costArrayLinear[get_itbl((StgClosure *)bd->start)->type] += size;
2270         costSum += size;
2271         bd = bd->link;
2272     }
2273
2274     return costSum;
2275 }
2276
2277 static nat
2278 checkHeapSanityForRetainerProfiling( void )
2279 {
2280     nat costSum, g, s;
2281
2282     costSum = 0;
2283     debugBelch("START: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2284     if (RtsFlags.GcFlags.generations == 1) {
2285         costSum += heapCheck(g0s0->to_blocks);
2286         debugBelch("heapCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2287         costSum += chainCheck(g0s0->large_objects);
2288         debugBelch("chainCheck: sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2289     } else {
2290         for (g = 0; g < RtsFlags.GcFlags.generations; g++)
2291         for (s = 0; s < generations[g].n_steps; s++) {
2292             /*
2293               After all live objects have been scavenged, the garbage
2294               collector may create some objects in
2295               scheduleFinalizers(). These objects are created throught
2296               allocate(), so the small object pool or the large object
2297               pool of the g0s0 may not be empty.
2298             */
2299             if (g == 0 && s == 0) {
2300                 costSum += smallObjectPoolCheck();
2301                 debugBelch("smallObjectPoolCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2302                 costSum += chainCheck(generations[g].steps[s].large_objects);
2303                 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2304             } else {
2305                 costSum += heapCheck(generations[g].steps[s].blocks);
2306                 debugBelch("heapCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2307                 costSum += chainCheck(generations[g].steps[s].large_objects);
2308                 debugBelch("chainCheck(): sumOfCostLinear = %d, costSum = %d\n", sumOfCostLinear, costSum);
2309             }
2310         }
2311     }
2312
2313     return costSum;
2314 }
2315
2316 void
2317 findPointer(StgPtr p)
2318 {
2319     StgPtr q, r, e;
2320     bdescr *bd;
2321     nat g, s;
2322
2323     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2324         for (s = 0; s < generations[g].n_steps; s++) {
2325             // if (g == 0 && s == 0) continue;
2326             bd = generations[g].steps[s].blocks;
2327             for (; bd; bd = bd->link) {
2328                 for (q = bd->start; q < bd->free; q++) {
2329                     if (*q == (StgWord)p) {
2330                         r = q;
2331                         while (!LOOKS_LIKE_GHC_INFO(*r)) r--;
2332                         debugBelch("Found in gen[%d], step[%d]: q = %p, r = %p\n", g, s, q, r);
2333                         // return;
2334                     }
2335                 }
2336             }
2337             bd = generations[g].steps[s].large_objects;
2338             for (; bd; bd = bd->link) {
2339                 e = bd->start + cost((StgClosure *)bd->start);
2340                 for (q = bd->start; q < e; q++) {
2341                     if (*q == (StgWord)p) {
2342                         r = q;
2343                         while (*r == 0 || !LOOKS_LIKE_GHC_INFO(*r)) r--;
2344                         debugBelch("Found in gen[%d], large_objects: %p\n", g, r);
2345                         // return;
2346                     }
2347                 }
2348             }
2349         }
2350     }
2351 }
2352
2353 static void
2354 belongToHeap(StgPtr p)
2355 {
2356     bdescr *bd;
2357     nat g, s;
2358
2359     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
2360         for (s = 0; s < generations[g].n_steps; s++) {
2361             // if (g == 0 && s == 0) continue;
2362             bd = generations[g].steps[s].blocks;
2363             for (; bd; bd = bd->link) {
2364                 if (bd->start <= p && p < bd->free) {
2365                     debugBelch("Belongs to gen[%d], step[%d]", g, s);
2366                     return;
2367                 }
2368             }
2369             bd = generations[g].steps[s].large_objects;
2370             for (; bd; bd = bd->link) {
2371                 if (bd->start <= p && p < bd->start + getHeapClosureSize((StgClosure *)bd->start)) {
2372                     debugBelch("Found in gen[%d], large_objects: %p\n", g, bd->start);
2373                     return;
2374                 }
2375             }
2376         }
2377     }
2378 }
2379 #endif // DEBUG_RETAINER
2380
2381 #endif /* PROFILING */