ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.10 1999/02/11 17:40:28 simonm Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Sanity checking code for the heap and stack.
   7  *
   8  * Used when debugging: check that the stack looks reasonable.
   9  *
  10  *    - All things that are supposed to be pointers look like pointers.
  11  *
  12  *    - Objects in text space are marked as static closures, those
  13  *      in the heap are dynamic.
  14  *
  15  * ---------------------------------------------------------------------------*/
  16
  17 #include "Rts.h"
  18
  19 #ifdef DEBUG
  20
  21 #include "RtsFlags.h"
  22 #include "RtsUtils.h"
  23 #include "BlockAlloc.h"
  24 #include "Sanity.h"
  25
  26 #define LOOKS_LIKE_PTR(r) \
  27   (IS_DATA_PTR(r) || ((IS_USER_PTR(r) && Bdescr((P_)r)->free != (void *)-1)))
  28
  29 /* -----------------------------------------------------------------------------
  30    Check stack sanity
  31    -------------------------------------------------------------------------- */
  32
  33 StgOffset checkStackClosure( StgClosure* c );
  34
  35 StgOffset checkStackObject( StgPtr sp );
  36
  37 void      checkStackChunk( StgPtr sp, StgPtr stack_end );
  38
  39 static StgOffset checkSmallBitmap(  StgPtr payload, StgNat32 bitmap );
  40
  41 static StgOffset checkLargeBitmap( StgPtr payload,
  42                                    StgLargeBitmap* large_bitmap );
  43
  44 void checkClosureShallow( StgClosure* p );
  45
  46 static StgOffset
  47 checkSmallBitmap( StgPtr payload, StgNat32 bitmap )
  48 {
  49     StgOffset i;
  50
  51     i = 0;
  52     for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  53         if ((bitmap & 1) == 0) {
  54             checkClosure(stgCast(StgClosure*,payload[i]));
  55         }
  56     }
  57     return i;
  58 }
  59
  60
  61 static StgOffset
  62 checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
  63 {
  64     StgNat32 bmp;
  65     StgOffset i;
  66
  67     i = 0;
  68     for (bmp=0; bmp<large_bitmap->size; bmp++) {
  69         StgNat32 bitmap = large_bitmap->bitmap[bmp];
  70         for(; bitmap != 0; ++i, bitmap >>= 1 ) {
  71             if ((bitmap & 1) == 0) {
  72                 checkClosure(stgCast(StgClosure*,payload[i]));
  73             }
  74         }
  75     }
  76     return i;
  77 }
  78
  79 StgOffset
  80 checkStackClosure( StgClosure* c )
  81 {
  82     const StgInfoTable* info = get_itbl(c);
  83
  84     /* All activation records have 'bitmap' style layout info. */
  85     switch (info->type) {
  86     case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
  87         {
  88             StgRetDyn* r = stgCast(StgRetDyn*,c);
  89             return sizeofW(StgRetDyn) +
  90                    checkSmallBitmap(r->payload,r->liveness);
  91         }
  92     case RET_BCO: /* small bitmap (<= 32 entries) */
  93     case RET_SMALL:
  94     case RET_VEC_SMALL:
  95     case UPDATE_FRAME:
  96     case CATCH_FRAME:
  97     case STOP_FRAME:
  98     case SEQ_FRAME:
  99             return sizeofW(StgClosure) +
 100                    checkSmallBitmap((StgPtr)c->payload,info->layout.bitmap);
 101     case RET_BIG: /* large bitmap (> 32 entries) */
 102     case RET_VEC_BIG:
 103             return sizeofW(StgClosure) +
 104                    checkLargeBitmap((StgPtr)c->payload,
 105                                     info->layout.large_bitmap);
 106     case FUN:
 107     case FUN_STATIC: /* probably a slow-entry point return address: */
 108             return 1;
 109     default:
 110             /* if none of the above, maybe it's a closure which looks a
 111              * little like an infotable
 112              */
 113             checkClosureShallow(*stgCast(StgClosure**,c));
 114             return 1;
 115             /* barf("checkStackClosure: weird activation record found on stack (%p).",c); */
 116     }
 117 }
 118
 119 /*
 120  * check that it looks like a valid closure - without checking its payload
 121  * used to avoid recursion between checking PAPs and checking stack
 122  * chunks.
 123  */
 124
 125 void
 126 checkClosureShallow( StgClosure* p )
 127 {
 128     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 129
 130     /* Is it a static closure (i.e. in the data segment)? */
 131     if (LOOKS_LIKE_STATIC(p)) {
 132         ASSERT(closure_STATIC(p));
 133     } else {
 134         ASSERT(!closure_STATIC(p));
 135         ASSERT(LOOKS_LIKE_PTR(p));
 136     }
 137 }
 138
 139 /* check an individual stack object */
 140 StgOffset
 141 checkStackObject( StgPtr sp )
 142 {
 143     if (IS_ARG_TAG(*sp)) {
 144         /* Tagged words might be "stubbed" pointers, so there's no
 145          * point checking to see whether they look like pointers or
 146          * not (some of them will).
 147          */
 148         return ARG_SIZE(*sp) + 1;
 149     } else if (LOOKS_LIKE_GHC_INFO(*stgCast(StgPtr*,sp))) {
 150         return checkStackClosure(stgCast(StgClosure*,sp));
 151     } else { /* must be an untagged closure pointer in the stack */
 152         checkClosureShallow(*stgCast(StgClosure**,sp));
 153         return 1;
 154     }
 155 }
 156
 157 /* check sections of stack between update frames */
 158 void
 159 checkStackChunk( StgPtr sp, StgPtr stack_end )
 160 {
 161     StgPtr p;
 162
 163     p = sp;
 164     while (p < stack_end) {
 165         p += checkStackObject( p );
 166     }
 167     ASSERT( p == stack_end );
 168 }
 169
 170 StgOffset
 171 checkClosure( StgClosure* p )
 172 {
 173     const StgInfoTable *info;
 174
 175 #ifndef INTERPRETER
 176     ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
 177 #endif
 178
 179     /* Is it a static closure (i.e. in the data segment)? */
 180     if (LOOKS_LIKE_STATIC(p)) {
 181         ASSERT(closure_STATIC(p));
 182     } else {
 183         ASSERT(!closure_STATIC(p));
 184         ASSERT(LOOKS_LIKE_PTR(p));
 185     }
 186
 187     info = get_itbl(p);
 188     switch (info->type) {
 189     case BCO:
 190         {
 191             StgBCO* bco = stgCast(StgBCO*,p);
 192             nat i;
 193             for(i=0; i < bco->n_ptrs; ++i) {
 194                 ASSERT(LOOKS_LIKE_PTR(bcoConstPtr(bco,i)));
 195             }
 196             return bco_sizeW(bco);
 197         }
 198
 199     case MVAR:
 200       {
 201         StgMVar *mvar = (StgMVar *)p;
 202         ASSERT(LOOKS_LIKE_PTR(mvar->head));
 203         ASSERT(LOOKS_LIKE_PTR(mvar->tail));
 204         ASSERT(LOOKS_LIKE_PTR(mvar->value));
 205         return sizeofW(StgMVar);
 206       }
 207
 208     case THUNK:
 209     case THUNK_1_0:
 210     case THUNK_0_1:
 211     case THUNK_1_1:
 212     case THUNK_0_2:
 213     case THUNK_2_0:
 214       {
 215         nat i;
 216         for (i = 0; i < info->layout.payload.ptrs; i++) {
 217           ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i)));
 218         }
 219         return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
 220       }
 221
 222     case FUN:
 223     case FUN_1_0:
 224     case FUN_0_1:
 225     case FUN_1_1:
 226     case FUN_0_2:
 227     case FUN_2_0:
 228     case CONSTR:
 229     case CONSTR_1_0:
 230     case CONSTR_0_1:
 231     case CONSTR_1_1:
 232     case CONSTR_0_2:
 233     case CONSTR_2_0:
 234     case IND_PERM:
 235     case IND_OLDGEN:
 236     case IND_OLDGEN_PERM:
 237     case CAF_UNENTERED:
 238     case CAF_ENTERED:
 239     case CAF_BLACKHOLE:
 240     case BLACKHOLE:
 241     case BLACKHOLE_BQ:
 242     case FOREIGN:
 243     case STABLE_NAME:
 244     case MUT_VAR:
 245     case CONSTR_INTLIKE:
 246     case CONSTR_CHARLIKE:
 247     case CONSTR_STATIC:
 248     case CONSTR_NOCAF_STATIC:
 249     case THUNK_STATIC:
 250     case FUN_STATIC:
 251     case IND_STATIC:
 252         {
 253             nat i;
 254             for (i = 0; i < info->layout.payload.ptrs; i++) {
 255                 ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i)));
 256             }
 257             return sizeW_fromITBL(info);
 258         }
 259
 260     case WEAK:
 261       /* deal with these specially - the info table isn't
 262        * representative of the actual layout.
 263        */
 264       { StgWeak *w = (StgWeak *)p;
 265         ASSERT(LOOKS_LIKE_PTR(w->key));
 266         ASSERT(LOOKS_LIKE_PTR(w->value));
 267         ASSERT(LOOKS_LIKE_PTR(w->finalizer));
 268         if (w->link) {
 269           ASSERT(LOOKS_LIKE_PTR(w->link));
 270         }
 271         return sizeW_fromITBL(info);
 272       }
 273
 274     case THUNK_SELECTOR:
 275             ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
 276             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 277
 278     case IND:
 279         {
 280             /* we don't expect to see any of these after GC
 281              * but they might appear during execution
 282              */
 283             P_ q;
 284             StgInd *ind = stgCast(StgInd*,p);
 285             ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
 286             q = (P_)p + sizeofW(StgInd);
 287             while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
 288             return q - (P_)p;
 289         }
 290
 291     case RET_BCO:
 292     case RET_SMALL:
 293     case RET_VEC_SMALL:
 294     case RET_BIG:
 295     case RET_VEC_BIG:
 296     case RET_DYN:
 297     case UPDATE_FRAME:
 298     case STOP_FRAME:
 299     case CATCH_FRAME:
 300     case SEQ_FRAME:
 301             barf("checkClosure: stack frame");
 302
 303     case AP_UPD: /* we can treat this as being the same as a PAP */
 304     case PAP:
 305         {
 306             StgPAP *pap = stgCast(StgPAP*,p);
 307             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 308             checkStackChunk((StgPtr)pap->payload,
 309                             (StgPtr)pap->payload + pap->n_args
 310                             );
 311             return pap_sizeW(pap);
 312         }
 313
 314     case ARR_WORDS:
 315             return arr_words_sizeW(stgCast(StgArrWords*,p));
 316
 317     case MUT_ARR_PTRS:
 318     case MUT_ARR_PTRS_FROZEN:
 319         {
 320             StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p);
 321             nat i;
 322             for (i = 0; i < a->ptrs; i++) {
 323                 ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
 324             }
 325             return mut_arr_ptrs_sizeW(a);
 326         }
 327
 328     case TSO:
 329         checkTSO((StgTSO *)p);
 330         return tso_sizeW((StgTSO *)p);
 331
 332     case BLOCKED_FETCH:
 333     case FETCH_ME:
 334     case EVACUATED:
 335             barf("checkClosure: unimplemented/strange closure type");
 336     default:
 337             barf("checkClosure");
 338     }
 339 #undef LOOKS_LIKE_PTR
 340 }
 341
 342 /* -----------------------------------------------------------------------------
 343    Check Heap Sanity
 344
 345    After garbage collection, the live heap is in a state where we can
 346    run through and check that all the pointers point to the right
 347    place.  This function starts at a given position and sanity-checks
 348    all the objects in the remainder of the chain.
 349    -------------------------------------------------------------------------- */
 350
 351 extern void
 352 checkHeap(bdescr *bd, StgPtr start)
 353 {
 354     StgPtr p;
 355
 356     if (start == NULL) {
 357       p = bd->start;
 358     } else {
 359       p = start;
 360     }
 361
 362     while (bd != NULL) {
 363       while (p < bd->free) {
 364         nat size = checkClosure(stgCast(StgClosure*,p));
 365         /* This is the smallest size of closure that can live in the heap. */
 366         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 367         p += size;
 368
 369         /* skip over slop */
 370         while (p < bd->free &&
 371                (*p == 0 || !LOOKS_LIKE_GHC_INFO(*p))) { p++; }
 372       }
 373       bd = bd->link;
 374       if (bd != NULL) {
 375         p = bd->start;
 376       }
 377     }
 378 }
 379
 380 extern void
 381 checkChain(bdescr *bd)
 382 {
 383   while (bd != NULL) {
 384     checkClosure((StgClosure *)bd->start);
 385     bd = bd->link;
 386   }
 387 }
 388
 389 /* check stack - making sure that update frames are linked correctly */
 390 void
 391 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 392 {
 393     /* check everything down to the first update frame */
 394     checkStackChunk( sp, stgCast(StgPtr,su) );
 395     while ( stgCast(StgPtr,su) < stack_end) {
 396         sp = stgCast(StgPtr,su);
 397         switch (get_itbl(su)->type) {
 398         case UPDATE_FRAME:
 399                 su = su->link;
 400                 break;
 401         case SEQ_FRAME:
 402                 su = stgCast(StgSeqFrame*,su)->link;
 403                 break;
 404         case CATCH_FRAME:
 405                 su = stgCast(StgCatchFrame*,su)->link;
 406                 break;
 407         case STOP_FRAME:
 408                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 409                 return;
 410         default:
 411                 barf("checkStack: weird record found on update frame list.");
 412         }
 413         checkStackChunk( sp, stgCast(StgPtr,su) );
 414     }
 415     ASSERT(stgCast(StgPtr,su) == stack_end);
 416 }
 417
 418 extern void
 419 checkTSO(StgTSO *tso)
 420 {
 421     StgPtr sp = tso->sp;
 422     StgPtr stack = tso->stack;
 423     StgUpdateFrame* su = tso->su;
 424     StgOffset stack_size = tso->stack_size;
 425     StgPtr stack_end = stack + stack_size;
 426
 427     if (tso->whatNext == ThreadComplete ||  tso->whatNext == ThreadKilled) {
 428       /* The garbage collector doesn't bother following any pointers
 429        * from dead threads, so don't check sanity here.
 430        */
 431       return;
 432     }
 433
 434     ASSERT(stack <= sp && sp < stack_end);
 435     ASSERT(sp <= stgCast(StgPtr,su));
 436
 437     checkStack(sp, stack_end, su);
 438 }
 439
 440 /* -----------------------------------------------------------------------------
 441    Check Blackhole Sanity
 442
 443    Test whether an object is already on the update list.
 444    It isn't necessarily an rts error if it is - it might be a programming
 445    error.
 446
 447    Future versions might be able to test for a blackhole without traversing
 448    the update frame list.
 449
 450    -------------------------------------------------------------------------- */
 451 rtsBool isBlackhole( StgTSO* tso, StgClosure* p )
 452 {
 453   StgUpdateFrame* su = tso->su;
 454   do {
 455     switch (get_itbl(su)->type) {
 456     case UPDATE_FRAME:
 457       if (su->updatee == p) {
 458         return rtsTrue;
 459       } else {
 460         su = su->link;
 461       }
 462       break;
 463     case SEQ_FRAME:
 464       su = stgCast(StgSeqFrame*,su)->link;
 465       break;
 466     case CATCH_FRAME:
 467       su = stgCast(StgCatchFrame*,su)->link;
 468       break;
 469     case STOP_FRAME:
 470       return rtsFalse;
 471     default:
 472       barf("isBlackhole: weird record found on update frame list.");
 473     }
 474   } while (1);
 475 }
 476
 477 #endif /* DEBUG */