rts/ProfHeap.c

   1 /* ----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2003
   4  *
   5  * Support for heap profiling
   6  *
   7  * --------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #include "Rts.h"
  11
  12 #include "RtsUtils.h"
  13 #include "Profiling.h"
  14 #include "ProfHeap.h"
  15 #include "Stats.h"
  16 #include "Hash.h"
  17 #include "RetainerProfile.h"
  18 #include "Arena.h"
  19 #include "Printer.h"
  20
  21 #include <string.h>
  22
  23 /* -----------------------------------------------------------------------------
  24  * era stores the current time period.  It is the same as the
  25  * number of censuses that have been performed.
  26  *
  27  * RESTRICTION:
  28  *   era must be no longer than LDV_SHIFT (15 or 30) bits.
  29  * Invariants:
  30  *   era is initialized to 1 in initHeapProfiling().
  31  *
  32  * max_era is initialized to 2^LDV_SHIFT in initHeapProfiling().
  33  * When era reaches max_era, the profiling stops because a closure can
  34  * store only up to (max_era - 1) as its creation or last use time.
  35  * -------------------------------------------------------------------------- */
  36 unsigned int era;
  37 static nat max_era;
  38
  39 /* -----------------------------------------------------------------------------
  40  * Counters
  41  *
  42  * For most heap profiles each closure identity gets a simple count
  43  * of live words in the heap at each census.  However, if we're
  44  * selecting by biography, then we have to keep the various
  45  * lag/drag/void counters for each identity.
  46  * -------------------------------------------------------------------------- */
  47 typedef struct _counter {
  48     void *identity;
  49     union {
  50         nat resid;
  51         struct {
  52             int prim;     // total size of 'inherently used' closures
  53             int not_used; // total size of 'never used' closures
  54             int used;     // total size of 'used at least once' closures
  55             int void_total;  // current total size of 'destroyed without being used' closures
  56             int drag_total;  // current total size of 'used at least once and waiting to die'
  57         } ldv;
  58     } c;
  59     struct _counter *next;
  60 } counter;
  61
  62 STATIC_INLINE void
  63 initLDVCtr( counter *ctr )
  64 {
  65     ctr->c.ldv.prim = 0;
  66     ctr->c.ldv.not_used = 0;
  67     ctr->c.ldv.used = 0;
  68     ctr->c.ldv.void_total = 0;
  69     ctr->c.ldv.drag_total = 0;
  70 }
  71
  72 typedef struct {
  73     double      time;    // the time in MUT time when the census is made
  74     HashTable * hash;
  75     counter   * ctrs;
  76     Arena     * arena;
  77
  78     // for LDV profiling, when just displaying by LDV
  79     int       prim;
  80     int       not_used;
  81     int       used;
  82     int       void_total;
  83     int       drag_total;
  84 } Census;
  85
  86 static Census *censuses = NULL;
  87 static nat n_censuses = 0;
  88
  89 #ifdef PROFILING
  90 static void aggregateCensusInfo( void );
  91 #endif
  92
  93 static void dumpCensus( Census *census );
  94
  95 static rtsBool closureSatisfiesConstraints( StgClosure* p );
  96
  97 /* ----------------------------------------------------------------------------
  98  * Find the "closure identity", which is a unique pointer reresenting
  99  * the band to which this closure's heap space is attributed in the
 100  * heap profile.
 101  * ------------------------------------------------------------------------- */
 102 static void *
 103 closureIdentity( StgClosure *p )
 104 {
 105     switch (RtsFlags.ProfFlags.doHeapProfile) {
 106
 107 #ifdef PROFILING
 108     case HEAP_BY_CCS:
 109         return p->header.prof.ccs;
 110     case HEAP_BY_MOD:
 111         return p->header.prof.ccs->cc->module;
 112     case HEAP_BY_DESCR:
 113         return GET_PROF_DESC(get_itbl(p));
 114     case HEAP_BY_TYPE:
 115         return GET_PROF_TYPE(get_itbl(p));
 116     case HEAP_BY_RETAINER:
 117         // AFAIK, the only closures in the heap which might not have a
 118         // valid retainer set are DEAD_WEAK closures.
 119         if (isRetainerSetFieldValid(p))
 120             return retainerSetOf(p);
 121         else
 122             return NULL;
 123
 124 #else
 125     case HEAP_BY_CLOSURE_TYPE:
 126     {
 127         StgInfoTable *info;
 128         info = get_itbl(p);
 129         switch (info->type) {
 130         case CONSTR:
 131         case CONSTR_1_0:
 132         case CONSTR_0_1:
 133         case CONSTR_2_0:
 134         case CONSTR_1_1:
 135         case CONSTR_0_2:
 136         case CONSTR_STATIC:
 137         case CONSTR_NOCAF_STATIC:
 138             return GET_CON_DESC(itbl_to_con_itbl(info));
 139         default:
 140             return closure_type_names[info->type];
 141         }
 142     }
 143
 144 #endif
 145     default:
 146         barf("closureIdentity");
 147     }
 148 }
 149
 150 /* --------------------------------------------------------------------------
 151  * Profiling type predicates
 152  * ----------------------------------------------------------------------- */
 153 #ifdef PROFILING
 154 STATIC_INLINE rtsBool
 155 doingLDVProfiling( void )
 156 {
 157     return (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
 158             || RtsFlags.ProfFlags.bioSelector != NULL);
 159 }
 160
 161 STATIC_INLINE rtsBool
 162 doingRetainerProfiling( void )
 163 {
 164     return (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER
 165             || RtsFlags.ProfFlags.retainerSelector != NULL);
 166 }
 167 #endif /* PROFILING */
 168
 169 // Precesses a closure 'c' being destroyed whose size is 'size'.
 170 // Make sure that LDV_recordDead() is not invoked on 'inherently used' closures
 171 // such as TSO; they should not be involved in computing dragNew or voidNew.
 172 //
 173 // Even though era is checked in both LdvCensusForDead() and
 174 // LdvCensusKillAll(), we still need to make sure that era is > 0 because
 175 // LDV_recordDead() may be called from elsewhere in the runtime system. E.g.,
 176 // when a thunk is replaced by an indirection object.
 177
 178 #ifdef PROFILING
 179 void
 180 LDV_recordDead( StgClosure *c, nat size )
 181 {
 182     void *id;
 183     nat t;
 184     counter *ctr;
 185
 186     if (era > 0 && closureSatisfiesConstraints(c)) {
 187         size -= sizeofW(StgProfHeader);
 188         ASSERT(LDVW(c) != 0);
 189         if ((LDVW((c)) & LDV_STATE_MASK) == LDV_STATE_CREATE) {
 190             t = (LDVW((c)) & LDV_CREATE_MASK) >> LDV_SHIFT;
 191             if (t < era) {
 192                 if (RtsFlags.ProfFlags.bioSelector == NULL) {
 193                     censuses[t].void_total   += (int)size;
 194                     censuses[era].void_total -= (int)size;
 195                     ASSERT(censuses[t].void_total < censuses[t].not_used);
 196                 } else {
 197                     id = closureIdentity(c);
 198                     ctr = lookupHashTable(censuses[t].hash, (StgWord)id);
 199                     ASSERT( ctr != NULL );
 200                     ctr->c.ldv.void_total += (int)size;
 201                     ctr = lookupHashTable(censuses[era].hash, (StgWord)id);
 202                     if (ctr == NULL) {
 203                         ctr = arenaAlloc(censuses[era].arena, sizeof(counter));
 204                         initLDVCtr(ctr);
 205                         insertHashTable(censuses[era].hash, (StgWord)id, ctr);
 206                         ctr->identity = id;
 207                         ctr->next = censuses[era].ctrs;
 208                         censuses[era].ctrs = ctr;
 209                     }
 210                     ctr->c.ldv.void_total -= (int)size;
 211                 }
 212             }
 213         } else {
 214             t = LDVW((c)) & LDV_LAST_MASK;
 215             if (t + 1 < era) {
 216                 if (RtsFlags.ProfFlags.bioSelector == NULL) {
 217                     censuses[t+1].drag_total += size;
 218                     censuses[era].drag_total -= size;
 219                 } else {
 220                     void *id;
 221                     id = closureIdentity(c);
 222                     ctr = lookupHashTable(censuses[t+1].hash, (StgWord)id);
 223                     ASSERT( ctr != NULL );
 224                     ctr->c.ldv.drag_total += (int)size;
 225                     ctr = lookupHashTable(censuses[era].hash, (StgWord)id);
 226                     if (ctr == NULL) {
 227                         ctr = arenaAlloc(censuses[era].arena, sizeof(counter));
 228                         initLDVCtr(ctr);
 229                         insertHashTable(censuses[era].hash, (StgWord)id, ctr);
 230                         ctr->identity = id;
 231                         ctr->next = censuses[era].ctrs;
 232                         censuses[era].ctrs = ctr;
 233                     }
 234                     ctr->c.ldv.drag_total -= (int)size;
 235                 }
 236             }
 237         }
 238     }
 239 }
 240 #endif
 241
 242 /* --------------------------------------------------------------------------
 243  * Initialize censuses[era];
 244  * ----------------------------------------------------------------------- */
 245
 246 STATIC_INLINE void
 247 initEra(Census *census)
 248 {
 249     census->hash  = allocHashTable();
 250     census->ctrs  = NULL;
 251     census->arena = newArena();
 252
 253     census->not_used   = 0;
 254     census->used       = 0;
 255     census->prim       = 0;
 256     census->void_total = 0;
 257     census->drag_total = 0;
 258 }
 259
 260 STATIC_INLINE void
 261 freeEra(Census *census)
 262 {
 263     if (RtsFlags.ProfFlags.bioSelector != NULL)
 264         // when bioSelector==NULL, these are freed in heapCensus()
 265     {
 266         arenaFree(census->arena);
 267         freeHashTable(census->hash, NULL);
 268     }
 269 }
 270
 271 /* --------------------------------------------------------------------------
 272  * Increases era by 1 and initialize census[era].
 273  * Reallocates gi[] and increases its size if needed.
 274  * ----------------------------------------------------------------------- */
 275
 276 static void
 277 nextEra( void )
 278 {
 279 #ifdef PROFILING
 280     if (doingLDVProfiling()) {
 281         era++;
 282
 283         if (era == max_era) {
 284             errorBelch("maximum number of censuses reached; use +RTS -i to reduce");
 285             stg_exit(EXIT_FAILURE);
 286         }
 287
 288         if (era == n_censuses) {
 289             n_censuses *= 2;
 290             censuses = stgReallocBytes(censuses, sizeof(Census) * n_censuses,
 291                                        "nextEra");
 292         }
 293     }
 294 #endif /* PROFILING */
 295
 296     initEra( &censuses[era] );
 297 }
 298
 299 /* ----------------------------------------------------------------------------
 300  * Heap profiling by info table
 301  * ------------------------------------------------------------------------- */
 302
 303 #if !defined(PROFILING)
 304 FILE *hp_file;
 305 static char *hp_filename;
 306
 307 void initProfiling1 (void)
 308 {
 309 }
 310
 311 void freeProfiling1 (void)
 312 {
 313 }
 314
 315 void initProfiling2 (void)
 316 {
 317     char *prog;
 318
 319     prog = stgMallocBytes(strlen(prog_name) + 1, "initProfiling2");
 320     strcpy(prog, prog_name);
 321 #ifdef mingw32_HOST_OS
 322     // on Windows, drop the .exe suffix if there is one
 323     {
 324         char *suff;
 325         suff = strrchr(prog,'.');
 326         if (suff != NULL && !strcmp(suff,".exe")) {
 327             *suff = '\0';
 328         }
 329     }
 330 #endif
 331
 332   if (RtsFlags.ProfFlags.doHeapProfile) {
 333     /* Initialise the log file name */
 334     hp_filename = stgMallocBytes(strlen(prog) + 6, "hpFileName");
 335     sprintf(hp_filename, "%s.hp", prog);
 336
 337     /* open the log file */
 338     if ((hp_file = fopen(hp_filename, "w")) == NULL) {
 339       debugBelch("Can't open profiling report file %s\n",
 340               hp_filename);
 341       RtsFlags.ProfFlags.doHeapProfile = 0;
 342       return;
 343     }
 344   }
 345
 346   stgFree(prog);
 347
 348   initHeapProfiling();
 349 }
 350
 351 void endProfiling( void )
 352 {
 353   endHeapProfiling();
 354 }
 355 #endif /* !PROFILING */
 356
 357 static void
 358 printSample(rtsBool beginSample, StgDouble sampleValue)
 359 {
 360     StgDouble fractionalPart, integralPart;
 361     fractionalPart = modf(sampleValue, &integralPart);
 362     fprintf(hp_file, "%s %" FMT_Word64 ".%02" FMT_Word64 "\n",
 363             (beginSample ? "BEGIN_SAMPLE" : "END_SAMPLE"),
 364             (StgWord64)integralPart, (StgWord64)(fractionalPart * 100));
 365 }
 366
 367 /* --------------------------------------------------------------------------
 368  * Initialize the heap profilier
 369  * ----------------------------------------------------------------------- */
 370 nat
 371 initHeapProfiling(void)
 372 {
 373     if (! RtsFlags.ProfFlags.doHeapProfile) {
 374         return 0;
 375     }
 376
 377 #ifdef PROFILING
 378     if (doingLDVProfiling() && doingRetainerProfiling()) {
 379         errorBelch("cannot mix -hb and -hr");
 380         stg_exit(EXIT_FAILURE);
 381     }
 382 #endif
 383
 384     // we only count eras if we're doing LDV profiling.  Otherwise era
 385     // is fixed at zero.
 386 #ifdef PROFILING
 387     if (doingLDVProfiling()) {
 388         era = 1;
 389     } else
 390 #endif
 391     {
 392         era = 0;
 393     }
 394
 395     // max_era = 2^LDV_SHIFT
 396         max_era = 1 << LDV_SHIFT;
 397
 398     n_censuses = 32;
 399     censuses = stgMallocBytes(sizeof(Census) * n_censuses, "initHeapProfiling");
 400
 401     initEra( &censuses[era] );
 402
 403     /* initProfilingLogFile(); */
 404     fprintf(hp_file, "JOB \"%s", prog_name);
 405
 406 #ifdef PROFILING
 407     {
 408         int count;
 409         for(count = 1; count < prog_argc; count++)
 410             fprintf(hp_file, " %s", prog_argv[count]);
 411         fprintf(hp_file, " +RTS");
 412         for(count = 0; count < rts_argc; count++)
 413             fprintf(hp_file, " %s", rts_argv[count]);
 414     }
 415 #endif /* PROFILING */
 416
 417     fprintf(hp_file, "\"\n" );
 418
 419     fprintf(hp_file, "DATE \"%s\"\n", time_str());
 420
 421     fprintf(hp_file, "SAMPLE_UNIT \"seconds\"\n");
 422     fprintf(hp_file, "VALUE_UNIT \"bytes\"\n");
 423
 424     printSample(rtsTrue, 0);
 425     printSample(rtsFalse, 0);
 426
 427 #ifdef PROFILING
 428     if (doingRetainerProfiling()) {
 429         initRetainerProfiling();
 430     }
 431 #endif
 432
 433     return 0;
 434 }
 435
 436 void
 437 endHeapProfiling(void)
 438 {
 439     StgDouble seconds;
 440
 441     if (! RtsFlags.ProfFlags.doHeapProfile) {
 442         return;
 443     }
 444
 445 #ifdef PROFILING
 446     if (doingRetainerProfiling()) {
 447         endRetainerProfiling();
 448     }
 449 #endif
 450
 451 #ifdef PROFILING
 452     if (doingLDVProfiling()) {
 453         nat t;
 454         LdvCensusKillAll();
 455         aggregateCensusInfo();
 456         for (t = 1; t < era; t++) {
 457             dumpCensus( &censuses[t] );
 458         }
 459     }
 460 #endif
 461
 462 #ifdef PROFILING
 463     if (doingLDVProfiling()) {
 464         nat t;
 465         for (t = 1; t <= era; t++) {
 466             freeEra( &censuses[t] );
 467         }
 468     } else {
 469         freeEra( &censuses[0] );
 470     }
 471 #else
 472     freeEra( &censuses[0] );
 473 #endif
 474
 475     stgFree(censuses);
 476
 477     seconds = mut_user_time();
 478     printSample(rtsTrue, seconds);
 479     printSample(rtsFalse, seconds);
 480     fclose(hp_file);
 481 }
 482
 483
 484
 485 #ifdef PROFILING
 486 static size_t
 487 buf_append(char *p, const char *q, char *end)
 488 {
 489     int m;
 490
 491     for (m = 0; p < end; p++, q++, m++) {
 492         *p = *q;
 493         if (*q == '\0') { break; }
 494     }
 495     return m;
 496 }
 497
 498 static void
 499 fprint_ccs(FILE *fp, CostCentreStack *ccs, nat max_length)
 500 {
 501     char buf[max_length+1], *p, *buf_end;
 502
 503     // MAIN on its own gets printed as "MAIN", otherwise we ignore MAIN.
 504     if (ccs == CCS_MAIN) {
 505         fprintf(fp, "MAIN");
 506         return;
 507     }
 508
 509     fprintf(fp, "(%ld)", ccs->ccsID);
 510
 511     p = buf;
 512     buf_end = buf + max_length + 1;
 513
 514     // keep printing components of the stack until we run out of space
 515     // in the buffer.  If we run out of space, end with "...".
 516     for (; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) {
 517
 518         // CAF cost centres print as M.CAF, but we leave the module
 519         // name out of all the others to save space.
 520         if (!strcmp(ccs->cc->label,"CAF")) {
 521             p += buf_append(p, ccs->cc->module, buf_end);
 522             p += buf_append(p, ".CAF", buf_end);
 523         } else {
 524             p += buf_append(p, ccs->cc->label, buf_end);
 525             if (ccs->prevStack != NULL && ccs->prevStack != CCS_MAIN) {
 526                 p += buf_append(p, "/", buf_end);
 527             }
 528         }
 529
 530         if (p >= buf_end) {
 531             sprintf(buf+max_length-4, "...");
 532             break;
 533         }
 534     }
 535     fprintf(fp, "%s", buf);
 536 }
 537
 538 rtsBool
 539 strMatchesSelector( char* str, char* sel )
 540 {
 541    char* p;
 542    // debugBelch("str_matches_selector %s %s\n", str, sel);
 543    while (1) {
 544        // Compare str against wherever we've got to in sel.
 545        p = str;
 546        while (*p != '\0' && *sel != ',' && *sel != '\0' && *p == *sel) {
 547            p++; sel++;
 548        }
 549        // Match if all of str used and have reached the end of a sel fragment.
 550        if (*p == '\0' && (*sel == ',' || *sel == '\0'))
 551            return rtsTrue;
 552
 553        // No match.  Advance sel to the start of the next elem.
 554        while (*sel != ',' && *sel != '\0') sel++;
 555        if (*sel == ',') sel++;
 556
 557        /* Run out of sel ?? */
 558        if (*sel == '\0') return rtsFalse;
 559    }
 560 }
 561
 562 #endif /* PROFILING */
 563
 564 /* -----------------------------------------------------------------------------
 565  * Figure out whether a closure should be counted in this census, by
 566  * testing against all the specified constraints.
 567  * -------------------------------------------------------------------------- */
 568 static rtsBool
 569 closureSatisfiesConstraints( StgClosure* p )
 570 {
 571 #if !defined(PROFILING)
 572     (void)p;   /* keep gcc -Wall happy */
 573     return rtsTrue;
 574 #else
 575    rtsBool b;
 576
 577    // The CCS has a selected field to indicate whether this closure is
 578    // deselected by not being mentioned in the module, CC, or CCS
 579    // selectors.
 580    if (!p->header.prof.ccs->selected) {
 581        return rtsFalse;
 582    }
 583
 584    if (RtsFlags.ProfFlags.descrSelector) {
 585        b = strMatchesSelector( (GET_PROF_DESC(get_itbl((StgClosure *)p))),
 586                                  RtsFlags.ProfFlags.descrSelector );
 587        if (!b) return rtsFalse;
 588    }
 589    if (RtsFlags.ProfFlags.typeSelector) {
 590        b = strMatchesSelector( (GET_PROF_TYPE(get_itbl((StgClosure *)p))),
 591                                 RtsFlags.ProfFlags.typeSelector );
 592        if (!b) return rtsFalse;
 593    }
 594    if (RtsFlags.ProfFlags.retainerSelector) {
 595        RetainerSet *rs;
 596        nat i;
 597        // We must check that the retainer set is valid here.  One
 598        // reason it might not be valid is if this closure is a
 599        // a newly deceased weak pointer (i.e. a DEAD_WEAK), since
 600        // these aren't reached by the retainer profiler's traversal.
 601        if (isRetainerSetFieldValid((StgClosure *)p)) {
 602            rs = retainerSetOf((StgClosure *)p);
 603            if (rs != NULL) {
 604                for (i = 0; i < rs->num; i++) {
 605                    b = strMatchesSelector( rs->element[i]->cc->label,
 606                                            RtsFlags.ProfFlags.retainerSelector );
 607                    if (b) return rtsTrue;
 608                }
 609            }
 610        }
 611        return rtsFalse;
 612    }
 613    return rtsTrue;
 614 #endif /* PROFILING */
 615 }
 616
 617 /* -----------------------------------------------------------------------------
 618  * Aggregate the heap census info for biographical profiling
 619  * -------------------------------------------------------------------------- */
 620 #ifdef PROFILING
 621 static void
 622 aggregateCensusInfo( void )
 623 {
 624     HashTable *acc;
 625     nat t;
 626     counter *c, *d, *ctrs;
 627     Arena *arena;
 628
 629     if (!doingLDVProfiling()) return;
 630
 631     // Aggregate the LDV counters when displaying by biography.
 632     if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
 633         int void_total, drag_total;
 634
 635         // Now we compute void_total and drag_total for each census
 636         // After the program has finished, the void_total field of
 637         // each census contains the count of words that were *created*
 638         // in this era and were eventually void.  Conversely, if a
 639         // void closure was destroyed in this era, it will be
 640         // represented by a negative count of words in void_total.
 641         //
 642         // To get the count of live words that are void at each
 643         // census, just propagate the void_total count forwards:
 644
 645         void_total = 0;
 646         drag_total = 0;
 647         for (t = 1; t < era; t++) { // note: start at 1, not 0
 648             void_total += censuses[t].void_total;
 649             drag_total += censuses[t].drag_total;
 650             censuses[t].void_total = void_total;
 651             censuses[t].drag_total = drag_total;
 652
 653             ASSERT( censuses[t].void_total <= censuses[t].not_used );
 654             // should be true because: void_total is the count of
 655             // live words that are void at this census, which *must*
 656             // be less than the number of live words that have not
 657             // been used yet.
 658
 659             ASSERT( censuses[t].drag_total <= censuses[t].used );
 660             // similar reasoning as above.
 661         }
 662
 663         return;
 664     }
 665
 666     // otherwise... we're doing a heap profile that is restricted to
 667     // some combination of lag, drag, void or use.  We've kept all the
 668     // census info for all censuses so far, but we still need to
 669     // aggregate the counters forwards.
 670
 671     arena = newArena();
 672     acc = allocHashTable();
 673     ctrs = NULL;
 674
 675     for (t = 1; t < era; t++) {
 676
 677         // first look through all the counters we're aggregating
 678         for (c = ctrs; c != NULL; c = c->next) {
 679             // if one of the totals is non-zero, then this closure
 680             // type must be present in the heap at this census time...
 681             d = lookupHashTable(censuses[t].hash, (StgWord)c->identity);
 682
 683             if (d == NULL) {
 684                 // if this closure identity isn't present in the
 685                 // census for this time period, then our running
 686                 // totals *must* be zero.
 687                 ASSERT(c->c.ldv.void_total == 0 && c->c.ldv.drag_total == 0);
 688
 689                 // debugCCS(c->identity);
 690                 // debugBelch(" census=%d void_total=%d drag_total=%d\n",
 691                 //         t, c->c.ldv.void_total, c->c.ldv.drag_total);
 692             } else {
 693                 d->c.ldv.void_total += c->c.ldv.void_total;
 694                 d->c.ldv.drag_total += c->c.ldv.drag_total;
 695                 c->c.ldv.void_total =  d->c.ldv.void_total;
 696                 c->c.ldv.drag_total =  d->c.ldv.drag_total;
 697
 698                 ASSERT( c->c.ldv.void_total >= 0 );
 699                 ASSERT( c->c.ldv.drag_total >= 0 );
 700             }
 701         }
 702
 703         // now look through the counters in this census to find new ones
 704         for (c = censuses[t].ctrs; c != NULL; c = c->next) {
 705             d = lookupHashTable(acc, (StgWord)c->identity);
 706             if (d == NULL) {
 707                 d = arenaAlloc( arena, sizeof(counter) );
 708                 initLDVCtr(d);
 709                 insertHashTable( acc, (StgWord)c->identity, d );
 710                 d->identity = c->identity;
 711                 d->next = ctrs;
 712                 ctrs = d;
 713                 d->c.ldv.void_total = c->c.ldv.void_total;
 714                 d->c.ldv.drag_total = c->c.ldv.drag_total;
 715             }
 716             ASSERT( c->c.ldv.void_total >= 0 );
 717             ASSERT( c->c.ldv.drag_total >= 0 );
 718         }
 719     }
 720
 721     freeHashTable(acc, NULL);
 722     arenaFree(arena);
 723 }
 724 #endif
 725
 726 /* -----------------------------------------------------------------------------
 727  * Print out the results of a heap census.
 728  * -------------------------------------------------------------------------- */
 729 static void
 730 dumpCensus( Census *census )
 731 {
 732     counter *ctr;
 733     int count;
 734
 735     printSample(rtsTrue, census->time);
 736
 737 #ifdef PROFILING
 738     if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
 739       fprintf(hp_file, "VOID\t%lu\n", (unsigned long)(census->void_total) * sizeof(W_));
 740         fprintf(hp_file, "LAG\t%lu\n",
 741                 (unsigned long)(census->not_used - census->void_total) * sizeof(W_));
 742         fprintf(hp_file, "USE\t%lu\n",
 743                 (unsigned long)(census->used - census->drag_total) * sizeof(W_));
 744         fprintf(hp_file, "INHERENT_USE\t%lu\n",
 745                 (unsigned long)(census->prim) * sizeof(W_));
 746         fprintf(hp_file, "DRAG\t%lu\n",
 747                 (unsigned long)(census->drag_total) * sizeof(W_));
 748         printSample(rtsFalse, census->time);
 749         return;
 750     }
 751 #endif
 752
 753     for (ctr = census->ctrs; ctr != NULL; ctr = ctr->next) {
 754
 755 #ifdef PROFILING
 756         if (RtsFlags.ProfFlags.bioSelector != NULL) {
 757             count = 0;
 758             if (strMatchesSelector("lag", RtsFlags.ProfFlags.bioSelector))
 759                 count += ctr->c.ldv.not_used - ctr->c.ldv.void_total;
 760             if (strMatchesSelector("drag", RtsFlags.ProfFlags.bioSelector))
 761                 count += ctr->c.ldv.drag_total;
 762             if (strMatchesSelector("void", RtsFlags.ProfFlags.bioSelector))
 763                 count += ctr->c.ldv.void_total;
 764             if (strMatchesSelector("use", RtsFlags.ProfFlags.bioSelector))
 765                 count += ctr->c.ldv.used - ctr->c.ldv.drag_total;
 766         } else
 767 #endif
 768         {
 769             count = ctr->c.resid;
 770         }
 771
 772         ASSERT( count >= 0 );
 773
 774         if (count == 0) continue;
 775
 776 #if !defined(PROFILING)
 777         switch (RtsFlags.ProfFlags.doHeapProfile) {
 778         case HEAP_BY_CLOSURE_TYPE:
 779             fprintf(hp_file, "%s", (char *)ctr->identity);
 780             break;
 781         }
 782 #endif
 783
 784 #ifdef PROFILING
 785         switch (RtsFlags.ProfFlags.doHeapProfile) {
 786         case HEAP_BY_CCS:
 787             fprint_ccs(hp_file, (CostCentreStack *)ctr->identity, RtsFlags.ProfFlags.ccsLength);
 788             break;
 789         case HEAP_BY_MOD:
 790         case HEAP_BY_DESCR:
 791         case HEAP_BY_TYPE:
 792             fprintf(hp_file, "%s", (char *)ctr->identity);
 793             break;
 794         case HEAP_BY_RETAINER:
 795         {
 796             RetainerSet *rs = (RetainerSet *)ctr->identity;
 797
 798             // it might be the distinguished retainer set rs_MANY:
 799             if (rs == &rs_MANY) {
 800                 fprintf(hp_file, "MANY");
 801                 break;
 802             }
 803
 804             // Mark this retainer set by negating its id, because it
 805             // has appeared in at least one census.  We print the
 806             // values of all such retainer sets into the log file at
 807             // the end.  A retainer set may exist but not feature in
 808             // any censuses if it arose as the intermediate retainer
 809             // set for some closure during retainer set calculation.
 810             if (rs->id > 0)
 811                 rs->id = -(rs->id);
 812
 813             // report in the unit of bytes: * sizeof(StgWord)
 814             printRetainerSetShort(hp_file, rs);
 815             break;
 816         }
 817         default:
 818             barf("dumpCensus; doHeapProfile");
 819         }
 820 #endif
 821
 822         fprintf(hp_file, "\t%lu\n", (unsigned long)count * sizeof(W_));
 823     }
 824
 825     printSample(rtsFalse, census->time);
 826 }
 827
 828 /* -----------------------------------------------------------------------------
 829  * Code to perform a heap census.
 830  * -------------------------------------------------------------------------- */
 831 static void
 832 heapCensusChain( Census *census, bdescr *bd )
 833 {
 834     StgPtr p;
 835     StgInfoTable *info;
 836     void *identity;
 837     nat size;
 838     counter *ctr;
 839     nat real_size;
 840     rtsBool prim;
 841
 842     for (; bd != NULL; bd = bd->link) {
 843
 844         // HACK: ignore pinned blocks, because they contain gaps.
 845         // It's not clear exactly what we'd like to do here, since we
 846         // can't tell which objects in the block are actually alive.
 847         // Perhaps the whole block should be counted as SYSTEM memory.
 848         if (bd->flags & BF_PINNED) {
 849             continue;
 850         }
 851
 852         p = bd->start;
 853         while (p < bd->free) {
 854             info = get_itbl((StgClosure *)p);
 855             prim = rtsFalse;
 856
 857             switch (info->type) {
 858
 859             case THUNK:
 860                 size = thunk_sizeW_fromITBL(info);
 861                 break;
 862
 863             case THUNK_1_1:
 864             case THUNK_0_2:
 865             case THUNK_2_0:
 866                 size = sizeofW(StgThunkHeader) + 2;
 867                 break;
 868
 869             case THUNK_1_0:
 870             case THUNK_0_1:
 871             case THUNK_SELECTOR:
 872                 size = sizeofW(StgThunkHeader) + 1;
 873                 break;
 874
 875             case CONSTR:
 876             case FUN:
 877             case IND_PERM:
 878             case IND_OLDGEN:
 879             case IND_OLDGEN_PERM:
 880             case CAF_BLACKHOLE:
 881             case BLACKHOLE:
 882             case FUN_1_0:
 883             case FUN_0_1:
 884             case FUN_1_1:
 885             case FUN_0_2:
 886             case FUN_2_0:
 887             case CONSTR_1_0:
 888             case CONSTR_0_1:
 889             case CONSTR_1_1:
 890             case CONSTR_0_2:
 891             case CONSTR_2_0:
 892                 size = sizeW_fromITBL(info);
 893                 break;
 894
 895             case IND:
 896                 // Special case/Delicate Hack: INDs don't normally
 897                 // appear, since we're doing this heap census right
 898                 // after GC.  However, GarbageCollect() also does
 899                 // resurrectThreads(), which can update some
 900                 // blackholes when it calls raiseAsync() on the
 901                 // resurrected threads.  So we know that any IND will
 902                 // be the size of a BLACKHOLE.
 903                 size = BLACKHOLE_sizeW();
 904                 break;
 905
 906             case BCO:
 907                 prim = rtsTrue;
 908                 size = bco_sizeW((StgBCO *)p);
 909                 break;
 910
 911             case MVAR_CLEAN:
 912             case MVAR_DIRTY:
 913             case WEAK:
 914             case STABLE_NAME:
 915             case MUT_VAR_CLEAN:
 916             case MUT_VAR_DIRTY:
 917                 prim = rtsTrue;
 918                 size = sizeW_fromITBL(info);
 919                 break;
 920
 921             case AP:
 922                 size = ap_sizeW((StgAP *)p);
 923                 break;
 924
 925             case PAP:
 926                 size = pap_sizeW((StgPAP *)p);
 927                 break;
 928
 929             case AP_STACK:
 930                 size = ap_stack_sizeW((StgAP_STACK *)p);
 931                 break;
 932
 933             case ARR_WORDS:
 934                 prim = rtsTrue;
 935                 size = arr_words_sizeW((StgArrWords*)p);
 936                 break;
 937
 938             case MUT_ARR_PTRS_CLEAN:
 939             case MUT_ARR_PTRS_DIRTY:
 940             case MUT_ARR_PTRS_FROZEN:
 941             case MUT_ARR_PTRS_FROZEN0:
 942                 prim = rtsTrue;
 943                 size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
 944                 break;
 945
 946             case TSO:
 947                 prim = rtsTrue;
 948 #ifdef PROFILING
 949                 if (RtsFlags.ProfFlags.includeTSOs) {
 950                     size = tso_sizeW((StgTSO *)p);
 951                     break;
 952                 } else {
 953                     // Skip this TSO and move on to the next object
 954                     p += tso_sizeW((StgTSO *)p);
 955                     continue;
 956                 }
 957 #else
 958                 size = tso_sizeW((StgTSO *)p);
 959                 break;
 960 #endif
 961
 962             case TREC_HEADER:
 963                 prim = rtsTrue;
 964                 size = sizeofW(StgTRecHeader);
 965                 break;
 966
 967             case TVAR_WATCH_QUEUE:
 968                 prim = rtsTrue;
 969                 size = sizeofW(StgTVarWatchQueue);
 970                 break;
 971
 972             case INVARIANT_CHECK_QUEUE:
 973                 prim = rtsTrue;
 974                 size = sizeofW(StgInvariantCheckQueue);
 975                 break;
 976
 977             case ATOMIC_INVARIANT:
 978                 prim = rtsTrue;
 979                 size = sizeofW(StgAtomicInvariant);
 980                 break;
 981
 982             case TVAR:
 983                 prim = rtsTrue;
 984                 size = sizeofW(StgTVar);
 985                 break;
 986
 987             case TREC_CHUNK:
 988                 prim = rtsTrue;
 989                 size = sizeofW(StgTRecChunk);
 990                 break;
 991
 992             default:
 993                 barf("heapCensus, unknown object: %d", info->type);
 994             }
 995
 996             identity = NULL;
 997
 998 #ifdef PROFILING
 999             // subtract the profiling overhead
1000             real_size = size - sizeofW(StgProfHeader);
1001 #else
1002             real_size = size;
1003 #endif
1004
1005             if (closureSatisfiesConstraints((StgClosure*)p)) {
1006 #ifdef PROFILING
1007                 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) {
1008                     if (prim)
1009                         census->prim += real_size;
1010                     else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
1011                         census->not_used += real_size;
1012                     else
1013                         census->used += real_size;
1014                 } else
1015 #endif
1016                 {
1017                     identity = closureIdentity((StgClosure *)p);
1018
1019                     if (identity != NULL) {
1020                         ctr = lookupHashTable( census->hash, (StgWord)identity );
1021                         if (ctr != NULL) {
1022 #ifdef PROFILING
1023                             if (RtsFlags.ProfFlags.bioSelector != NULL) {
1024                                 if (prim)
1025                                     ctr->c.ldv.prim += real_size;
1026                                 else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
1027                                     ctr->c.ldv.not_used += real_size;
1028                                 else
1029                                     ctr->c.ldv.used += real_size;
1030                             } else
1031 #endif
1032                             {
1033                                 ctr->c.resid += real_size;
1034                             }
1035                         } else {
1036                             ctr = arenaAlloc( census->arena, sizeof(counter) );
1037                             initLDVCtr(ctr);
1038                             insertHashTable( census->hash, (StgWord)identity, ctr );
1039                             ctr->identity = identity;
1040                             ctr->next = census->ctrs;
1041                             census->ctrs = ctr;
1042
1043 #ifdef PROFILING
1044                             if (RtsFlags.ProfFlags.bioSelector != NULL) {
1045                                 if (prim)
1046                                     ctr->c.ldv.prim = real_size;
1047                                 else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE)
1048                                     ctr->c.ldv.not_used = real_size;
1049                                 else
1050                                     ctr->c.ldv.used = real_size;
1051                             } else
1052 #endif
1053                             {
1054                                 ctr->c.resid = real_size;
1055                             }
1056                         }
1057                     }
1058                 }
1059             }
1060
1061             p += size;
1062         }
1063     }
1064 }
1065
1066 void
1067 heapCensus( void )
1068 {
1069   nat g, s;
1070   Census *census;
1071
1072   census = &censuses[era];
1073   census->time  = mut_user_time();
1074
1075   // calculate retainer sets if necessary
1076 #ifdef PROFILING
1077   if (doingRetainerProfiling()) {
1078       retainerProfile();
1079   }
1080 #endif
1081
1082 #ifdef PROFILING
1083   stat_startHeapCensus();
1084 #endif
1085
1086   // Traverse the heap, collecting the census info
1087   if (RtsFlags.GcFlags.generations == 1) {
1088       heapCensusChain( census, g0s0->blocks );
1089   } else {
1090       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1091           for (s = 0; s < generations[g].n_steps; s++) {
1092               heapCensusChain( census, generations[g].steps[s].blocks );
1093               // Are we interested in large objects?  might be
1094               // confusing to include the stack in a heap profile.
1095               heapCensusChain( census, generations[g].steps[s].large_objects );
1096           }
1097       }
1098   }
1099
1100   // dump out the census info
1101 #ifdef PROFILING
1102     // We can't generate any info for LDV profiling until
1103     // the end of the run...
1104     if (!doingLDVProfiling())
1105         dumpCensus( census );
1106 #else
1107     dumpCensus( census );
1108 #endif
1109
1110
1111   // free our storage, unless we're keeping all the census info for
1112   // future restriction by biography.
1113 #ifdef PROFILING
1114   if (RtsFlags.ProfFlags.bioSelector == NULL)
1115   {
1116       freeHashTable( census->hash, NULL/* don't free the elements */ );
1117       arenaFree( census->arena );
1118       census->hash = NULL;
1119       census->arena = NULL;
1120   }
1121 #endif
1122
1123   // we're into the next time period now
1124   nextEra();
1125
1126 #ifdef PROFILING
1127   stat_endHeapCensus();
1128 #endif
1129 }
1130