ghc/rts/Sanity.c

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