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 PRIM:
 310     case MUT_PRIM:
 311     case MUT_VAR_CLEAN:
 312     case MUT_VAR_DIRTY:
 313     case CONSTR_STATIC:
 314     case CONSTR_NOCAF_STATIC:
 315     case THUNK_STATIC:
 316     case FUN_STATIC:
 317         {
 318             nat i;
 319             for (i = 0; i < info->layout.payload.ptrs; i++) {
 320                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
 321             }
 322             return sizeW_fromITBL(info);
 323         }
 324
 325     case BLOCKING_QUEUE:
 326     {
 327         StgBlockingQueue *bq = (StgBlockingQueue *)p;
 328
 329         // NO: the BH might have been updated now
 330         // ASSERT(get_itbl(bq->bh)->type == BLACKHOLE);
 331         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bq->bh));
 332
 333         ASSERT(get_itbl(bq->owner)->type == TSO);
 334         ASSERT(bq->queue == END_TSO_QUEUE || get_itbl(bq->queue)->type == TSO);
 335         ASSERT(bq->link == (StgBlockingQueue*)END_TSO_QUEUE ||
 336                get_itbl(bq->link)->type == IND ||
 337                get_itbl(bq->link)->type == BLOCKING_QUEUE);
 338
 339         return sizeofW(StgBlockingQueue);
 340     }
 341
 342     case BCO: {
 343         StgBCO *bco = (StgBCO *)p;
 344         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs));
 345         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals));
 346         ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs));
 347         return bco_sizeW(bco);
 348     }
 349
 350     case IND_STATIC: /* (1, 0) closure */
 351       ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgIndStatic*)p)->indirectee));
 352       return sizeW_fromITBL(info);
 353
 354     case WEAK:
 355       /* deal with these specially - the info table isn't
 356        * representative of the actual layout.
 357        */
 358       { StgWeak *w = (StgWeak *)p;
 359         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->key));
 360         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->value));
 361         ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->finalizer));
 362         if (w->link) {
 363           ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->link));
 364         }
 365         return sizeW_fromITBL(info);
 366       }
 367
 368     case THUNK_SELECTOR:
 369             ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee));
 370             return THUNK_SELECTOR_sizeW();
 371
 372     case IND:
 373         {
 374             /* we don't expect to see any of these after GC
 375              * but they might appear during execution
 376              */
 377             StgInd *ind = (StgInd *)p;
 378             ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
 379             return sizeofW(StgInd);
 380         }
 381
 382     case RET_BCO:
 383     case RET_SMALL:
 384     case RET_BIG:
 385     case RET_DYN:
 386     case UPDATE_FRAME:
 387     case STOP_FRAME:
 388     case CATCH_FRAME:
 389     case ATOMICALLY_FRAME:
 390     case CATCH_RETRY_FRAME:
 391     case CATCH_STM_FRAME:
 392             barf("checkClosure: stack frame");
 393
 394     case AP:
 395     {
 396         StgAP* ap = (StgAP *)p;
 397         checkPAP (ap->fun, ap->payload, ap->n_args);
 398         return ap_sizeW(ap);
 399     }
 400
 401     case PAP:
 402     {
 403         StgPAP* pap = (StgPAP *)p;
 404         checkPAP (pap->fun, pap->payload, pap->n_args);
 405         return pap_sizeW(pap);
 406     }
 407
 408     case AP_STACK:
 409     {
 410         StgAP_STACK *ap = (StgAP_STACK *)p;
 411         ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
 412         checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
 413         return ap_stack_sizeW(ap);
 414     }
 415
 416     case ARR_WORDS:
 417             return arr_words_sizeW((StgArrWords *)p);
 418
 419     case MUT_ARR_PTRS_CLEAN:
 420     case MUT_ARR_PTRS_DIRTY:
 421     case MUT_ARR_PTRS_FROZEN:
 422     case MUT_ARR_PTRS_FROZEN0:
 423         {
 424             StgMutArrPtrs* a = (StgMutArrPtrs *)p;
 425             nat i;
 426             for (i = 0; i < a->ptrs; i++) {
 427                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
 428             }
 429             return mut_arr_ptrs_sizeW(a);
 430         }
 431
 432     case TSO:
 433         checkTSO((StgTSO *)p);
 434         return tso_sizeW((StgTSO *)p);
 435
 436     case TREC_CHUNK:
 437       {
 438         nat i;
 439         StgTRecChunk *tc = (StgTRecChunk *)p;
 440         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->prev_chunk));
 441         for (i = 0; i < tc -> next_entry_idx; i ++) {
 442           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].tvar));
 443           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].expected_value));
 444           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tc->entries[i].new_value));
 445         }
 446         return sizeofW(StgTRecChunk);
 447       }
 448
 449     default:
 450             barf("checkClosure (closure type %d)", info->type);
 451     }
 452 }
 453
 454
 455 /* -----------------------------------------------------------------------------
 456    Check Heap Sanity
 457
 458    After garbage collection, the live heap is in a state where we can
 459    run through and check that all the pointers point to the right
 460    place.  This function starts at a given position and sanity-checks
 461    all the objects in the remainder of the chain.
 462    -------------------------------------------------------------------------- */
 463
 464 void
 465 checkHeap(bdescr *bd)
 466 {
 467     StgPtr p;
 468
 469 #if defined(THREADED_RTS)
 470     // heap sanity checking doesn't work with SMP, because we can't
 471     // zero the slop (see Updates.h).
 472     return;
 473 #endif
 474
 475     for (; bd != NULL; bd = bd->link) {
 476         p = bd->start;
 477         while (p < bd->free) {
 478             nat size = checkClosure((StgClosure *)p);
 479             /* This is the smallest size of closure that can live in the heap */
 480             ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 481             p += size;
 482
 483             /* skip over slop */
 484             while (p < bd->free &&
 485                    (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR(*p))) { p++; }
 486         }
 487     }
 488 }
 489
 490 void
 491 checkHeapChunk(StgPtr start, StgPtr end)
 492 {
 493   StgPtr p;
 494   nat size;
 495
 496   for (p=start; p<end; p+=size) {
 497     ASSERT(LOOKS_LIKE_INFO_PTR(*p));
 498     size = checkClosure((StgClosure *)p);
 499     /* This is the smallest size of closure that can live in the heap. */
 500     ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
 501   }
 502 }
 503
 504 void
 505 checkLargeObjects(bdescr *bd)
 506 {
 507   while (bd != NULL) {
 508     if (!(bd->flags & BF_PINNED)) {
 509       checkClosure((StgClosure *)bd->start);
 510     }
 511     bd = bd->link;
 512   }
 513 }
 514
 515 void
 516 checkTSO(StgTSO *tso)
 517 {
 518     StgPtr sp = tso->sp;
 519     StgPtr stack = tso->stack;
 520     StgOffset stack_size = tso->stack_size;
 521     StgPtr stack_end = stack + stack_size;
 522
 523     if (tso->what_next == ThreadRelocated) {
 524       checkTSO(tso->_link);
 525       return;
 526     }
 527
 528     if (tso->what_next == ThreadKilled) {
 529       /* The garbage collector doesn't bother following any pointers
 530        * from dead threads, so don't check sanity here.
 531        */
 532       return;
 533     }
 534
 535     ASSERT(tso->_link == END_TSO_QUEUE || get_itbl(tso->_link)->type == TSO);
 536     ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure));
 537     ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq));
 538     ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions));
 539
 540     ASSERT(stack <= sp && sp < stack_end);
 541
 542     checkStackChunk(sp, stack_end);
 543 }
 544
 545 /*
 546    Check that all TSOs have been evacuated.
 547    Optionally also check the sanity of the TSOs.
 548 */
 549 void
 550 checkGlobalTSOList (rtsBool checkTSOs)
 551 {
 552   StgTSO *tso;
 553   nat g;
 554
 555   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 556       for (tso=generations[g].threads; tso != END_TSO_QUEUE;
 557            tso = tso->global_link) {
 558           ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
 559           ASSERT(get_itbl(tso)->type == TSO);
 560           if (checkTSOs)
 561               checkTSO(tso);
 562
 563           tso = deRefTSO(tso);
 564
 565           // If this TSO is dirty and in an old generation, it better
 566           // be on the mutable list.
 567           if (tso->dirty || (tso->flags & TSO_LINK_DIRTY)) {
 568               ASSERT(Bdescr((P_)tso)->gen_no == 0 || (tso->flags & TSO_MARKED));
 569               tso->flags &= ~TSO_MARKED;
 570           }
 571       }
 572   }
 573 }
 574
 575 /* -----------------------------------------------------------------------------
 576    Check mutable list sanity.
 577    -------------------------------------------------------------------------- */
 578
 579 void
 580 checkMutableList( bdescr *mut_bd, nat gen )
 581 {
 582     bdescr *bd;
 583     StgPtr q;
 584     StgClosure *p;
 585
 586     for (bd = mut_bd; bd != NULL; bd = bd->link) {
 587         for (q = bd->start; q < bd->free; q++) {
 588             p = (StgClosure *)*q;
 589             ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen);
 590             if (get_itbl(p)->type == TSO) {
 591                 ((StgTSO *)p)->flags |= TSO_MARKED;
 592             }
 593         }
 594     }
 595 }
 596
 597 void
 598 checkMutableLists (rtsBool checkTSOs)
 599 {
 600     nat g, i;
 601
 602     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 603         checkMutableList(generations[g].mut_list, g);
 604         for (i = 0; i < n_capabilities; i++) {
 605             checkMutableList(capabilities[i].mut_lists[g], g);
 606         }
 607     }
 608     checkGlobalTSOList(checkTSOs);
 609 }
 610
 611 /*
 612   Check the static objects list.
 613 */
 614 void
 615 checkStaticObjects ( StgClosure* static_objects )
 616 {
 617   StgClosure *p = static_objects;
 618   StgInfoTable *info;
 619
 620   while (p != END_OF_STATIC_LIST) {
 621     checkClosure(p);
 622     info = get_itbl(p);
 623     switch (info->type) {
 624     case IND_STATIC:
 625       {
 626         StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
 627
 628         ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
 629         ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)indirectee->header.info));
 630         p = *IND_STATIC_LINK((StgClosure *)p);
 631         break;
 632       }
 633
 634     case THUNK_STATIC:
 635       p = *THUNK_STATIC_LINK((StgClosure *)p);
 636       break;
 637
 638     case FUN_STATIC:
 639       p = *FUN_STATIC_LINK((StgClosure *)p);
 640       break;
 641
 642     case CONSTR_STATIC:
 643       p = *STATIC_LINK(info,(StgClosure *)p);
 644       break;
 645
 646     default:
 647       barf("checkStaticObjetcs: strange closure %p (%s)",
 648            p, info_type(p));
 649     }
 650   }
 651 }
 652
 653 /* Nursery sanity check */
 654 void
 655 checkNurserySanity (nursery *nursery)
 656 {
 657     bdescr *bd, *prev;
 658     nat blocks = 0;
 659
 660     prev = NULL;
 661     for (bd = nursery->blocks; bd != NULL; bd = bd->link) {
 662         ASSERT(bd->u.back == prev);
 663         prev = bd;
 664         blocks += bd->blocks;
 665     }
 666
 667     ASSERT(blocks == nursery->n_blocks);
 668 }
 669
 670
 671 /* Full heap sanity check. */
 672 void
 673 checkSanity( rtsBool check_heap )
 674 {
 675     nat g, n;
 676
 677     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 678         ASSERT(countBlocks(generations[g].blocks)
 679                == generations[g].n_blocks);
 680         ASSERT(countBlocks(generations[g].large_objects)
 681                    == generations[g].n_large_blocks);
 682         if (check_heap) {
 683             checkHeap(generations[g].blocks);
 684         }
 685         checkLargeObjects(generations[g].large_objects);
 686     }
 687
 688     for (n = 0; n < n_capabilities; n++) {
 689         checkNurserySanity(&nurseries[n]);
 690     }
 691
 692     checkFreeListSanity();
 693
 694 #if defined(THREADED_RTS)
 695     // always check the stacks in threaded mode, because checkHeap()
 696     // does nothing in this case.
 697     checkMutableLists(rtsTrue);
 698 #else
 699     if (check_heap) {
 700         checkMutableLists(rtsFalse);
 701     } else {
 702         checkMutableLists(rtsTrue);
 703     }
 704 #endif
 705 }
 706
 707 // If memInventory() calculates that we have a memory leak, this
 708 // function will try to find the block(s) that are leaking by marking
 709 // all the ones that we know about, and search through memory to find
 710 // blocks that are not marked.  In the debugger this can help to give
 711 // us a clue about what kind of block leaked.  In the future we might
 712 // annotate blocks with their allocation site to give more helpful
 713 // info.
 714 static void
 715 findMemoryLeak (void)
 716 {
 717   nat g, i;
 718   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 719       for (i = 0; i < n_capabilities; i++) {
 720           markBlocks(capabilities[i].mut_lists[g]);
 721       }
 722       markBlocks(generations[g].mut_list);
 723       markBlocks(generations[g].blocks);
 724       markBlocks(generations[g].large_objects);
 725   }
 726
 727   for (i = 0; i < n_capabilities; i++) {
 728       markBlocks(nurseries[i].blocks);
 729   }
 730
 731 #ifdef PROFILING
 732   // TODO:
 733   // if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
 734   //    markRetainerBlocks();
 735   // }
 736 #endif
 737
 738   // count the blocks allocated by the arena allocator
 739   // TODO:
 740   // markArenaBlocks();
 741
 742   // count the blocks containing executable memory
 743   markBlocks(exec_block);
 744
 745   reportUnmarkedBlocks();
 746 }
 747
 748
 749 /* -----------------------------------------------------------------------------
 750    Memory leak detection
 751
 752    memInventory() checks for memory leaks by counting up all the
 753    blocks we know about and comparing that to the number of blocks
 754    allegedly floating around in the system.
 755    -------------------------------------------------------------------------- */
 756
 757 // Useful for finding partially full blocks in gdb
 758 void findSlop(bdescr *bd);
 759 void findSlop(bdescr *bd)
 760 {
 761     lnat slop;
 762
 763     for (; bd != NULL; bd = bd->link) {
 764         slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start);
 765         if (slop > (1024/sizeof(W_))) {
 766             debugBelch("block at %p (bdescr %p) has %ldKB slop\n",
 767                        bd->start, bd, slop / (1024/sizeof(W_)));
 768         }
 769     }
 770 }
 771
 772 static lnat
 773 genBlocks (generation *gen)
 774 {
 775     ASSERT(countBlocks(gen->blocks) == gen->n_blocks);
 776     ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks);
 777     return gen->n_blocks + gen->n_old_blocks +
 778             countAllocdBlocks(gen->large_objects);
 779 }
 780
 781 void
 782 memInventory (rtsBool show)
 783 {
 784   nat g, i;
 785   lnat gen_blocks[RtsFlags.GcFlags.generations];
 786   lnat nursery_blocks, retainer_blocks,
 787        arena_blocks, exec_blocks;
 788   lnat live_blocks = 0, free_blocks = 0;
 789   rtsBool leak;
 790
 791   // count the blocks we current have
 792
 793   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 794       gen_blocks[g] = 0;
 795       for (i = 0; i < n_capabilities; i++) {
 796           gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
 797       }
 798       gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
 799       gen_blocks[g] += genBlocks(&generations[g]);
 800   }
 801
 802   nursery_blocks = 0;
 803   for (i = 0; i < n_capabilities; i++) {
 804       ASSERT(countBlocks(nurseries[i].blocks) == nurseries[i].n_blocks);
 805       nursery_blocks += nurseries[i].n_blocks;
 806   }
 807
 808   retainer_blocks = 0;
 809 #ifdef PROFILING
 810   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
 811       retainer_blocks = retainerStackBlocks();
 812   }
 813 #endif
 814
 815   // count the blocks allocated by the arena allocator
 816   arena_blocks = arenaBlocks();
 817
 818   // count the blocks containing executable memory
 819   exec_blocks = countAllocdBlocks(exec_block);
 820
 821   /* count the blocks on the free list */
 822   free_blocks = countFreeList();
 823
 824   live_blocks = 0;
 825   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 826       live_blocks += gen_blocks[g];
 827   }
 828   live_blocks += nursery_blocks +
 829                + retainer_blocks + arena_blocks + exec_blocks;
 830
 831 #define MB(n) (((n) * BLOCK_SIZE_W) / ((1024*1024)/sizeof(W_)))
 832
 833   leak = live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK;
 834
 835   if (show || leak)
 836   {
 837       if (leak) {
 838           debugBelch("Memory leak detected:\n");
 839       } else {
 840           debugBelch("Memory inventory:\n");
 841       }
 842       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 843           debugBelch("  gen %d blocks : %5lu blocks (%lu MB)\n", g,
 844                      gen_blocks[g], MB(gen_blocks[g]));
 845       }
 846       debugBelch("  nursery      : %5lu blocks (%lu MB)\n",
 847                  nursery_blocks, MB(nursery_blocks));
 848       debugBelch("  retainer     : %5lu blocks (%lu MB)\n",
 849                  retainer_blocks, MB(retainer_blocks));
 850       debugBelch("  arena blocks : %5lu blocks (%lu MB)\n",
 851                  arena_blocks, MB(arena_blocks));
 852       debugBelch("  exec         : %5lu blocks (%lu MB)\n",
 853                  exec_blocks, MB(exec_blocks));
 854       debugBelch("  free         : %5lu blocks (%lu MB)\n",
 855                  free_blocks, MB(free_blocks));
 856       debugBelch("  total        : %5lu blocks (%lu MB)\n",
 857                  live_blocks + free_blocks, MB(live_blocks+free_blocks));
 858       if (leak) {
 859           debugBelch("\n  in system    : %5lu blocks (%lu MB)\n",
 860                      mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated);
 861       }
 862   }
 863
 864   if (leak) {
 865       debugBelch("\n");
 866       findMemoryLeak();
 867   }
 868   ASSERT(n_alloc_blocks == live_blocks);
 869   ASSERT(!leak);
 870 }
 871
 872
 873 #endif /* DEBUG */