rts/sm/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2006
   4  *
   5  * Sanity checking code for the heap and stack.
   6  *
   7  * Used when debugging: check that everything reasonable.
   8  *
   9  *    - All things that are supposed to be pointers look like pointers.
  10  *
  11  *    - Objects in text space are marked as static closures, those
  12  *      in the heap are dynamic.
  13  *
  14  * ---------------------------------------------------------------------------*/
  15
  16 #include "PosixSource.h"
  17 #include "Rts.h"
  18
  19 #ifdef DEBUG                                                   /* whole file */
  20
  21 #include "RtsUtils.h"
  22 #include "sm/Storage.h"
  23 #include "sm/BlockAlloc.h"
  24 #include "Sanity.h"
  25 #include "Schedule.h"
  26 #include "Apply.h"
  27 #include "Printer.h"
  28 #include "Arena.h"
  29
  30 /* -----------------------------------------------------------------------------
  31    Forward decls.
  32    -------------------------------------------------------------------------- */
  33
  34 static void      checkSmallBitmap    ( StgPtr payload, StgWord bitmap, nat );
  35 static void      checkLargeBitmap    ( StgPtr payload, StgLargeBitmap*, nat );
  36 static void      checkClosureShallow ( StgClosure * );
  37
  38 /* -----------------------------------------------------------------------------
  39    Check stack sanity
  40    -------------------------------------------------------------------------- */
  41
  42 static void
  43 checkSmallBitmap( StgPtr payload, StgWord bitmap, nat size )
  44 {
  45     StgPtr p;
  46     nat i;
  47
  48     p = payload;
  49     for(i = 0; i < size; i++, bitmap >>= 1 ) {
  50         if ((bitmap & 1) == 0) {
  51             checkClosureShallow((StgClosure *)payload[i]);
  52         }
  53     }
  54 }
  55
  56 static void
  57 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
  58 {
  59     StgWord bmp;
  60     nat i, j;
  61
  62     i = 0;
  63     for (bmp=0; i < size; bmp++) {
  64         StgWord bitmap = large_bitmap->bitmap[bmp];
  65         j = 0;
  66         for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
  67             if ((bitmap & 1) == 0) {
  68                 checkClosureShallow((StgClosure *)payload[i]);
  69             }
  70         }
  71     }
  72 }
  73
  74 /*
  75  * check that it looks like a valid closure - without checking its payload
  76  * used to avoid recursion between checking PAPs and checking stack
  77  * chunks.
  78  */
  79
  80 static void
  81 checkClosureShallow( StgClosure* p )
  82 {
  83     StgClosure *q;
  84
  85     q = UNTAG_CLOSURE(p);
  86     ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
  87
  88     /* Is it a static closure? */
  89     if (!HEAP_ALLOCED(q)) {
  90         ASSERT(closure_STATIC(q));
  91     } else {
  92         ASSERT(!closure_STATIC(q));
  93     }
  94 }
  95
  96 // check an individual stack object
  97 StgOffset
  98 checkStackFrame( StgPtr c )
  99 {
 100     nat size;
 101     const StgRetInfoTable* info;
 102
 103     info = get_ret_itbl((StgClosure *)c);
 104
 105     /* All activation records have 'bitmap' style layout info. */
 106     switch (info->i.type) {
 107     case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
 108     {
 109         StgWord dyn;
 110         StgPtr p;
 111         StgRetDyn* r;
 112
 113         r = (StgRetDyn *)c;
 114         dyn = r->liveness;
 115
 116         p = (P_)(r->payload);
 117         checkSmallBitmap(p,RET_DYN_LIVENESS(r->liveness),RET_DYN_BITMAP_SIZE);
 118         p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
 119
 120         // skip over the non-pointers
 121         p += RET_DYN_NONPTRS(dyn);
 122
 123         // follow the ptr words
 124         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 125             checkClosureShallow((StgClosure *)*p);
 126             p++;
 127         }
 128
 129         return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
 130             RET_DYN_NONPTR_REGS_SIZE +
 131             RET_DYN_NONPTRS(dyn) + RET_DYN_PTRS(dyn);
 132     }
 133
 134     case UPDATE_FRAME:
 135       ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee));
 136     case ATOMICALLY_FRAME:
 137     case CATCH_RETRY_FRAME:
 138     case CATCH_STM_FRAME:
 139     case CATCH_FRAME:
 140       // small bitmap cases (<= 32 entries)
 141     case STOP_FRAME:
 142     case RET_SMALL:
 143         size = BITMAP_SIZE(info->i.layout.bitmap);
 144         checkSmallBitmap((StgPtr)c + 1,
 145                          BITMAP_BITS(info->i.layout.bitmap), size);
 146         return 1 + size;
 147
 148     case RET_BCO: {
 149         StgBCO *bco;
 150         nat size;
 151         bco = (StgBCO *)*(c+1);
 152         size = BCO_BITMAP_SIZE(bco);
 153         checkLargeBitmap((StgPtr)c + 2, BCO_BITMAP(bco), size);
 154         return 2 + size;
 155     }
 156
 157     case RET_BIG: // large bitmap (> 32 entries)
 158         size = GET_LARGE_BITMAP(&info->i)->size;
 159         checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
 160         return 1 + size;
 161
 162     case RET_FUN:
 163     {
 164         StgFunInfoTable *fun_info;
 165         StgRetFun *ret_fun;
 166
 167         ret_fun = (StgRetFun *)c;
 168         fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 169         size = ret_fun->size;
 170         switch (fun_info->f.fun_type) {
 171         case ARG_GEN:
 172             checkSmallBitmap((StgPtr)ret_fun->payload,
 173                              BITMAP_BITS(fun_info->f.b.bitmap), size);
 174             break;
 175         case ARG_GEN_BIG:
 176             checkLargeBitmap((StgPtr)ret_fun->payload,
 177                              GET_FUN_LARGE_BITMAP(fun_info), size);
 178             break;
 179         default:
 180             checkSmallBitmap((StgPtr)ret_fun->payload,
 181                              BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
 182                              size);
 183             break;
 184         }
 185         return sizeofW(StgRetFun) + size;
 186     }
 187
 188     default:
 189         barf("checkStackFrame: weird activation record found on stack (%p %d).",c,info->i.type);
 190     }
 191 }
 192
 193 // check sections of stack between update frames
 194 void
 195 checkStackChunk( StgPtr sp, StgPtr stack_end )
 196 {
 197     StgPtr p;
 198
 199     p = sp;
 200     while (p < stack_end) {
 201         p += checkStackFrame( p );
 202     }
 203     // ASSERT( p == stack_end ); -- HWL
 204 }
 205
 206 static void
 207 checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
 208 {
 209     StgClosure *fun;
 210     StgClosure *p;
 211     StgFunInfoTable *fun_info;
 212
 213     fun = UNTAG_CLOSURE(tagged_fun);
 214     ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
 215     fun_info = get_fun_itbl(fun);
 216
 217     p = (StgClosure *)payload;
 218     switch (fun_info->f.fun_type) {
 219     case ARG_GEN:
 220         checkSmallBitmap( (StgPtr)payload,
 221                           BITMAP_BITS(fun_info->f.b.bitmap), n_args );
 222         break;
 223     case ARG_GEN_BIG:
 224         checkLargeBitmap( (StgPtr)payload,
 225                           GET_FUN_LARGE_BITMAP(fun_info),
 226                           n_args );
 227         break;
 228     case ARG_BCO:
 229         checkLargeBitmap( (StgPtr)payload,
 230                           BCO_BITMAP(fun),
 231                           n_args );
 232         break;
 233     default:
 234         checkSmallBitmap( (StgPtr)payload,
 235                           BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
 236                           n_args );
 237         break;
 238     }
 239
 240     ASSERT(fun_info->f.arity > TAG_MASK ? GET_CLOSURE_TAG(tagged_fun) == 0
 241            : GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity);
 242 }
 243
 244
 245 StgOffset
 246 checkClosure( StgClosure* p )
 247 {
 248     const StgInfoTable *info;
 249
 250     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 251
 252     p = UNTAG_CLOSURE(p);
 253     /* Is it a static closure (i.e. in the data segment)? */
 254     if (!HEAP_ALLOCED(p)) {
 255         ASSERT(closure_STATIC(p));
 256     } else {
 257         ASSERT(!closure_STATIC(p));
 258     }
 259
 260     info = p->header.info;
 261
 262     if (IS_FORWARDING_PTR(info)) {
 263         barf("checkClosure: found EVACUATED closure %d", info->type);
 264     }
 265     info = INFO_PTR_TO_STRUCT(info);
 266
 267     switch (info->type) {
 268
 269     case MVAR_CLEAN:
 270     case MVAR_DIRTY:
 271       {
 272         StgMVar *mvar = (StgMVar *)p;
 273         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
 274         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
 275         ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
 276         return sizeofW(StgMVar);
 277       }
 278
 279     case THUNK:
 280     case THUNK_1_0:
 281     case THUNK_0_1:
 282     case THUNK_1_1:
 283     case THUNK_0_2:
 284     case THUNK_2_0:
 285       {
 286         nat i;
 287         for (i = 0; i < info->layout.payload.ptrs; i++) {
 288           ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i]));
 289         }
 290         return thunk_sizeW_fromITBL(info);
 291       }
 292
 293     case FUN:
 294     case FUN_1_0:
 295     case FUN_0_1:
 296     case FUN_1_1:
 297     case FUN_0_2:
 298     case FUN_2_0:
 299     case CONSTR:
 300     case CONSTR_1_0:
 301     case CONSTR_0_1:
 302     case CONSTR_1_1:
 303     case CONSTR_0_2:
 304     case CONSTR_2_0:
 305     case IND_PERM:
 306     case IND_OLDGEN:
 307     case IND_OLDGEN_PERM:
 308     case BLACKHOLE:
 309     case CAF_BLACKHOLE:
 310     case PRIM:
 311     case MUT_PRIM:
 312     case MUT_VAR_CLEAN:
 313     case MUT_VAR_DIRTY:
 314     case CONSTR_STATIC:
 315     case CONSTR_NOCAF_STATIC:
 316     case THUNK_STATIC:
 317     case FUN_STATIC:
 318         {
 319             nat i;
 320             for (i = 0; i < info->layout.payload.ptrs; i++) {
 321                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
 322             }
 323             return sizeW_fromITBL(info);
 324         }
 325
 326     case BCO: {
 327         StgBCO *bco = (StgBCO *)p;
 328         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs));
 329         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals));
 330         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs));
 331         return bco_sizeW(bco);
 332     }
 333
 334     case IND_STATIC: /* (1, 0) closure */
 335       ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgIndStatic*)p)->indirectee));
 336       return sizeW_fromITBL(info);
 337
 338     case WEAK:
 339       /* deal with these specially - the info table isn't
 340        * representative of the actual layout.
 341        */
 342       { StgWeak *w = (StgWeak *)p;
 343         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->key));
 344         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->value));
 345         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->finalizer));
 346         if (w->link) {
 347           ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->link));
 348         }
 349         return sizeW_fromITBL(info);
 350       }
 351
 352     case THUNK_SELECTOR:
 353             ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee));
 354             return THUNK_SELECTOR_sizeW();
 355
 356     case IND:
 357         {
 358             /* we don't expect to see any of these after GC
 359              * but they might appear during execution
 360              */
 361             StgInd *ind = (StgInd *)p;
 362             ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
 363             return sizeofW(StgInd);
 364         }
 365
 366     case RET_BCO:
 367     case RET_SMALL:
 368     case RET_BIG:
 369     case RET_DYN:
 370     case UPDATE_FRAME:
 371     case STOP_FRAME:
 372     case CATCH_FRAME:
 373     case ATOMICALLY_FRAME:
 374     case CATCH_RETRY_FRAME:
 375     case CATCH_STM_FRAME:
 376             barf("checkClosure: stack frame");
 377
 378     case AP:
 379     {
 380         StgAP* ap = (StgAP *)p;
 381         checkPAP (ap->fun, ap->payload, ap->n_args);
 382         return ap_sizeW(ap);
 383     }
 384
 385     case PAP:
 386     {
 387         StgPAP* pap = (StgPAP *)p;
 388         checkPAP (pap->fun, pap->payload, pap->n_args);
 389         return pap_sizeW(pap);
 390     }
 391
 392     case AP_STACK:
 393     {
 394         StgAP_STACK *ap = (StgAP_STACK *)p;
 395         ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
 396         checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 397         return ap_stack_sizeW(ap);
 398     }
 399
 400     case ARR_WORDS:
 401             return arr_words_sizeW((StgArrWords *)p);
 402
 403     case MUT_ARR_PTRS_CLEAN:
 404     case MUT_ARR_PTRS_DIRTY:
 405     case MUT_ARR_PTRS_FROZEN:
 406     case MUT_ARR_PTRS_FROZEN0:
 407         {
 408             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 409             nat i;
 410             for (i = 0; i < a->ptrs; i++) {
 411                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
 412             }
 413             return mut_arr_ptrs_sizeW(a);
 414         }
 415
 416     case TSO:
 417         checkTSO((StgTSO *)p);
 418         return tso_sizeW((StgTSO *)p);
 419
 420     case TREC_CHUNK:
 421       {
 422         nat i;
 423         StgTRecChunk *tc = (StgTRecChunk *)p;
 424         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
 425         for (i = 0; i < tc -> next_entry_idx; i ++) {
 426           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
 427           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
 428           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
 429         }
 430         return sizeofW(StgTRecChunk);
 431       }
 432
 433     default:
 434             barf("checkClosure (closure type %d)", info->type);
 435     }
 436 }
 437
 438
 439 /* -----------------------------------------------------------------------------
 440    Check Heap Sanity
 441
 442    After garbage collection, the live heap is in a state where we can
 443    run through and check that all the pointers point to the right
 444    place.  This function starts at a given position and sanity-checks
 445    all the objects in the remainder of the chain.
 446    -------------------------------------------------------------------------- */
 447
 448 void
 449 checkHeap(bdescr *bd)
 450 {
 451     StgPtr p;
 452
 453 #if defined(THREADED_RTS)
 454     // heap sanity checking doesn't work with SMP, because we can't
 455     // zero the slop (see Updates.h).
 456     return;
 457 #endif
 458
 459     for (; bd != NULL; bd = bd->link) {
 460         p = bd->start;
 461         while (p < bd->free) {
 462             nat size = checkClosure((StgClosure *)p);
 463             /* This is the smallest size of closure that can live in the heap */
 464             ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 465             p += size;
 466
 467             /* skip over slop */
 468             while (p < bd->free &&
 469                    (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; }
 470         }
 471     }
 472 }
 473
 474 void
 475 checkHeapChunk(StgPtr start, StgPtr end)
 476 {
 477   StgPtr p;
 478   nat size;
 479
 480   for (p=start; p<end; p+=size) {
 481     ASSERT(LOOKS_LIKE_INFO_PTR(*p));
 482     size = checkClosure((StgClosure *)p);
 483     /* This is the smallest size of closure that can live in the heap. */
 484     ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 485   }
 486 }
 487
 488 void
 489 checkLargeObjects(bdescr *bd)
 490 {
 491   while (bd != NULL) {
 492     if (!(bd->flags & BF_PINNED)) {
 493       checkClosure((StgClosure *)bd->start);
 494     }
 495     bd = bd->link;
 496   }
 497 }
 498
 499 void
 500 checkTSO(StgTSO *tso)
 501 {
 502     StgPtr sp = tso->sp;
 503     StgPtr stack = tso->stack;
 504     StgOffset stack_size = tso->stack_size;
 505     StgPtr stack_end = stack + stack_size;
 506
 507     if (tso->what_next == ThreadRelocated) {
 508       checkTSO(tso->_link);
 509       return;
 510     }
 511
 512     if (tso->what_next == ThreadKilled) {
 513       /* The garbage collector doesn't bother following any pointers
 514        * from dead threads, so don't check sanity here.
 515        */
 516       return;
 517     }
 518
 519     ASSERT(stack <= sp && sp < stack_end);
 520
 521     checkStackChunk(sp, stack_end);
 522 }
 523
 524 /*
 525    Check that all TSOs have been evacuated.
 526    Optionally also check the sanity of the TSOs.
 527 */
 528 void
 529 checkGlobalTSOList (rtsBool checkTSOs)
 530 {
 531   StgTSO *tso;
 532   nat g;
 533
 534   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 535       for (tso=generations[g].threads; tso != END_TSO_QUEUE;
 536            tso = tso->global_link) {
 537           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 538           ASSERT(get_itbl(tso)->type == TSO);
 539           if (checkTSOs)
 540               checkTSO(tso);
 541
 542           while (tso->what_next == ThreadRelocated) {
 543               tso = tso->_link;
 544           }
 545
 546           // If this TSO is dirty and in an old generation, it better
 547           // be on the mutable list.
 548           if (tso->dirty || (tso->flags & TSO_LINK_DIRTY)) {
 549               ASSERT(Bdescr((P_)tso)->gen_no == 0 || (tso->flags & TSO_MARKED));
 550               tso->flags &= ~TSO_MARKED;
 551           }
 552       }
 553   }
 554 }
 555
 556 /* -----------------------------------------------------------------------------
 557    Check mutable list sanity.
 558    -------------------------------------------------------------------------- */
 559
 560 void
 561 checkMutableList( bdescr *mut_bd, nat gen )
 562 {
 563     bdescr *bd;
 564     StgPtr q;
 565     StgClosure *p;
 566
 567     for (bd = mut_bd; bd != NULL; bd = bd->link) {
 568         for (q = bd->start; q < bd->free; q++) {
 569             p = (StgClosure *)*q;
 570             ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 571             if (get_itbl(p)->type == TSO) {
 572                 ((StgTSO *)p)->flags |= TSO_MARKED;
 573             }
 574         }
 575     }
 576 }
 577
 578 void
 579 checkMutableLists (rtsBool checkTSOs)
 580 {
 581     nat g, i;
 582
 583     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 584         checkMutableList(generations[g].mut_list, g);
 585         for (i = 0; i < n_capabilities; i++) {
 586             checkMutableList(capabilities[i].mut_lists[g], g);
 587         }
 588     }
 589     checkGlobalTSOList(checkTSOs);
 590 }
 591
 592 /*
 593   Check the static objects list.
 594 */
 595 void
 596 checkStaticObjects ( StgClosure* static_objects )
 597 {
 598   StgClosure *p = static_objects;
 599   StgInfoTable *info;
 600
 601   while (p != END_OF_STATIC_LIST) {
 602     checkClosure(p);
 603     info = get_itbl(p);
 604     switch (info->type) {
 605     case IND_STATIC:
 606       {
 607         StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
 608
 609         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 610         ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
 611         p = *IND_STATIC_LINK((StgClosure *)p);
 612         break;
 613       }
 614
 615     case THUNK_STATIC:
 616       p = *THUNK_STATIC_LINK((StgClosure *)p);
 617       break;
 618
 619     case FUN_STATIC:
 620       p = *FUN_STATIC_LINK((StgClosure *)p);
 621       break;
 622
 623     case CONSTR_STATIC:
 624       p = *STATIC_LINK(info,(StgClosure *)p);
 625       break;
 626
 627     default:
 628       barf("checkStaticObjetcs: strange closure %p (%s)",
 629            p, info_type(p));
 630     }
 631   }
 632 }
 633
 634 /* Nursery sanity check */
 635 void
 636 checkNurserySanity (nursery *nursery)
 637 {
 638     bdescr *bd, *prev;
 639     nat blocks = 0;
 640
 641     prev = NULL;
 642     for (bd = nursery->blocks; bd != NULL; bd = bd->link) {
 643         ASSERT(bd->u.back == prev);
 644         prev = bd;
 645         blocks += bd->blocks;
 646     }
 647
 648     ASSERT(blocks == nursery->n_blocks);
 649 }
 650
 651
 652 /* Full heap sanity check. */
 653 void
 654 checkSanity( rtsBool check_heap )
 655 {
 656     nat g, n;
 657
 658     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 659         ASSERT(countBlocks(generations[g].blocks)
 660                == generations[g].n_blocks);
 661         ASSERT(countBlocks(generations[g].large_objects)
 662                    == generations[g].n_large_blocks);
 663         if (check_heap) {
 664             checkHeap(generations[g].blocks);
 665         }
 666         checkLargeObjects(generations[g].large_objects);
 667     }
 668
 669     for (n = 0; n < n_capabilities; n++) {
 670         checkNurserySanity(&nurseries[n]);
 671     }
 672
 673     checkFreeListSanity();
 674
 675 #if defined(THREADED_RTS)
 676     // always check the stacks in threaded mode, because checkHeap()
 677     // does nothing in this case.
 678     checkMutableLists(rtsTrue);
 679 #else
 680     if (check_heap) {
 681         checkMutableLists(rtsFalse);
 682     } else {
 683         checkMutableLists(rtsTrue);
 684     }
 685 #endif
 686 }
 687
 688 // If memInventory() calculates that we have a memory leak, this
 689 // function will try to find the block(s) that are leaking by marking
 690 // all the ones that we know about, and search through memory to find
 691 // blocks that are not marked.  In the debugger this can help to give
 692 // us a clue about what kind of block leaked.  In the future we might
 693 // annotate blocks with their allocation site to give more helpful
 694 // info.
 695 static void
 696 findMemoryLeak (void)
 697 {
 698   nat g, i;
 699   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 700       for (i = 0; i < n_capabilities; i++) {
 701           markBlocks(capabilities[i].mut_lists[g]);
 702       }
 703       markBlocks(generations[g].mut_list);
 704       markBlocks(generations[g].blocks);
 705       markBlocks(generations[g].large_objects);
 706   }
 707
 708   for (i = 0; i < n_capabilities; i++) {
 709       markBlocks(nurseries[i].blocks);
 710   }
 711
 712 #ifdef PROFILING
 713   // TODO:
 714   // if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
 715   //    markRetainerBlocks();
 716   // }
 717 #endif
 718
 719   // count the blocks allocated by the arena allocator
 720   // TODO:
 721   // markArenaBlocks();
 722
 723   // count the blocks containing executable memory
 724   markBlocks(exec_block);
 725
 726   reportUnmarkedBlocks();
 727 }
 728
 729
 730 /* -----------------------------------------------------------------------------
 731    Memory leak detection
 732
 733    memInventory() checks for memory leaks by counting up all the
 734    blocks we know about and comparing that to the number of blocks
 735    allegedly floating around in the system.
 736    -------------------------------------------------------------------------- */
 737
 738 // Useful for finding partially full blocks in gdb
 739 void findSlop(bdescr *bd);
 740 void findSlop(bdescr *bd)
 741 {
 742     lnat slop;
 743
 744     for (; bd != NULL; bd = bd->link) {
 745         slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start);
 746         if (slop > (1024/sizeof(W_))) {
 747             debugBelch("block at %p (bdescr %p) has %ldKB slop\n",
 748                        bd->start, bd, slop / (1024/sizeof(W_)));
 749         }
 750     }
 751 }
 752
 753 static lnat
 754 genBlocks (generation *gen)
 755 {
 756     ASSERT(countBlocks(gen->blocks) == gen->n_blocks);
 757     ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks);
 758     return gen->n_blocks + gen->n_old_blocks +
 759             countAllocdBlocks(gen->large_objects);
 760 }
 761
 762 void
 763 memInventory (rtsBool show)
 764 {
 765   nat g, i;
 766   lnat gen_blocks[RtsFlags.GcFlags.generations];
 767   lnat nursery_blocks, retainer_blocks,
 768        arena_blocks, exec_blocks;
 769   lnat live_blocks = 0, free_blocks = 0;
 770   rtsBool leak;
 771
 772   // count the blocks we current have
 773
 774   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 775       gen_blocks[g] = 0;
 776       for (i = 0; i < n_capabilities; i++) {
 777           gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
 778       }
 779       gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
 780       gen_blocks[g] += genBlocks(&generations[g]);
 781   }
 782
 783   nursery_blocks = 0;
 784   for (i = 0; i < n_capabilities; i++) {
 785       ASSERT(countBlocks(nurseries[i].blocks) == nurseries[i].n_blocks);
 786       nursery_blocks += nurseries[i].n_blocks;
 787   }
 788
 789   retainer_blocks = 0;
 790 #ifdef PROFILING
 791   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
 792       retainer_blocks = retainerStackBlocks();
 793   }
 794 #endif
 795
 796   // count the blocks allocated by the arena allocator
 797   arena_blocks = arenaBlocks();
 798
 799   // count the blocks containing executable memory
 800   exec_blocks = countAllocdBlocks(exec_block);
 801
 802   /* count the blocks on the free list */
 803   free_blocks = countFreeList();
 804
 805   live_blocks = 0;
 806   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 807       live_blocks += gen_blocks[g];
 808   }
 809   live_blocks += nursery_blocks +
 810                + retainer_blocks + arena_blocks + exec_blocks;
 811
 812 #define MB(n) (((n) * BLOCK_SIZE_W) / ((1024*1024)/sizeof(W_)))
 813
 814   leak = live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK;
 815
 816   if (show || leak)
 817   {
 818       if (leak) {
 819           debugBelch("Memory leak detected:\n");
 820       } else {
 821           debugBelch("Memory inventory:\n");
 822       }
 823       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 824           debugBelch("  gen %d blocks : %5lu blocks (%lu MB)\n", g,
 825                      gen_blocks[g], MB(gen_blocks[g]));
 826       }
 827       debugBelch("  nursery      : %5lu blocks (%lu MB)\n",
 828                  nursery_blocks, MB(nursery_blocks));
 829       debugBelch("  retainer     : %5lu blocks (%lu MB)\n",
 830                  retainer_blocks, MB(retainer_blocks));
 831       debugBelch("  arena blocks : %5lu blocks (%lu MB)\n",
 832                  arena_blocks, MB(arena_blocks));
 833       debugBelch("  exec         : %5lu blocks (%lu MB)\n",
 834                  exec_blocks, MB(exec_blocks));
 835       debugBelch("  free         : %5lu blocks (%lu MB)\n",
 836                  free_blocks, MB(free_blocks));
 837       debugBelch("  total        : %5lu blocks (%lu MB)\n",
 838                  live_blocks + free_blocks, MB(live_blocks+free_blocks));
 839       if (leak) {
 840           debugBelch("\n  in system    : %5lu blocks (%lu MB)\n",
 841                      mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated);
 842       }
 843   }
 844
 845   if (leak) {
 846       debugBelch("\n");
 847       findMemoryLeak();
 848   }
 849   ASSERT(n_alloc_blocks == live_blocks);
 850   ASSERT(!leak);
 851 }
 852
 853
 854 #endif /* DEBUG */