ghc/rts/RetainerProfile.c

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