ghc/rts/RetainerProfile.c

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