ghc/runtime/storage/SMcheck.lc

   1 \section[storage-manager-check]{Checking Consistency of Storage Manager}
   2
   3 This code performs consistency/sanity checks on the stacks and heap.
   4 It can be called each time round the mini-interpreter loop.  Not
   5 required if we're tail-jumping (no mini-interpreter).
   6
   7 \begin{code}
   8
   9 #if ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) )
  10
  11 /* Insist on the declaration of STG-machine registers */
  12 #define MAIN_REG_MAP
  13
  14 #include "SMinternal.h"
  15
  16 #define isHeapPtr(p) \
  17     ((p) >= heap_space && (p) < heap_space + RTSflags.GcFlags.heapSize)
  18
  19 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
  20 #define validInfoPtr(i) \
  21     ((i) < (StgPtr) (get_end_result) /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
  22         /* No Internal info tables allowed (type -1) */
  23
  24 #else /* non-NeXT */
  25 #define validInfoPtr(i) \
  26     ((i) < (P_) &end /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
  27         /* No Internal info tables allowed (type -1) */
  28
  29 #endif /* non-NeXT */
  30
  31 #define suspectPtr(p) ((p) < (P_)256)
  32
  33 #if defined(GC2s)
  34 #define validHeapPtr(p) \
  35     ((p) >= semispaceInfo[semispace].base && (p) <= semispaceInfo[semispace].lim)
  36 #else
  37 #if defined(GC1s)
  38 #define validHeapPtr(p) \
  39     ((p) >= compactingInfo.base && (p) <= compactingInfo.lim)
  40 #else
  41 #if defined(GCdu)
  42 #define validHeapPtr(p) \
  43     ((p) >= dualmodeInfo.modeinfo[dualmodeInfo.mode].base && \
  44      (p) <= dualmodeInfo.modeinfo[dualmodeInfo.mode].lim)
  45
  46 #else
  47 #if defined(GCap)
  48 /* Two cases needed, depending on whether the 2-space GC is forced
  49    SLPJ 17 June 93 */
  50 #define validHeapPtr(p)                                                 \
  51     (RTSflags.GcFlags.force2s ?                                         \
  52             ((p) >= appelInfo.space[appelInfo.semi_space].base &&       \
  53              (p) <= appelInfo.space[appelInfo.semi_space].lim) :        \
  54             (((p) >= appelInfo.oldbase && (p) <= appelInfo.oldlim) ||   \
  55              ((p) >= appelInfo.newbase && (p) <= appelInfo.newlim))     \
  56     )
  57
  58 #else
  59 #if defined(GCgn)
  60 #define validHeapPtr(p) \
  61     (((p) >= genInfo.oldbase && (p) <= genInfo.oldlim) || \
  62      ((p) >= genInfo.newgen[genInfo.curnew].newbase && (p) <= genInfo.newgen[genInfo.curnew].newlim) || \
  63      ((p) >= genInfo.allocbase && (p) <= genInfo.alloclim))
  64 #else
  65 #define validHeapPtr(p) 0
  66 #endif
  67 #endif
  68 #endif
  69 #endif
  70 #endif
  71
  72
  73 void checkAStack(STG_NO_ARGS)
  74 {
  75     PP_ stackptr;
  76     P_  closurePtr;
  77     P_  infoPtr;
  78     I_  error = 0;
  79
  80     if (SuB > SpB + 1) {
  81         fprintf(stderr, "SuB (%lx) > SpB (%lx)\n", (W_) SuB, (W_) SpB);
  82         error = 1;
  83     }
  84     if (SuA < SpA) {
  85         fprintf(stderr, "SuA (%lx) < SpA (%lx)\n", (W_) SuA, (W_) SpA);
  86         error = 1;
  87     }
  88
  89     for (stackptr = SpA;
  90          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
  91          stackptr = stackptr + AREL(1)) {
  92
  93         closurePtr = (P_) *stackptr;
  94
  95         if (suspectPtr(closurePtr)) {
  96             fprintf(stderr, "Suspect heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
  97                     (W_) SpA, (W_) stackptr, (W_) closurePtr);
  98             error = 1;
  99
 100         } else if (isHeapPtr(closurePtr) && ! validHeapPtr(closurePtr)) {
 101
 102             fprintf(stderr, "Bad heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
 103                     (W_) SpA, (W_) stackptr, (W_) closurePtr);
 104             error = 1;
 105
 106         } else {
 107             infoPtr = (P_) *closurePtr;
 108
 109             if (suspectPtr(infoPtr)) {
 110                 fprintf(stderr, "Suspect info ptr on A stk; SpA %lx, sp %lx, closure %lx info %lx\n",
 111                     (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr);
 112                 error = 1;
 113
 114             } else if ( ! validInfoPtr(infoPtr)) {
 115                 fprintf(stderr, "Bad info ptr in A stk; SpA %lx, sp %lx, closure %lx, info %lx\n",
 116                         (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr/* , INFO_TYPE(infoPtr) */);
 117                 error = 1;
 118             }
 119         }
 120     }
 121
 122     if (error) abort();
 123 }
 124
 125 #endif /* ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) ) */
 126
 127 \end{code}