ghc/rts/Sanity.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Sanity.c,v 1.2 1998/12/02 13:28:43 simonm Exp $
   3  *
   4  * Sanity checking code for the heap and stack.
   5  *
   6  * Used when debugging: check that the stack looks reasonable.
   7  *
   8  *    - All things that are supposed to be pointers look like pointers.
   9  *
  10  *    - Objects in text space are marked as static closures, those
  11  *      in the heap are dynamic.
  12  *
  13  * ---------------------------------------------------------------------------*/
  14
  15 #include "Rts.h"
  16
  17 #ifdef DEBUG
  18
  19 #include "RtsFlags.h"
  20 #include "RtsUtils.h"
  21 #include "BlockAlloc.h"
  22 #include "Sanity.h"
  23
  24 static nat heap_step;
  25
  26 #define LOOKS_LIKE_PTR(r) \
  27   (IS_DATA_PTR(r) || ((IS_USER_PTR(r) && Bdescr((P_)r)->step == heap_step)))
  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     case FUN:
 199     case THUNK:
 200     case CONSTR:
 201     case IND_PERM:
 202     case IND_OLDGEN_PERM:
 203     case CAF_UNENTERED:
 204     case CAF_ENTERED:
 205     case CAF_BLACKHOLE:
 206     case BLACKHOLE:
 207     case FOREIGN:
 208     case MVAR:
 209     case MUT_VAR:
 210     case CONSTR_INTLIKE:
 211     case CONSTR_CHARLIKE:
 212     case CONSTR_STATIC:
 213     case CONSTR_NOCAF_STATIC:
 214     case THUNK_STATIC:
 215     case FUN_STATIC:
 216     case IND_STATIC:
 217         {
 218             nat i;
 219             for (i = 0; i < info->layout.payload.ptrs; i++) {
 220                 ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i)));
 221             }
 222             return sizeW_fromITBL(info);
 223         }
 224
 225     case WEAK:
 226       /* deal with these specially - the info table isn't
 227        * representative of the actual layout.
 228        */
 229       { StgWeak *w = (StgWeak *)p;
 230         ASSERT(LOOKS_LIKE_PTR(w->key));
 231         ASSERT(LOOKS_LIKE_PTR(w->value));
 232         ASSERT(LOOKS_LIKE_PTR(w->finaliser));
 233         if (w->link) {
 234           ASSERT(LOOKS_LIKE_PTR(w->link));
 235         }
 236         return sizeW_fromITBL(info);
 237       }
 238
 239     case THUNK_SELECTOR:
 240             ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
 241             return sizeofW(StgHeader) + MIN_UPD_SIZE;
 242
 243     case IND:
 244     case IND_OLDGEN:
 245         {
 246             /* we don't expect to see any of these after GC
 247              * but they might appear during execution
 248              */
 249             StgInd *ind = stgCast(StgInd*,p);
 250             ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
 251             return sizeofW(StgInd);
 252         }
 253
 254     case RET_BCO:
 255     case RET_SMALL:
 256     case RET_VEC_SMALL:
 257     case RET_BIG:
 258     case RET_VEC_BIG:
 259     case RET_DYN:
 260     case UPDATE_FRAME:
 261     case STOP_FRAME:
 262     case CATCH_FRAME:
 263     case SEQ_FRAME:
 264             barf("checkClosure: stack frame");
 265
 266     case AP_UPD: /* we can treat this as being the same as a PAP */
 267     case PAP:
 268         {
 269             StgPAP *pap = stgCast(StgPAP*,p);
 270             ASSERT(LOOKS_LIKE_PTR(pap->fun));
 271             checkStackChunk((StgPtr)pap->payload,
 272                             (StgPtr)pap->payload + pap->n_args
 273                             );
 274             return pap_sizeW(pap);
 275         }
 276
 277     case ARR_WORDS:
 278     case MUT_ARR_WORDS:
 279             return arr_words_sizeW(stgCast(StgArrWords*,p));
 280
 281     case ARR_PTRS:
 282     case MUT_ARR_PTRS:
 283     case MUT_ARR_PTRS_FROZEN:
 284         {
 285             StgArrPtrs* a = stgCast(StgArrPtrs*,p);
 286             nat i;
 287             for (i = 0; i < a->ptrs; i++) {
 288                 ASSERT(LOOKS_LIKE_PTR(payloadPtr(a,i)));
 289             }
 290             return arr_ptrs_sizeW(a);
 291         }
 292
 293     case TSO:
 294         checkTSO((StgTSO *)p, heap_step);
 295         return tso_sizeW((StgTSO *)p);
 296
 297     case BLOCKED_FETCH:
 298     case FETCH_ME:
 299     case EVACUATED:
 300             barf("checkClosure: unimplemented/strange closure type");
 301     default:
 302             barf("checkClosure");
 303     }
 304 #undef LOOKS_LIKE_PTR
 305 }
 306
 307 /* -----------------------------------------------------------------------------
 308    Check Heap Sanity
 309
 310    After garbage collection, the live heap is in a state where we can
 311    run through and check that all the pointers point to the right
 312    place.
 313    -------------------------------------------------------------------------- */
 314
 315 extern void
 316 checkHeap(bdescr *bd, nat step)
 317 {
 318     StgPtr p;
 319
 320     heap_step = step;
 321
 322     while (bd != NULL) {
 323       p = bd->start;
 324       while (p < bd->free) {
 325         nat size = checkClosure(stgCast(StgClosure*,p));
 326         /* This is the smallest size of closure that can live in the heap. */
 327         ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 328         p += size;
 329       }
 330       bd = bd->link;
 331     }
 332 }
 333
 334 /* check stack - making sure that update frames are linked correctly */
 335 void
 336 checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
 337 {
 338     /* check everything down to the first update frame */
 339     checkStackChunk( sp, stgCast(StgPtr,su) );
 340     while ( stgCast(StgPtr,su) < stack_end) {
 341         sp = stgCast(StgPtr,su);
 342         switch (get_itbl(su)->type) {
 343         case UPDATE_FRAME:
 344                 su = su->link;
 345                 break;
 346         case SEQ_FRAME:
 347                 su = stgCast(StgSeqFrame*,su)->link;
 348                 break;
 349         case CATCH_FRAME:
 350                 su = stgCast(StgCatchFrame*,su)->link;
 351                 break;
 352         case STOP_FRAME:
 353                 /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
 354                 return;
 355         default:
 356                 barf("checkStack: weird record found on update frame list.");
 357         }
 358         checkStackChunk( sp, stgCast(StgPtr,su) );
 359     }
 360     ASSERT(stgCast(StgPtr,su) == stack_end);
 361 }
 362
 363 extern void
 364 checkTSO(StgTSO *tso, nat step)
 365 {
 366     StgPtr sp = tso->sp;
 367     StgPtr stack = tso->stack;
 368     StgUpdateFrame* su = tso->su;
 369     StgOffset stack_size = tso->stack_size;
 370     StgPtr stack_end = stack + stack_size;
 371
 372     heap_step = step;
 373
 374     ASSERT(stack <= sp && sp < stack_end);
 375     ASSERT(sp <= stgCast(StgPtr,su));
 376
 377     checkStack(sp, stack_end, su);
 378 }
 379
 380 /* -----------------------------------------------------------------------------
 381    Check Blackhole Sanity
 382
 383    Test whether an object is already on the update list.
 384    It isn't necessarily an rts error if it is - it might be a programming
 385    error.
 386
 387    Future versions might be able to test for a blackhole without traversing
 388    the update frame list.
 389
 390    -------------------------------------------------------------------------- */
 391 rtsBool isBlackhole( StgTSO* tso, StgClosure* p )
 392 {
 393   StgUpdateFrame* su = tso->su;
 394   do {
 395     switch (get_itbl(su)->type) {
 396     case UPDATE_FRAME:
 397       if (su->updatee == p) {
 398         return rtsTrue;
 399       } else {
 400         su = su->link;
 401       }
 402       break;
 403     case SEQ_FRAME:
 404       su = stgCast(StgSeqFrame*,su)->link;
 405       break;
 406     case CATCH_FRAME:
 407       su = stgCast(StgCatchFrame*,su)->link;
 408       break;
 409     case STOP_FRAME:
 410       return rtsFalse;
 411     default:
 412       barf("isBlackhole: weird record found on update frame list.");
 413     }
 414   } while (1);
 415 }
 416
 417 #endif /* DEBUG */