Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC

Commits:

19 changed files:

Changes:

  • libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
    ... ... @@ -23,28 +23,7 @@ import Data.Typeable
    23 23 
     import GHC.Exts
    24 24 
     import GHC.IO
    25 25 
     import GHC.Internal.Stack
    26 
    -
    27 
    --- ----------------------------------------------------------------------------
    28 
    --- IsStackAnnotation
    29 
    --- ----------------------------------------------------------------------------
    30 
    -
    31 
    -class IsStackAnnotation a where
    32 
    -  displayStackAnnotation :: a -> String
    33 
    -
    34 
    --- ----------------------------------------------------------------------------
    35 
    --- Annotations
    36 
    --- ----------------------------------------------------------------------------
    37 
    -
    38 
    -{- |
    39 
    -The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
    40 
    -When the call stack is annotated with a value of type @a@, behind the scenes it is
    41 
    -encapsulated in a @SomeStackAnnotation@.
    42 
    --}
    43 
    -data SomeStackAnnotation where
    44 
    -  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
    45 
    -
    46 
    -instance IsStackAnnotation SomeStackAnnotation where
    47 
    -  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
    26 
    +import GHC.Internal.Stack.Annotation
    48 27
    49 28 
     data StringAnnotation where
    50 29 
       StringAnnotation :: String -> StringAnnotation

  • libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
    ... ... @@ -24,10 +24,10 @@ import Data.Bits
    24 24 
     import Data.Maybe
    25 25 
     import Foreign
    26 26 
     import GHC.Exts
    27 
    -import GHC.Exts.Heap (Box (..))
    28 27 
     import GHC.Exts.Heap.ClosureTypes
    29 28 
     import GHC.Exts.Heap.Closures
    30 
    -  ( StackFrame,
    29 
    +  ( Box (..),
    30 
    +    StackFrame,
    31 31 
         GenStackFrame (..),
    32 32 
         StgStackClosure,
    33 33 
         GenStgStackClosure (..),

  • libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
    ... ... @@ -14,7 +14,7 @@ hello x y = annotateShow (x,y) $
    14 14
    15 15 
     {-# NOINLINE decodeAndPrintAnnotationFrames #-}
    16 16 
     decodeAndPrintAnnotationFrames :: a -> a
    17 
    -decodeAndPrintAnnotationFrames a = unsafePerformIO $ do
    17 
    +decodeAndPrintAnnotationFrames !a = unsafePerformIO $ do
    18 18 
       stack <- GHC.Stack.CloneStack.cloneMyStack
    19 19 
       decoded <- GHC.Exts.Stack.Decode.decodeStack stack
    20 20 
       print [ displayStackAnnotation a

  • libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
    1 
    -
    2 1 
     {-# LANGUAGE ScopedTypeVariables #-}
    3 
    -{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-}
    4 2 
     import Control.Monad
    5 3 
     import GHC.Stack.Types
    6 4 
     import Control.Exception
    ... ... @@ -9,21 +7,8 @@ import GHC.Stack.Annotation.Experimental
    9 7
    10 8 
     main :: IO ()
    11 9 
     main = do
    12 
    -  setBacktraceMechanismState IPEBacktrace True
    13 
    -  -- foo baz
    14 10 
       bar
    15 11
    16 
    -foo :: HasCallStack => IO () -> IO ()
    17 
    -foo act = annotateCallStackM $ do
    18 
    -  putStrLn "Start some work"
    19 
    -  act
    20 
    -  putStrLn "Finish some work"
    21 
    -
    22 
    -baz :: HasCallStack => IO ()
    23 
    -baz = annotateCallStackM $ do
    24 
    -  print (fib 20)
    25 
    -  throwIO $ ErrorCall "baz is interrupted"
    26 
    -
    27 12 
     bar :: IO ()
    28 13 
     bar = annotateCallStackM $ annotateStringM "bar" $ do
    29 14 
       putStrLn "Some more work in bar"

  • libraries/ghc-internal/cbits/HeapPrim.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +aToWordzh (P_ clos)
    4 
    +{
    5 
    +    return (clos);
    6 
    +}
    7 
    +
    8 
    +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
    9 
    +{
    10 
    +    clos1 = UNTAG(clos1);
    11 
    +    clos2 = UNTAG(clos2);
    12 
    +    return (clos1 == clos2);
    13 
    +}

  • libraries/ghc-internal/cbits/Stack.cmm
    1 
    +// Uncomment to enable assertions during development
    2 
    +// #define DEBUG 1
    3 
    +
    4 
    +#include "Cmm.h"
    5 
    +
    6 
    +// StgStack_marking was not available in the Stage0 compiler at the time of
    7 
    +// writing. Because, it has been added to derivedConstants when Stack.cmm was
    8 
    +// developed.
    9 
    +#if defined(StgStack_marking)
    10 
    +
    11 
    +// Returns the next stackframe's StgStack* and offset in it. And, an indicator
    12 
    +// if this frame is the last one (`hasNext` bit.)
    13 
    +// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
    14 
    +advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
    15 
    +  W_ frameSize;
    16 
    +  (frameSize) = ccall stackFrameSize(stack, offsetWords);
    17 
    +
    18 
    +  P_ nextClosurePtr;
    19 
    +  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));
    20 
    +
    21 
    +  P_ stackArrayPtr;
    22 
    +  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;
    23 
    +
    24 
    +  P_ stackBottom;
    25 
    +  W_ stackSize, stackSizeInBytes;
    26 
    +  stackSize = TO_W_(StgStack_stack_size(stack));
    27 
    +  stackSizeInBytes = WDS(stackSize);
    28 
    +  stackBottom = stackSizeInBytes + stackArrayPtr;
    29 
    +
    30 
    +  P_ newStack;
    31 
    +  W_ newOffsetWords, hasNext;
    32 
    +  if(nextClosurePtr < stackBottom) (likely: True) {
    33 
    +    newStack = stack;
    34 
    +    newOffsetWords = offsetWords + frameSize;
    35 
    +    hasNext = 1;
    36 
    +  } else {
    37 
    +    P_ underflowFrameStack;
    38 
    +    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
    39 
    +    if (underflowFrameStack == NULL) (likely: True) {
    40 
    +      newStack = NULL;
    41 
    +      newOffsetWords = NULL;
    42 
    +      hasNext = NULL;
    43 
    +    } else {
    44 
    +      newStack = underflowFrameStack;
    45 
    +      newOffsetWords = NULL;
    46 
    +      hasNext = 1;
    47 
    +    }
    48 
    +  }
    49 
    +
    50 
    +  return (newStack, newOffsetWords, hasNext);
    51 
    +}
    52 
    +
    53 
    +// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)
    54 
    +getSmallBitmapzh(P_ stack, W_ offsetWords) {
    55 
    +  P_ c;
    56 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    57 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    58 
    +
    59 
    +  W_ bitmap, size;
    60 
    +  (bitmap) = ccall getBitmapWord(c);
    61 
    +  (size) = ccall getBitmapSize(c);
    62 
    +
    63 
    +  return (bitmap, size);
    64 
    +}
    65 
    +
    66 
    +
    67 
    +// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)
    68 
    +getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {
    69 
    +  P_ c;
    70 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    71 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    72 
    +
    73 
    +  W_ bitmap, size, specialType;
    74 
    +  (bitmap) = ccall getRetFunBitmapWord(c);
    75 
    +  (size) = ccall getRetFunBitmapSize(c);
    76 
    +
    77 
    +  return (bitmap, size);
    78 
    +}
    79 
    +
    80 
    +// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)
    81 
    +getLargeBitmapzh(P_ stack, W_ offsetWords) {
    82 
    +  P_ c, words;
    83 
    +  W_ size;
    84 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    85 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    86 
    +
    87 
    +  (words) = ccall getLargeBitmap(MyCapability(), c);
    88 
    +  (size) = ccall getLargeBitmapSize(c);
    89 
    +
    90 
    +  return (words, size);
    91 
    +}
    92 
    +
    93 
    +// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)
    94 
    +getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {
    95 
    +  P_ c, words;
    96 
    +  W_ size;
    97 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    98 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    99 
    +
    100 
    +  (words) = ccall getBCOLargeBitmap(MyCapability(), c);
    101 
    +  (size) = ccall getBCOLargeBitmapSize(c);
    102 
    +
    103 
    +  return (words, size);
    104 
    +}
    105 
    +
    106 
    +// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)
    107 
    +getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {
    108 
    +  P_ c, words;
    109 
    +  W_ size;
    110 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    111 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    112 
    +
    113 
    +  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);
    114 
    +  (size) = ccall getRetFunSize(c);
    115 
    +
    116 
    +  return (words, size);
    117 
    +}
    118 
    +
    119 
    +// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)
    120 
    +getWordzh(P_ stack, W_ offsetWords) {
    121 
    +  P_ wordAddr;
    122 
    +  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));
    123 
    +  return (W_[wordAddr]);
    124 
    +}
    125 
    +
    126 
    +// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)
    127 
    +getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {
    128 
    +  P_ closurePtr;
    129 
    +  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
    130 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
    131 
    +
    132 
    +  P_ next_chunk;
    133 
    +  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
    134 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk));
    135 
    +  return (next_chunk);
    136 
    +}
    137 
    +
    138 
    +// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)
    139 
    +isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
    140 
    +  P_ c;
    141 
    +  c = StgStack_sp(stack) + WDS(offsetWords);
    142 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    143 
    +
    144 
    +  W_ type;
    145 
    +  (type) = ccall isArgGenBigRetFunType(c);
    146 
    +  return (type);
    147 
    +}
    148 
    +
    149 
    +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
    150 
    +getInfoTableAddrszh(P_ stack, W_ offsetWords) {
    151 
    +  P_ p, info_struct, info_ptr;
    152 
    +  p = StgStack_sp(stack) + WDS(offsetWords);
    153 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
    154 
    +  info_struct = %GET_STD_INFO(UNTAG(p));
    155 
    +  info_ptr = %INFO_PTR(UNTAG(p));
    156 
    +  return (info_struct, info_ptr);
    157 
    +}
    158 
    +
    159 
    +// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
    160 
    +getStackInfoTableAddrzh(P_ stack) {
    161 
    +  P_ info;
    162 
    +  info = %GET_STD_INFO(UNTAG(stack));
    163 
    +  return (info);
    164 
    +}
    165 
    +
    166 
    +// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
    167 
    +getStackClosurezh(P_ stack, W_ offsetWords) {
    168 
    +  P_ ptr;
    169 
    +  ptr = StgStack_sp(stack) + WDS(offsetWords);
    170 
    +
    171 
    +  P_ closure;
    172 
    +  (closure) = ccall getStackClosure(ptr);
    173 
    +  return (closure);
    174 
    +}
    175 
    +
    176 
    +// (bits32) getStackFieldszh(StgStack* stack)
    177 
    +getStackFieldszh(P_ stack){
    178 
    +  bits32 size;
    179 
    +  size = StgStack_stack_size(stack);
    180 
    +  return (size);
    181 
    +}
    182 
    +#endif

  • libraries/ghc-internal/cbits/Stack_c.c
    1 
    +#include "MachDeps.h"
    2 
    +#include "Rts.h"
    3 
    +#include "RtsAPI.h"
    4 
    +#include "rts/Messages.h"
    5 
    +#include "rts/Types.h"
    6 
    +#include "rts/storage/ClosureTypes.h"
    7 
    +#include "rts/storage/Closures.h"
    8 
    +#include "rts/storage/FunTypes.h"
    9 
    +#include "rts/storage/InfoTables.h"
    10 
    +
    11 
    +StgWord stackFrameSize(StgStack *stack, StgWord offset) {
    12 
    +  StgClosure *c = (StgClosure *)stack->sp + offset;
    13 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    14 
    +  return stack_frame_sizeW(c);
    15 
    +}
    16 
    +
    17 
    +StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
    18 
    +  StgClosure *frame = (StgClosure *)stack->sp + offset;
    19 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
    20 
    +  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
    21 
    +
    22 
    +  if (info->i.type == UNDERFLOW_FRAME) {
    23 
    +    return ((StgUnderflowFrame *)frame)->next_chunk;
    24 
    +  } else {
    25 
    +    return NULL;
    26 
    +  }
    27 
    +}
    28 
    +
    29 
    +// Only exists to make the get_itbl macro available in Haskell code (via FFI).
    30 
    +const StgInfoTable *getItbl(StgClosure *closure) {
    31 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
    32 
    +  return get_itbl(closure);
    33 
    +};
    34 
    +
    35 
    +StgWord getBitmapSize(StgClosure *c) {
    36 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    37 
    +
    38 
    +  const StgInfoTable *info = get_itbl(c);
    39 
    +  StgWord bitmap = info->layout.bitmap;
    40 
    +  return BITMAP_SIZE(bitmap);
    41 
    +}
    42 
    +
    43 
    +StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
    44 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
    45 
    +
    46 
    +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    47 
    +  switch (fun_info->f.fun_type) {
    48 
    +  case ARG_GEN:
    49 
    +    return BITMAP_SIZE(fun_info->f.b.bitmap);
    50 
    +  case ARG_GEN_BIG:
    51 
    +    return GET_FUN_LARGE_BITMAP(fun_info)->size;
    52 
    +  default:
    53 
    +    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
    54 
    +  }
    55 
    +}
    56 
    +
    57 
    +StgWord getBitmapWord(StgClosure *c) {
    58 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    59 
    +
    60 
    +  const StgInfoTable *info = get_itbl(c);
    61 
    +  StgWord bitmap = info->layout.bitmap;
    62 
    +  StgWord bitmapWord = BITMAP_BITS(bitmap);
    63 
    +  return bitmapWord;
    64 
    +}
    65 
    +
    66 
    +StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
    67 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
    68 
    +
    69 
    +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    70 
    +  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    71 
    +  switch (fun_info->f.fun_type) {
    72 
    +  case ARG_GEN:
    73 
    +    return BITMAP_BITS(fun_info->f.b.bitmap);
    74 
    +  case ARG_GEN_BIG:
    75 
    +    // Cannot do more than warn and exit.
    76 
    +    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
    77 
    +    stg_exit(EXIT_INTERNAL_ERROR);
    78 
    +  default:
    79 
    +    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
    80 
    +  }
    81 
    +}
    82 
    +
    83 
    +StgWord getLargeBitmapSize(StgClosure *c) {
    84 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    85 
    +
    86 
    +  const StgInfoTable *info = get_itbl(c);
    87 
    +  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
    88 
    +  return bitmap->size;
    89 
    +}
    90 
    +
    91 
    +StgWord getRetFunSize(StgRetFun *ret_fun) {
    92 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
    93 
    +
    94 
    +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    95 
    +  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    96 
    +  switch (fun_info->f.fun_type) {
    97 
    +  case ARG_GEN:
    98 
    +    return BITMAP_SIZE(fun_info->f.b.bitmap);
    99 
    +  case ARG_GEN_BIG:
    100 
    +    return GET_FUN_LARGE_BITMAP(fun_info)->size;
    101 
    +  default:
    102 
    +    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
    103 
    +  }
    104 
    +}
    105 
    +
    106 
    +StgWord getBCOLargeBitmapSize(StgClosure *c) {
    107 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    108 
    +
    109 
    +  StgBCO *bco = (StgBCO *)*c->payload;
    110 
    +
    111 
    +  return BCO_BITMAP_SIZE(bco);
    112 
    +}
    113 
    +
    114 
    +StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {
    115 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    116 
    +  const StgInfoTable *info = get_itbl(c);
    117 
    +  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
    118 
    +
    119 
    +  return bitmap->bitmap;
    120 
    +}
    121 
    +
    122 
    +StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
    123 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
    124 
    +
    125 
    +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    126 
    +  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
    127 
    +
    128 
    +  return bitmap->bitmap;
    129 
    +}
    130 
    +
    131 
    +StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
    132 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
    133 
    +
    134 
    +  StgBCO *bco = (StgBCO *)*c->payload;
    135 
    +  StgLargeBitmap *bitmap = BCO_BITMAP(bco);
    136 
    +
    137 
    +  return bitmap->bitmap;
    138 
    +}
    139 
    +
    140 
    +StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
    141 
    +  return frame->next_chunk;
    142 
    +}
    143 
    +
    144 
    +StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) {
    145 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
    146 
    +
    147 
    +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
    148 
    +  return fun_info->f.fun_type == ARG_GEN_BIG;
    149 
    +}
    150 
    +
    151 
    +StgClosure *getStackClosure(StgClosure **c) { return *c; }

  • libraries/ghc-internal/ghc-internal.cabal.in
    ... ... @@ -231,6 +231,12 @@ Library
    231 231 
             GHC.Internal.GHCi
    232 232 
             GHC.Internal.GHCi.Helpers
    233 233 
             GHC.Internal.Generics
    234 
    +        GHC.Internal.Heap.Closures
    235 
    +        GHC.Internal.Heap.Constants
    236 
    +        GHC.Internal.Heap.InfoTable
    237 
    +        GHC.Internal.Heap.InfoTable.Types
    238 
    +        GHC.Internal.Heap.InfoTableProf
    239 
    +        GHC.Internal.Heap.ProfInfo.Types
    234 240 
             GHC.Internal.InfoProv
    235 241 
             GHC.Internal.InfoProv.Types
    236 242 
             GHC.Internal.IO
    ... ... @@ -283,14 +289,17 @@ Library
    283 289 
             GHC.Internal.RTS.Flags
    284 290 
             GHC.Internal.RTS.Flags.Test
    285 291 
             GHC.Internal.ST
    286 
    -        GHC.Internal.Stack.CloneStack
    287 292 
             GHC.Internal.StaticPtr
    288 293 
             GHC.Internal.STRef
    289 294 
             GHC.Internal.Show
    290 295 
             GHC.Internal.Stable
    291 296 
             GHC.Internal.StableName
    292 297 
             GHC.Internal.Stack
    298 
    +        GHC.Internal.Stack.Annotation
    293 299 
             GHC.Internal.Stack.CCS
    300 
    +        GHC.Internal.Stack.CloneStack
    301 
    +        GHC.Internal.Stack.Constants
    302 
    +        GHC.Internal.Stack.Decode
    294 303 
             GHC.Internal.Stack.Types
    295 304 
             GHC.Internal.Stats
    296 305 
             GHC.Internal.Storable
    ... ... @@ -449,9 +458,12 @@ Library
    449 458 
               cbits/popcnt.c
    450 459 
               cbits/vectorQuotRem.c
    451 460 
               cbits/word2float.c
    461 
    +          cbits/Stack_c.c
    452 462
    453 463 
           cmm-sources:
    454 464 
               cbits/StackCloningDecoding.cmm
    465 
    +          cbits/Stack.cmm
    466 
    +          cbits/HeapPrim.cmm
    455 467
    456 468 
         if arch(javascript)
    457 469 
           js-sources:

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -7,6 +7,8 @@ module GHC.Internal.Exception.Backtrace where
    7 7
    8 8 
     import GHC.Internal.Base
    9 9 
     import GHC.Internal.Data.OldList
    10 
    +import GHC.Internal.Data.Functor
    11 
    +import GHC.Internal.Data.Maybe
    10 12 
     import GHC.Internal.IORef
    11 13 
     import GHC.Internal.IO.Unsafe (unsafePerformIO)
    12 14 
     import GHC.Internal.Exception.Context
    ... ... @@ -16,6 +18,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack)
    16 18 
     import qualified GHC.Internal.Stack as HCS
    17 19 
     import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
    18 20 
     import qualified GHC.Internal.Stack.CloneStack as CloneStack
    21 
    +import qualified GHC.Internal.Stack.Decode as Decode
    19 22 
     import qualified GHC.Internal.Stack.CCS as CCS
    20 23
    21 24 
     -- | How to collect a backtrace when an exception is thrown.
    ... ... @@ -112,7 +115,7 @@ displayBacktraces bts = concat
    112 115 
         displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
    113 116 
         -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
    114 117 
         -- references closures can be garbage collected.
    115 
    -    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
    118 
    +    displayIpe  = unlines . map (indent 2 . Decode.prettyStackEntry) . unsafePerformIO . CloneStack.decode
    116 119 
         displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    117 120 
           where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    118 121

  • libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +{-# LANGUAGE ForeignFunctionInterface #-}
    3 
    +{-# LANGUAGE GHCForeignImportPrim #-}
    4 
    +{-# LANGUAGE MagicHash #-}
    5 
    +{-# LANGUAGE RecordWildCards #-}
    6 
    +{-# LANGUAGE UnliftedFFITypes #-}
    7 
    +{-# LANGUAGE DeriveGeneric #-}
    8 
    +{-# LANGUAGE DeriveTraversable #-}
    9 
    +-- Late cost centres introduce a thunk in the asBox function, which leads to
    10 
    +-- an additional wrapper being added to any value placed inside a box.
    11 
    +-- This can be removed once our boot compiler is no longer affected by #25212
    12 
    +{-# OPTIONS_GHC -fno-prof-late  #-}
    13 
    +{-# LANGUAGE NamedFieldPuns #-}
    14 
    +
    15 
    +module GHC.Internal.Heap.Closures (
    16 
    +    -- * Closures
    17 
    +      Closure
    18 
    +    , GenClosure(..)
    19 
    +    , getClosureInfoTbl
    20 
    +    , getClosureInfoTbl_maybe
    21 
    +    , getClosurePtrArgs
    22 
    +    , getClosurePtrArgs_maybe
    23 
    +    , PrimType(..)
    24 
    +    , WhatNext(..)
    25 
    +    , WhyBlocked(..)
    26 
    +    , TsoFlags(..)
    27 
    +    , allClosures
    28 
    +    , closureSize
    29 
    +
    30 
    +    -- * Stack
    31 
    +    , StgStackClosure
    32 
    +    , GenStgStackClosure(..)
    33 
    +    , StackFrame
    34 
    +    , GenStackFrame(..)
    35 
    +    , StackField
    36 
    +    , GenStackField(..)
    37 
    +
    38 
    +    -- * Boxes
    39 
    +    , Box(..)
    40 
    +    , areBoxesEqual
    41 
    +    , asBox
    42 
    +    ) where
    43 
    +
    44 
    +import GHC.Internal.Base
    45 
    +import GHC.Internal.Show
    46 
    +
    47 
    +import GHC.Internal.Heap.Constants
    48 
    +#if defined(PROFILING)
    49 
    +import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports]
    50 
    +import GHC.Internal.Heap.InfoTableProf
    51 
    +#else
    52 
    +import GHC.Internal.Heap.InfoTable
    53 
    +import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports]
    54 
    +
    55 
    +{-
    56 
    +Note [No way-dependent imports]
    57 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    58 
    +`ghc -M` currently assumes that the imports for a module are the same
    59 
    +in every way.  This is arguably a bug, but breaking this assumption by
    60 
    +importing different things in different ways can cause trouble.  For
    61 
    +example, this module in the profiling way imports and uses
    62 
    +GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the
    63 
    +vanilla way, there were intermittent build failures due to this module
    64 
    +being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf
    65 
    +in the profiling way. (#15197)
    66 
    +-}
    67 
    +#endif
    68 
    +
    69 
    +import GHC.Internal.Heap.ProfInfo.Types
    70 
    +
    71 
    +import GHC.Internal.Data.Bits
    72 
    +import GHC.Internal.Data.Foldable (Foldable, toList)
    73 
    +import GHC.Internal.Data.Traversable (Traversable)
    74 
    +import GHC.Internal.Int
    75 
    +import GHC.Internal.Num
    76 
    +import GHC.Internal.Real
    77 
    +import GHC.Internal.Word
    78 
    +import GHC.Internal.Exts
    79 
    +import GHC.Internal.Generics
    80 
    +import GHC.Internal.Numeric
    81 
    +import GHC.Internal.Stack (HasCallStack)
    82 
    +
    83 
    +------------------------------------------------------------------------
    84 
    +-- Boxes
    85 
    +
    86 
    +foreign import prim "aToWordzh" aToWord# :: Any -> Word#
    87 
    +
    88 
    +foreign import prim "reallyUnsafePtrEqualityUpToTag"
    89 
    +    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
    90 
    +
    91 
    +-- | An arbitrary Haskell value in a safe Box. The point is that even
    92 
    +-- unevaluated thunks can safely be moved around inside the Box, and when
    93 
    +-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
    94 
    +-- to evaluate the argument.
    95 
    +data Box = Box Any
    96 
    +
    97 
    +instance Show Box where
    98 
    +-- From libraries/base/GHC/Ptr.lhs
    99 
    +   showsPrec _ (Box a) rs =
    100 
    +    -- unsafePerformIO (print "↓" >> pClosure a) `seq`
    101 
    +    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
    102 
    +     where
    103 
    +       ptr  = W# (aToWord# a)
    104 
    +       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
    105 
    +       addr = ptr - tag
    106 
    +       pad_out ls = '0':'x':ls
    107 
    +
    108 
    +-- |This takes an arbitrary value and puts it into a box.
    109 
    +-- Note that calls like
    110 
    +--
    111 
    +-- > asBox (head list)
    112 
    +--
    113 
    +-- will put the thunk \"head list\" into the box, /not/ the element at the head
    114 
    +-- of the list. For that, use careful case expressions:
    115 
    +--
    116 
    +-- > case list of x:_ -> asBox x
    117 
    +asBox :: a -> Box
    118 
    +asBox x = Box (unsafeCoerce# x)
    119 
    +
    120 
    +-- | Boxes can be compared, but this is not pure, as different heap objects can,
    121 
    +-- after garbage collection, become the same object.
    122 
    +areBoxesEqual :: Box -> Box -> IO Bool
    123 
    +areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
    124 
    +    0# -> pure False
    125 
    +    _  -> pure True
    126 
    +
    127 
    +
    128 
    +------------------------------------------------------------------------
    129 
    +-- Closures
    130 
    +type Closure = GenClosure Box
    131 
    +
    132 
    +-- | This is the representation of a Haskell value on the heap. It reflects
    133 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h>
    134 
    +--
    135 
    +-- The data type is parametrized by `b`: the type to store references in.
    136 
    +-- Usually this is a 'Box' with the type synonym 'Closure'.
    137 
    +--
    138 
    +-- All Heap objects have the same basic layout. A header containing a pointer to
    139 
    +-- the info table and a payload with various fields. The @info@ field below
    140 
    +-- always refers to the info table pointed to by the header. The remaining
    141 
    +-- fields are the payload.
    142 
    +--
    143 
    +-- See
    144 
    +-- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>
    145 
    +-- for more information.
    146 
    +data GenClosure b
    147 
    +  = -- | A data constructor
    148 
    +    ConstrClosure
    149 
    +        { info       :: !StgInfoTable
    150 
    +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
    151 
    +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
    152 
    +        , pkg        :: !String         -- ^ Package name
    153 
    +        , modl       :: !String         -- ^ Module name
    154 
    +        , name       :: !String         -- ^ Constructor name
    155 
    +        }
    156 
    +
    157 
    +    -- | A function
    158 
    +  | FunClosure
    159 
    +        { info       :: !StgInfoTable
    160 
    +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
    161 
    +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
    162 
    +        }
    163 
    +
    164 
    +    -- | A thunk, an expression not obviously in head normal form
    165 
    +  | ThunkClosure
    166 
    +        { info       :: !StgInfoTable
    167 
    +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
    168 
    +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
    169 
    +        }
    170 
    +
    171 
    +    -- | A thunk which performs a simple selection operation
    172 
    +  | SelectorClosure
    173 
    +        { info       :: !StgInfoTable
    174 
    +        , selectee   :: !b              -- ^ Pointer to the object being
    175 
    +                                        --   selected from
    176 
    +        }
    177 
    +
    178 
    +    -- | An unsaturated function application
    179 
    +  | PAPClosure
    180 
    +        { info       :: !StgInfoTable
    181 
    +        , arity      :: !HalfWord       -- ^ Arity of the partial application
    182 
    +        , n_args     :: !HalfWord       -- ^ Size of the payload in words
    183 
    +        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
    184 
    +        , payload    :: ![b]            -- ^ Sequence of already applied
    185 
    +                                        --   arguments
    186 
    +        }
    187 
    +
    188 
    +    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
    189 
    +    -- functions fun actually find the name here.
    190 
    +    -- At least the other direction works via "lookupSymbol
    191 
    +    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
    192 
    +    -- | A function application
    193 
    +  | APClosure
    194 
    +        { info       :: !StgInfoTable
    195 
    +        , arity      :: !HalfWord       -- ^ Always 0
    196 
    +        , n_args     :: !HalfWord       -- ^ Size of payload in words
    197 
    +        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
    198 
    +        , payload    :: ![b]            -- ^ Sequence of already applied
    199 
    +                                        --   arguments
    200 
    +        }
    201 
    +
    202 
    +    -- | A suspended thunk evaluation
    203 
    +  | APStackClosure
    204 
    +        { info       :: !StgInfoTable
    205 
    +        , fun        :: !b              -- ^ Function closure
    206 
    +        , payload    :: ![b]            -- ^ Stack right before suspension
    207 
    +        }
    208 
    +
    209 
    +    -- | A pointer to another closure, introduced when a thunk is updated
    210 
    +    -- to point at its value
    211 
    +  | IndClosure
    212 
    +        { info       :: !StgInfoTable
    213 
    +        , indirectee :: !b              -- ^ Target closure
    214 
    +        }
    215 
    +
    216 
    +   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
    217 
    +   -- interpreter (e.g. as used by GHCi)
    218 
    +  | BCOClosure
    219 
    +        { info       :: !StgInfoTable
    220 
    +        , instrs     :: !b              -- ^ A pointer to an ArrWords
    221 
    +                                        --   of instructions
    222 
    +        , literals   :: !b              -- ^ A pointer to an ArrWords
    223 
    +                                        --   of literals
    224 
    +        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
    225 
    +                                        --   of byte code objects
    226 
    +        , arity      :: !HalfWord       -- ^ The arity of this BCO
    227 
    +        , size       :: !HalfWord       -- ^ The size of this BCO in words
    228 
    +        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
    229 
    +                                        --   pointerhood of its args/free vars
    230 
    +        }
    231 
    +
    232 
    +    -- | A thunk under evaluation by another thread
    233 
    +  | BlackholeClosure
    234 
    +        { info       :: !StgInfoTable
    235 
    +        , indirectee :: !b              -- ^ The target closure
    236 
    +        }
    237 
    +
    238 
    +    -- | A @ByteArray#@
    239 
    +  | ArrWordsClosure
    240 
    +        { info       :: !StgInfoTable
    241 
    +        , bytes      :: !Word           -- ^ Size of array in bytes
    242 
    +        , arrWords   :: ![Word]         -- ^ Array payload
    243 
    +        }
    244 
    +
    245 
    +    -- | A @MutableByteArray#@
    246 
    +  | MutArrClosure
    247 
    +        { info       :: !StgInfoTable
    248 
    +        , mccPtrs    :: !Word           -- ^ Number of pointers
    249 
    +        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
    250 
    +        , mccPayload :: ![b]            -- ^ Array payload
    251 
    +        -- Card table ignored
    252 
    +        }
    253 
    +
    254 
    +    -- | A @SmallMutableArray#@
    255 
    +    --
    256 
    +    -- @since 8.10.1
    257 
    +  | SmallMutArrClosure
    258 
    +        { info       :: !StgInfoTable
    259 
    +        , mccPtrs    :: !Word           -- ^ Number of pointers
    260 
    +        , mccPayload :: ![b]            -- ^ Array payload
    261 
    +        }
    262 
    +
    263 
    +  -- | An @MVar#@, with a queue of thread state objects blocking on them
    264 
    +  | MVarClosure
    265 
    +    { info       :: !StgInfoTable
    266 
    +    , queueHead  :: !b              -- ^ Pointer to head of queue
    267 
    +    , queueTail  :: !b              -- ^ Pointer to tail of queue
    268 
    +    , value      :: !b              -- ^ Pointer to closure
    269 
    +    }
    270 
    +
    271 
    +    -- | An @IOPort#@, with a queue of thread state objects blocking on them
    272 
    +  | IOPortClosure
    273 
    +        { info       :: !StgInfoTable
    274 
    +        , queueHead  :: !b              -- ^ Pointer to head of queue
    275 
    +        , queueTail  :: !b              -- ^ Pointer to tail of queue
    276 
    +        , value      :: !b              -- ^ Pointer to closure
    277 
    +        }
    278 
    +
    279 
    +    -- | A @MutVar#@
    280 
    +  | MutVarClosure
    281 
    +        { info       :: !StgInfoTable
    282 
    +        , var        :: !b              -- ^ Pointer to contents
    283 
    +        }
    284 
    +
    285 
    +    -- | An STM blocking queue.
    286 
    +  | BlockingQueueClosure
    287 
    +        { info       :: !StgInfoTable
    288 
    +        , link       :: !b              -- ^ ?? Here so it looks like an IND
    289 
    +        , blackHole  :: !b              -- ^ The blackhole closure
    290 
    +        , owner      :: !b              -- ^ The owning thread state object
    291 
    +        , queue      :: !b              -- ^ ??
    292 
    +        }
    293 
    +
    294 
    +  | WeakClosure
    295 
    +        { info        :: !StgInfoTable
    296 
    +        , cfinalizers :: !b
    297 
    +        , key         :: !b
    298 
    +        , value       :: !b
    299 
    +        , finalizer   :: !b
    300 
    +        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability
    301 
    +        }
    302 
    +
    303 
    +  -- | Representation of StgTSO: A Thread State Object. The values for
    304 
    +  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.
    305 
    +  | TSOClosure
    306 
    +      { info                :: !StgInfoTable
    307 
    +      -- pointers
    308 
    +      , link                :: !b
    309 
    +      , global_link         :: !b
    310 
    +      , tsoStack            :: !b -- ^ stackobj from StgTSO
    311 
    +      , trec                :: !b
    312 
    +      , blocked_exceptions  :: !b
    313 
    +      , bq                  :: !b
    314 
    +      , thread_label        :: !(Maybe b)
    315 
    +      -- values
    316 
    +      , what_next           :: !WhatNext
    317 
    +      , why_blocked         :: !WhyBlocked
    318 
    +      , flags               :: ![TsoFlags]
    319 
    +      , threadId            :: !Word64
    320 
    +      , saved_errno         :: !Word32
    321 
    +      , tso_dirty           :: !Word32 -- ^ non-zero => dirty
    322 
    +      , alloc_limit         :: !Int64
    323 
    +      , tot_stack_size      :: !Word32
    324 
    +      , prof                :: !(Maybe StgTSOProfInfo)
    325 
    +      }
    326 
    +
    327 
    +  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.
    328 
    +  | StackClosure
    329 
    +      { info            :: !StgInfoTable
    330 
    +      , stack_size      :: !Word32 -- ^ stack size in *words*
    331 
    +      , stack_dirty     :: !Word8 -- ^ non-zero => dirty
    332 
    +      , stack_marking   :: !Word8
    333 
    +      }
    334 
    +
    335 
    +    ------------------------------------------------------------
    336 
    +    -- Unboxed unlifted closures
    337 
    +
    338 
    +    -- | Primitive Int
    339 
    +  | IntClosure
    340 
    +        { ptipe      :: PrimType
    341 
    +        , intVal     :: !Int }
    342 
    +
    343 
    +    -- | Primitive Word
    344 
    +  | WordClosure
    345 
    +        { ptipe      :: PrimType
    346 
    +        , wordVal    :: !Word }
    347 
    +
    348 
    +    -- | Primitive Int64
    349 
    +  | Int64Closure
    350 
    +        { ptipe      :: PrimType
    351 
    +        , int64Val   :: !Int64 }
    352 
    +
    353 
    +    -- | Primitive Word64
    354 
    +  | Word64Closure
    355 
    +        { ptipe      :: PrimType
    356 
    +        , word64Val  :: !Word64 }
    357 
    +
    358 
    +    -- | Primitive Addr
    359 
    +  | AddrClosure
    360 
    +        { ptipe      :: PrimType
    361 
    +        , addrVal    :: !(Ptr ()) }
    362 
    +
    363 
    +    -- | Primitive Float
    364 
    +  | FloatClosure
    365 
    +        { ptipe      :: PrimType
    366 
    +        , floatVal   :: !Float }
    367 
    +
    368 
    +    -- | Primitive Double
    369 
    +  | DoubleClosure
    370 
    +        { ptipe      :: PrimType
    371 
    +        , doubleVal  :: !Double }
    372 
    +
    373 
    +    -----------------------------------------------------------
    374 
    +    -- Anything else
    375 
    +
    376 
    +    -- | Another kind of closure
    377 
    +  | OtherClosure
    378 
    +        { info       :: !StgInfoTable
    379 
    +        , hvalues    :: ![b]
    380 
    +        , rawWords   :: ![Word]
    381 
    +        }
    382 
    +
    383 
    +  | UnsupportedClosure
    384 
    +        { info       :: !StgInfoTable
    385 
    +        }
    386 
    +
    387 
    +    -- | A primitive word from a bitmap encoded stack frame payload
    388 
    +    --
    389 
    +    -- The type itself cannot be restored (i.e. it might represent a Word8#
    390 
    +    -- or an Int#).
    391 
    +  |  UnknownTypeWordSizedPrimitive
    392 
    +        { wordVal :: !Word }
    393 
    +  deriving (Show, Generic, Functor, Foldable, Traversable)
    394 
    +
    395 
    +-- | Get the info table for a heap closure, or Nothing for a prim value
    396 
    +--
    397 
    +-- @since 9.14.1
    398 
    +getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable
    399 
    +{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box
    400 
    +getClosureInfoTbl_maybe closure = case closure of
    401 
    +  ConstrClosure{info} ->Just info
    402 
    +  FunClosure{info} ->Just info
    403 
    +  ThunkClosure{info} ->Just info
    404 
    +  SelectorClosure{info} ->Just info
    405 
    +  PAPClosure{info} ->Just info
    406 
    +  APClosure{info} ->Just info
    407 
    +  APStackClosure{info} ->Just info
    408 
    +  IndClosure{info} ->Just info
    409 
    +  BCOClosure{info} ->Just info
    410 
    +  BlackholeClosure{info} ->Just info
    411 
    +  ArrWordsClosure{info} ->Just info
    412 
    +  MutArrClosure{info} ->Just info
    413 
    +  SmallMutArrClosure{info} ->Just info
    414 
    +  MVarClosure{info} ->Just info
    415 
    +  IOPortClosure{info} ->Just info
    416 
    +  MutVarClosure{info} ->Just info
    417 
    +  BlockingQueueClosure{info} ->Just info
    418 
    +  WeakClosure{info} ->Just info
    419 
    +  TSOClosure{info} ->Just info
    420 
    +  StackClosure{info} ->Just info
    421 
    +
    422 
    +  IntClosure{} -> Nothing
    423 
    +  WordClosure{} -> Nothing
    424 
    +  Int64Closure{} -> Nothing
    425 
    +  Word64Closure{} -> Nothing
    426 
    +  AddrClosure{} -> Nothing
    427 
    +  FloatClosure{} -> Nothing
    428 
    +  DoubleClosure{} -> Nothing
    429 
    +
    430 
    +  OtherClosure{info} -> Just info
    431 
    +  UnsupportedClosure {info} -> Just info
    432 
    +
    433 
    +  UnknownTypeWordSizedPrimitive{} -> Nothing
    434 
    +
    435 
    +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
    436 
    +-- heap closure.
    437 
    +--
    438 
    +-- @since 9.14.1
    439 
    +getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable
    440 
    +getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of
    441 
    +  Just info -> info
    442 
    +  Nothing -> error "getClosureInfoTbl - Closure without info table"
    443 
    +
    444 
    +-- | Get the info table for a heap closure, or Nothing for a prim value
    445 
    +--
    446 
    +-- @since 9.14.1
    447 
    +getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b]
    448 
    +{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box
    449 
    +getClosurePtrArgs_maybe closure = case closure of
    450 
    +  ConstrClosure{ptrArgs} -> Just ptrArgs
    451 
    +  FunClosure{ptrArgs} -> Just ptrArgs
    452 
    +  ThunkClosure{ptrArgs} -> Just ptrArgs
    453 
    +  SelectorClosure{} -> Nothing
    454 
    +  PAPClosure{} -> Nothing
    455 
    +  APClosure{} -> Nothing
    456 
    +  APStackClosure{} -> Nothing
    457 
    +  IndClosure{} -> Nothing
    458 
    +  BCOClosure{} -> Nothing
    459 
    +  BlackholeClosure{} -> Nothing
    460 
    +  ArrWordsClosure{} -> Nothing
    461 
    +  MutArrClosure{} -> Nothing
    462 
    +  SmallMutArrClosure{} -> Nothing
    463 
    +  MVarClosure{} -> Nothing
    464 
    +  IOPortClosure{} -> Nothing
    465 
    +  MutVarClosure{} -> Nothing
    466 
    +  BlockingQueueClosure{} -> Nothing
    467 
    +  WeakClosure{} -> Nothing
    468 
    +  TSOClosure{} -> Nothing
    469 
    +  StackClosure{} -> Nothing
    470 
    +
    471 
    +  IntClosure{} -> Nothing
    472 
    +  WordClosure{} -> Nothing
    473 
    +  Int64Closure{} -> Nothing
    474 
    +  Word64Closure{} -> Nothing
    475 
    +  AddrClosure{} -> Nothing
    476 
    +  FloatClosure{} -> Nothing
    477 
    +  DoubleClosure{} -> Nothing
    478 
    +
    479 
    +  OtherClosure{} -> Nothing
    480 
    +  UnsupportedClosure{} -> Nothing
    481 
    +
    482 
    +  UnknownTypeWordSizedPrimitive{} -> Nothing
    483 
    +
    484 
    +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
    485 
    +-- heap closure.
    486 
    +--
    487 
    +-- @since 9.14.1
    488 
    +getClosurePtrArgs :: HasCallStack => GenClosure b -> [b]
    489 
    +getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of
    490 
    +  Just ptrs -> ptrs
    491 
    +  Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field"
    492 
    +
    493 
    +type StgStackClosure = GenStgStackClosure Box
    494 
    +
    495 
    +-- | A decoded @StgStack@ with `StackFrame`s
    496 
    +--
    497 
    +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,
    498 
    +-- `GenStackFrame`) are defined separately from `GenClosure` as their related
    499 
    +-- functions are very different. Though, both are closures in the sense of RTS
    500 
    +-- structures, their decoding logic differs: While it's safe to keep a reference
    501 
    +-- to a heap closure, the garbage collector does not update references to stack
    502 
    +-- located closures.
    503 
    +--
    504 
    +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping
    505 
    +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise
    506 
    +-- (in the sense what values to expect.)
    507 
    +data GenStgStackClosure b = GenStgStackClosure
    508 
    +      { ssc_info            :: !StgInfoTable
    509 
    +      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*
    510 
    +      , ssc_stack           :: ![GenStackFrame b]
    511 
    +      }
    512 
    +  deriving (Foldable, Functor, Generic, Show, Traversable)
    513 
    +
    514 
    +type StackField = GenStackField Box
    515 
    +
    516 
    +-- | Bitmap-encoded payload on the stack
    517 
    +data GenStackField b
    518 
    +    -- | A non-pointer field
    519 
    +    = StackWord !Word
    520 
    +    -- | A pointer field
    521 
    +    | StackBox  !b
    522 
    +  deriving (Foldable, Functor, Generic, Show, Traversable)
    523 
    +
    524 
    +type StackFrame = GenStackFrame Box
    525 
    +
    526 
    +-- | A single stack frame
    527 
    +data GenStackFrame b =
    528 
    +   UpdateFrame
    529 
    +      { info_tbl           :: !StgInfoTable
    530 
    +      , updatee            :: !b
    531 
    +      }
    532 
    +
    533 
    +  | CatchFrame
    534 
    +      { info_tbl            :: !StgInfoTable
    535 
    +      , handler             :: !b
    536 
    +      }
    537 
    +
    538 
    +  | CatchStmFrame
    539 
    +      { info_tbl            :: !StgInfoTable
    540 
    +      , catchFrameCode      :: !b
    541 
    +      , handler             :: !b
    542 
    +      }
    543 
    +
    544 
    +  | CatchRetryFrame
    545 
    +      { info_tbl            :: !StgInfoTable
    546 
    +      , running_alt_code    :: !Word
    547 
    +      , first_code          :: !b
    548 
    +      , alt_code            :: !b
    549 
    +      }
    550 
    +
    551 
    +  | AtomicallyFrame
    552 
    +      { info_tbl            :: !StgInfoTable
    553 
    +      , atomicallyFrameCode :: !b
    554 
    +      , result              :: !b
    555 
    +      }
    556 
    +
    557 
    +  | UnderflowFrame
    558 
    +      { info_tbl            :: !StgInfoTable
    559 
    +      , nextChunk           :: !(GenStgStackClosure b)
    560 
    +      }
    561 
    +
    562 
    +  | StopFrame
    563 
    +      { info_tbl            :: !StgInfoTable }
    564 
    +
    565 
    +  | RetSmall
    566 
    +      { info_tbl            :: !StgInfoTable
    567 
    +      , stack_payload       :: ![GenStackField b]
    568 
    +      }
    569 
    +
    570 
    +  | RetBig
    571 
    +      { info_tbl            :: !StgInfoTable
    572 
    +      , stack_payload       :: ![GenStackField b]
    573 
    +      }
    574 
    +
    575 
    +  | RetFun
    576 
    +      { info_tbl            :: !StgInfoTable
    577 
    +      , retFunSize          :: !Word
    578 
    +      , retFunFun           :: !b
    579 
    +      , retFunPayload       :: ![GenStackField b]
    580 
    +      }
    581 
    +
    582 
    +  | RetBCO
    583 
    +      { info_tbl            :: !StgInfoTable
    584 
    +      , bco                 :: !b -- ^ always a BCOClosure
    585 
    +      , bcoArgs             :: ![GenStackField b]
    586 
    +      }
    587 
    +  | AnnFrame
    588 
    +      { info_tbl            :: !StgInfoTable
    589 
    +      , annotation          :: !b
    590 
    +      }
    591 
    +  deriving (Foldable, Functor, Generic, Show, Traversable)
    592 
    +
    593 
    +data PrimType
    594 
    +  = PInt
    595 
    +  | PWord
    596 
    +  | PInt64
    597 
    +  | PWord64
    598 
    +  | PAddr
    599 
    +  | PFloat
    600 
    +  | PDouble
    601 
    +  deriving (Eq, Show, Generic, Ord)
    602 
    +
    603 
    +data WhatNext
    604 
    +  = ThreadRunGHC
    605 
    +  | ThreadInterpret
    606 
    +  | ThreadKilled
    607 
    +  | ThreadComplete
    608 
    +  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug
    609 
    +  deriving (Eq, Show, Generic, Ord)
    610 
    +
    611 
    +data WhyBlocked
    612 
    +  = NotBlocked
    613 
    +  | BlockedOnMVar
    614 
    +  | BlockedOnMVarRead
    615 
    +  | BlockedOnBlackHole
    616 
    +  | BlockedOnRead
    617 
    +  | BlockedOnWrite
    618 
    +  | BlockedOnDelay
    619 
    +  | BlockedOnSTM
    620 
    +  | BlockedOnDoProc
    621 
    +  | BlockedOnCCall
    622 
    +  | BlockedOnCCall_Interruptible
    623 
    +  | BlockedOnMsgThrowTo
    624 
    +  | ThreadMigrating
    625 
    +  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
    626 
    +  deriving (Eq, Show, Generic, Ord)
    627 
    +
    628 
    +data TsoFlags
    629 
    +  = TsoLocked
    630 
    +  | TsoBlockx
    631 
    +  | TsoInterruptible
    632 
    +  | TsoStoppedOnBreakpoint
    633 
    +  | TsoMarked
    634 
    +  | TsoSqueezed
    635 
    +  | TsoAllocLimit
    636 
    +  | TsoStopNextBreakpoint
    637 
    +  | TsoStopAfterReturn
    638 
    +  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
    639 
    +  deriving (Eq, Show, Generic, Ord)
    640 
    +
    641 
    +-- | For generic code, this function returns all referenced closures.
    642 
    +allClosures :: GenClosure b -> [b]
    643 
    +allClosures (ConstrClosure {..}) = ptrArgs
    644 
    +allClosures (ThunkClosure {..}) = ptrArgs
    645 
    +allClosures (SelectorClosure {..}) = [selectee]
    646 
    +allClosures (IndClosure {..}) = [indirectee]
    647 
    +allClosures (BlackholeClosure {..}) = [indirectee]
    648 
    +allClosures (APClosure {..}) = fun:payload
    649 
    +allClosures (PAPClosure {..}) = fun:payload
    650 
    +allClosures (APStackClosure {..}) = fun:payload
    651 
    +allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
    652 
    +allClosures (ArrWordsClosure {}) = []
    653 
    +allClosures (MutArrClosure {..}) = mccPayload
    654 
    +allClosures (SmallMutArrClosure {..}) = mccPayload
    655 
    +allClosures (MutVarClosure {..}) = [var]
    656 
    +allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
    657 
    +allClosures (IOPortClosure {..}) = [queueHead,queueTail,value]
    658 
    +allClosures (FunClosure {..}) = ptrArgs
    659 
    +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
    660 
    +allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink
    661 
    +allClosures (OtherClosure {..}) = hvalues
    662 
    +allClosures _ = []
    663 
    +
    664 
    +-- | Get the size of the top-level closure in words.
    665 
    +-- Includes header and payload. Does not follow pointers.
    666 
    +--
    667 
    +-- @since 8.10.1
    668 
    +closureSize :: Box -> Int
    669 
    +closureSize (Box x) = I# (closureSize# x)

  • libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +
    3 
    +module GHC.Internal.Heap.Constants
    4 
    +    ( wORD_SIZE
    5 
    +    , tAG_MASK
    6 
    +    , wORD_SIZE_IN_BITS
    7 
    +    ) where
    8 
    +
    9 
    +#include "MachDeps.h"
    10 
    +
    11 
    +import GHC.Internal.Data.Bits
    12 
    +import GHC.Internal.Int
    13 
    +import GHC.Internal.Num
    14 
    +
    15 
    +wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int
    16 
    +wORD_SIZE = #const SIZEOF_HSWORD
    17 
    +wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS
    18 
    +tAG_MASK = (1 `shift` #const TAG_BITS) - 1

  • libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
    1 
    +module GHC.Internal.Heap.InfoTable
    2 
    +    ( module GHC.Internal.Heap.InfoTable.Types
    3 
    +    , itblSize
    4 
    +    , peekItbl
    5 
    +    , pokeItbl
    6 
    +    ) where
    7 
    +
    8 
    +#include "Rts.h"
    9 
    +
    10 
    +import GHC.Internal.Base
    11 
    +import GHC.Internal.Data.Either
    12 
    +import GHC.Internal.Real
    13 
    +import GHC.Internal.Enum
    14 
    +
    15 
    +import GHC.Internal.Heap.InfoTable.Types
    16 
    +#if !defined(TABLES_NEXT_TO_CODE)
    17 
    +import GHC.Internal.Heap.Constants
    18 
    +import GHC.Internal.Data.Maybe
    19 
    +#endif
    20 
    +import GHC.Internal.Foreign.Ptr
    21 
    +import GHC.Internal.Foreign.Storable
    22 
    +import GHC.Internal.Foreign.Marshal.Array
    23 
    +
    24 
    +-------------------------------------------------------------------------
    25 
    +-- Profiling specific code
    26 
    +--
    27 
    +-- The functions that follow all rely on PROFILING. They are duplicated in
    28 
    +-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This
    29 
    +-- allows hsc2hs to generate values for both profiling and non-profiling builds.
    30 
    +
    31 
    +-- | Read an InfoTable from the heap into a haskell type.
    32 
    +-- WARNING: This code assumes it is passed a pointer to a "standard" info
    33 
    +-- table. If tables_next_to_code is disabled, it will look 1 word before the
    34 
    +-- start for the entry field.
    35 
    +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
    36 
    +peekItbl a0 = do
    37 
    +#if !defined(TABLES_NEXT_TO_CODE)
    38 
    +  let ptr = a0 `plusPtr` (negate wORD_SIZE)
    39 
    +  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
    40 
    +#else
    41 
    +  let ptr = a0
    42 
    +      entry' = Nothing
    43 
    +#endif
    44 
    +  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
    45 
    +  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
    46 
    +  tipe'   <- (#peek struct StgInfoTable_, type) ptr
    47 
    +  srtlen' <- (#peek struct StgInfoTable_, srt) a0
    48 
    +  return StgInfoTable
    49 
    +    { entry  = entry'
    50 
    +    , ptrs   = ptrs'
    51 
    +    , nptrs  = nptrs'
    52 
    +    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
    53 
    +    , srtlen = srtlen'
    54 
    +    , code   = Nothing
    55 
    +    }
    56 
    +
    57 
    +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
    58 
    +pokeItbl a0 itbl = do
    59 
    +#if !defined(TABLES_NEXT_TO_CODE)
    60 
    +  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
    61 
    +#endif
    62 
    +  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
    63 
    +  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
    64 
    +  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))
    65 
    +  (#poke StgInfoTable, srt) a0 (srtlen itbl)
    66 
    +#if defined(TABLES_NEXT_TO_CODE)
    67 
    +  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
    68 
    +  case code itbl of
    69 
    +    Nothing -> return ()
    70 
    +    Just (Left xs) -> pokeArray code_offset xs
    71 
    +    Just (Right xs) -> pokeArray code_offset xs
    72 
    +#endif
    73 
    +  where
    74 
    +    toHalfWord :: Int -> HalfWord
    75 
    +    toHalfWord i = fromIntegral i
    76 
    +
    77 
    +-- | Size in bytes of a standard InfoTable
    78 
    +itblSize :: Int
    79 
    +itblSize = (#size struct StgInfoTable_)

  • libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
    1 
    +{-# LANGUAGE DeriveGeneric #-}
    2 
    +{-# LANGUAGE DerivingStrategies #-}
    3 
    +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
    4 
    +
    5 
    +module GHC.Internal.Heap.InfoTable.Types
    6 
    +    ( StgInfoTable(..)
    7 
    +    , EntryFunPtr
    8 
    +    , HalfWord(..)
    9 
    +    , ItblCodes
    10 
    +    ) where
    11 
    +
    12 
    +#include "Rts.h"
    13 
    +
    14 
    +import GHC.Internal.Base
    15 
    +import GHC.Internal.Generics
    16 
    +import GHC.Internal.ClosureTypes
    17 
    +import GHC.Internal.Foreign.Ptr
    18 
    +import GHC.Internal.Foreign.Storable
    19 
    +import GHC.Internal.Enum
    20 
    +import GHC.Internal.Num
    21 
    +import GHC.Internal.Word
    22 
    +import GHC.Internal.Show
    23 
    +import GHC.Internal.Real
    24 
    +import GHC.Internal.Data.Either
    25 
    +
    26 
    +type ItblCodes = Either [Word8] [Word32]
    27 
    +
    28 
    +#include "ghcautoconf.h"
    29 
    +-- Ultra-minimalist version specially for constructors
    30 
    +#if SIZEOF_VOID_P == 8
    31 
    +type HalfWord' = Word32
    32 
    +#elif SIZEOF_VOID_P == 4
    33 
    +type HalfWord' = Word16
    34 
    +#else
    35 
    +#error Unknown SIZEOF_VOID_P
    36 
    +#endif
    37 
    +
    38 
    +newtype HalfWord = HalfWord HalfWord'
    39 
    +    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)
    40 
    +
    41 
    +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
    42 
    +
    43 
    +-- | This is a somewhat faithful representation of an info table. See
    44 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h>
    45 
    +-- for more details on this data structure.
    46 
    +data StgInfoTable = StgInfoTable {
    47 
    +   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
    48 
    +   ptrs   :: HalfWord,
    49 
    +   nptrs  :: HalfWord,
    50 
    +   tipe   :: ClosureType,
    51 
    +   srtlen :: HalfWord,
    52 
    +   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
    53 
    +  } deriving (Eq, Show, Generic)

  • libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
    1 
    +module GHC.Internal.Heap.InfoTableProf
    2 
    +    ( module GHC.Internal.Heap.InfoTable.Types
    3 
    +    , itblSize
    4 
    +    , peekItbl
    5 
    +    , pokeItbl
    6 
    +    ) where
    7 
    +
    8 
    +-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.
    9 
    +-- Manually defining PROFILING gives the #peek and #poke macros an accurate
    10 
    +-- representation of StgInfoTable_ when hsc2hs runs.
    11 
    +#define PROFILING
    12 
    +#include "Rts.h"
    13 
    +
    14 
    +import GHC.Internal.Base
    15 
    +import GHC.Internal.Data.Either
    16 
    +import GHC.Internal.Real
    17 
    +import GHC.Internal.Enum
    18 
    +
    19 
    +import GHC.Internal.Heap.InfoTable.Types
    20 
    +#if !defined(TABLES_NEXT_TO_CODE)
    21 
    +import GHC.Internal.Heap.Constants
    22 
    +import GHC.Internal.Data.Maybe
    23 
    +#endif
    24 
    +import GHC.Internal.Foreign.Ptr
    25 
    +import GHC.Internal.Foreign.Storable
    26 
    +import GHC.Internal.Foreign.Marshal.Array
    27 
    +
    28 
    +-- | Read an InfoTable from the heap into a haskell type.
    29 
    +-- WARNING: This code assumes it is passed a pointer to a "standard" info
    30 
    +-- table. If tables_next_to_code is enabled, it will look 1 byte before the
    31 
    +-- start for the entry field.
    32 
    +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
    33 
    +peekItbl a0 = do
    34 
    +#if !defined(TABLES_NEXT_TO_CODE)
    35 
    +  let ptr = a0 `plusPtr` (negate wORD_SIZE)
    36 
    +  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
    37 
    +#else
    38 
    +  let ptr = a0
    39 
    +      entry' = Nothing
    40 
    +#endif
    41 
    +  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
    42 
    +  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
    43 
    +  tipe'   <- (#peek struct StgInfoTable_, type) ptr
    44 
    +  srtlen' <- (#peek struct StgInfoTable_, srt) a0
    45 
    +  return StgInfoTable
    46 
    +    { entry  = entry'
    47 
    +    , ptrs   = ptrs'
    48 
    +    , nptrs  = nptrs'
    49 
    +    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
    50 
    +    , srtlen = srtlen'
    51 
    +    , code   = Nothing
    52 
    +    }
    53 
    +
    54 
    +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
    55 
    +pokeItbl a0 itbl = do
    56 
    +#if !defined(TABLES_NEXT_TO_CODE)
    57 
    +  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
    58 
    +#endif
    59 
    +  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
    60 
    +  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
    61 
    +  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
    62 
    +  (#poke StgInfoTable, srt) a0 (srtlen itbl)
    63 
    +#if defined(TABLES_NEXT_TO_CODE)
    64 
    +  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
    65 
    +  case code itbl of
    66 
    +    Nothing -> return ()
    67 
    +    Just (Left xs) -> pokeArray code_offset xs
    68 
    +    Just (Right xs) -> pokeArray code_offset xs
    69 
    +#endif
    70 
    +
    71 
    +itblSize :: Int
    72 
    +itblSize = (#size struct StgInfoTable_)

  • libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
    1 
    +{-# LANGUAGE DeriveGeneric #-}
    2 
    +
    3 
    +module GHC.Internal.Heap.ProfInfo.Types where
    4 
    +
    5 
    +import GHC.Internal.Base
    6 
    +import GHC.Internal.Word
    7 
    +import GHC.Internal.Generics
    8 
    +import GHC.Internal.Show
    9 
    +
    10 
    +-- | This is a somewhat faithful representation of StgTSOProfInfo. See
    11 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h>
    12 
    +-- for more details on this data structure.
    13 
    +newtype StgTSOProfInfo = StgTSOProfInfo {
    14 
    +    cccs :: Maybe CostCentreStack
    15 
    +} deriving (Show, Generic, Eq, Ord)
    16 
    +
    17 
    +-- | This is a somewhat faithful representation of CostCentreStack. See
    18 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
    19 
    +-- for more details on this data structure.
    20 
    +data CostCentreStack = CostCentreStack {
    21 
    +    ccs_ccsID :: Int,
    22 
    +    ccs_cc :: CostCentre,
    23 
    +    ccs_prevStack :: Maybe CostCentreStack,
    24 
    +    ccs_indexTable :: Maybe IndexTable,
    25 
    +    ccs_root :: Maybe CostCentreStack,
    26 
    +    ccs_depth :: Word,
    27 
    +    ccs_scc_count :: Word64,
    28 
    +    ccs_selected :: Word,
    29 
    +    ccs_time_ticks :: Word,
    30 
    +    ccs_mem_alloc :: Word64,
    31 
    +    ccs_inherited_alloc :: Word64,
    32 
    +    ccs_inherited_ticks :: Word
    33 
    +} deriving (Show, Generic, Eq, Ord)
    34 
    +
    35 
    +-- | This is a somewhat faithful representation of CostCentre. See
    36 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
    37 
    +-- for more details on this data structure.
    38 
    +data CostCentre = CostCentre {
    39 
    +    cc_ccID :: Int,
    40 
    +    cc_label :: String,
    41 
    +    cc_module :: String,
    42 
    +    cc_srcloc :: Maybe String,
    43 
    +    cc_mem_alloc :: Word64,
    44 
    +    cc_time_ticks :: Word,
    45 
    +    cc_is_caf :: Bool,
    46 
    +    cc_link :: Maybe CostCentre
    47 
    +} deriving (Show, Generic, Eq, Ord)
    48 
    +
    49 
    +-- | This is a somewhat faithful representation of IndexTable. See
    50 
    +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
    51 
    +-- for more details on this data structure.
    52 
    +data IndexTable = IndexTable {
    53 
    +    it_cc :: CostCentre,
    54 
    +    it_ccs :: Maybe CostCentreStack,
    55 
    +    it_next :: Maybe IndexTable,
    56 
    +    it_back_edge :: Bool
    57 
    +} deriving (Show, Generic, Eq, Ord)

  • libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
    1 
    +{-# LANGUAGE GADTs #-}
    2 
    +{-# LANGUAGE ScopedTypeVariables #-}
    3 
    +module GHC.Internal.Stack.Annotation (
    4 
    +  IsStackAnnotation(..),
    5 
    +  SomeStackAnnotation(..),
    6 
    +  )
    7 
    +  where
    8 
    +
    9 
    +import GHC.Internal.Base
    10 
    +import GHC.Internal.Data.Typeable
    11 
    +
    12 
    +-- ----------------------------------------------------------------------------
    13 
    +-- IsStackAnnotation
    14 
    +-- ----------------------------------------------------------------------------
    15 
    +
    16 
    +class IsStackAnnotation a where
    17 
    +  displayStackAnnotation :: a -> String
    18 
    +
    19 
    +-- ----------------------------------------------------------------------------
    20 
    +-- Annotations
    21 
    +-- ----------------------------------------------------------------------------
    22 
    +
    23 
    +{- |
    24 
    +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
    25 
    +When the call stack is annotated with a value of type @a@, behind the scenes it is
    26 
    +encapsulated in a @SomeStackAnnotation@.
    27 
    +-}
    28 
    +data SomeStackAnnotation where
    29 
    +  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
    30 
    +
    31 
    +instance IsStackAnnotation SomeStackAnnotation where
    32 
    +  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a

  • libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
    ... ... @@ -18,8 +18,8 @@ module GHC.Internal.Stack.CloneStack (
    18 18 
       StackEntry(..),
    19 19 
       cloneMyStack,
    20 20 
       cloneThreadStack,
    21 
    -  decode,
    22 
    -  prettyStackEntry
    21 
    +  decode, -- TODO @fendor: deprecate
    22 
    +  toStackEntry, -- TODO @fendor: deprecate
    23 23 
       ) where
    24 24
    25 25 
     import GHC.Internal.MVar
    ... ... @@ -40,7 +40,7 @@ import GHC.Internal.ClosureTypes
    40 40 
     --
    41 41 
     -- @since base-4.17.0.0
    42 42 
     data StackSnapshot = StackSnapshot !StackSnapshot#
    43 
    -
    43 
    +-- TODO @fendor: deprecate
    44 44 
     foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
    45 45
    46 46 
     foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
    ... ... @@ -208,6 +208,7 @@ cloneThreadStack (ThreadId tid#) = do
    208 208
    209 209 
     -- | Representation for the source location where a return frame was pushed on the stack.
    210 210 
     -- This happens every time when a @case ... of@ scrutinee is evaluated.
    211 
    +-- TODO @fendor: deprecate
    211 212 
     data StackEntry = StackEntry
    212 213 
       { functionName :: String,
    213 214 
         moduleName :: String,
    ... ... @@ -232,9 +233,11 @@ data StackEntry = StackEntry
    232 233 
     --     is evaluated.)
    233 234 
     --
    234 235 
     -- @since base-4.17.0.0
    236 
    +-- TODO @fendor: deprecate
    235 237 
     decode :: StackSnapshot -> IO [StackEntry]
    236 238 
     decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot
    237 239
    240 
    +-- TODO @fendor: deprecate
    238 241 
     toStackEntry :: InfoProv -> StackEntry
    239 242 
     toStackEntry infoProv =
    240 243 
       StackEntry
    ... ... @@ -244,6 +247,7 @@ toStackEntry infoProv =
    244 247 
         closureType = ipDesc infoProv
    245 248 
       }
    246 249
    250 
    +-- TODO @fendor: deprecate
    247 251 
     getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
    248 252 
     getDecodedStackArray (StackSnapshot s) =
    249 253 
       IO $ \s0 -> case decodeStack# s s0 of
    ... ... @@ -263,6 +267,7 @@ getDecodedStackArray (StackSnapshot s) =
    263 267
    264 268 
         wordSize = sizeOf (nullPtr :: Ptr ())
    265 269
    270 
    +-- TODO @fendor: deprecate
    266 271 
     prettyStackEntry :: StackEntry -> String
    267 272 
     prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
    268 273 
         "  " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"

  • libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +{-# LANGUAGE DerivingStrategies #-}
    3 
    +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
    4 
    +module GHC.Internal.Stack.Constants where
    5 
    +
    6 
    +import GHC.Internal.Base
    7 
    +import GHC.Internal.Enum
    8 
    +import GHC.Internal.Num
    9 
    +import GHC.Internal.Show
    10 
    +import GHC.Internal.Real
    11 
    +
    12 
    +#include "Rts.h"
    13 
    +#undef BLOCK_SIZE
    14 
    +#undef MBLOCK_SIZE
    15 
    +#undef BLOCKS_PER_MBLOCK
    16 
    +#include "DerivedConstants.h"
    17 
    +
    18 
    +newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
    19 
    +  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
    20 
    +
    21 
    +newtype WordOffset = WordOffset { offsetInWords :: Int }
    22 
    +  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
    23 
    +
    24 
    +offsetStgCatchFrameHandler :: WordOffset
    25 
    +offsetStgCatchFrameHandler = byteOffsetToWordOffset $
    26 
    +  (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
    27 
    +
    28 
    +sizeStgCatchFrame :: Int
    29 
    +sizeStgCatchFrame = bytesToWords $
    30 
    +  (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
    31 
    +
    32 
    +offsetStgCatchSTMFrameCode :: WordOffset
    33 
    +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $
    34 
    +  (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
    35 
    +
    36 
    +offsetStgCatchSTMFrameHandler :: WordOffset
    37 
    +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $
    38 
    +  (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
    39 
    +
    40 
    +sizeStgCatchSTMFrame :: Int
    41 
    +sizeStgCatchSTMFrame = bytesToWords $
    42 
    +  (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
    43 
    +
    44 
    +offsetStgUpdateFrameUpdatee :: WordOffset
    45 
    +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $
    46 
    +  (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
    47 
    +
    48 
    +sizeStgUpdateFrame :: Int
    49 
    +sizeStgUpdateFrame = bytesToWords $
    50 
    +  (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
    51 
    +
    52 
    +offsetStgAtomicallyFrameCode :: WordOffset
    53 
    +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $
    54 
    +  (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
    55 
    +
    56 
    +offsetStgAtomicallyFrameResult :: WordOffset
    57 
    +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $
    58 
    +  (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
    59 
    +
    60 
    +sizeStgAtomicallyFrame :: Int
    61 
    +sizeStgAtomicallyFrame = bytesToWords $
    62 
    +  (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
    63 
    +
    64 
    +offsetStgCatchRetryFrameRunningAltCode :: WordOffset
    65 
    +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $
    66 
    +  (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
    67 
    +
    68 
    +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
    69 
    +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $
    70 
    +  (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
    71 
    +
    72 
    +offsetStgCatchRetryFrameAltCode :: WordOffset
    73 
    +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $
    74 
    +  (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
    75 
    +
    76 
    +sizeStgCatchRetryFrame :: Int
    77 
    +sizeStgCatchRetryFrame = bytesToWords $
    78 
    +  (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
    79 
    +
    80 
    +offsetStgRetFunFrameSize :: WordOffset
    81 
    +-- StgRetFun has no header, but only a pointer to the info table at the beginning.
    82 
    +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size)
    83 
    +
    84 
    +offsetStgRetFunFrameFun :: WordOffset
    85 
    +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun)
    86 
    +
    87 
    +offsetStgRetFunFramePayload :: WordOffset
    88 
    +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload)
    89 
    +
    90 
    +sizeStgRetFunFrame :: Int
    91 
    +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
    92 
    +
    93 
    +sizeStgAnnFrame :: Int
    94 
    +sizeStgAnnFrame = bytesToWords $
    95 
    +  (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader)
    96 
    +
    97 
    +offsetStgAnnFrameAnn :: WordOffset
    98 
    +offsetStgAnnFrameAnn = byteOffsetToWordOffset $
    99 
    +  (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
    100 
    +
    101 
    +offsetStgBCOFrameInstrs :: ByteOffset
    102 
    +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
    103 
    +
    104 
    +offsetStgBCOFrameLiterals :: ByteOffset
    105 
    +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
    106 
    +
    107 
    +offsetStgBCOFramePtrs :: ByteOffset
    108 
    +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
    109 
    +
    110 
    +offsetStgBCOFrameArity :: ByteOffset
    111 
    +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
    112 
    +
    113 
    +offsetStgBCOFrameSize :: ByteOffset
    114 
    +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
    115 
    +
    116 
    +offsetStgClosurePayload :: WordOffset
    117 
    +offsetStgClosurePayload = byteOffsetToWordOffset $
    118 
    +  (#const OFFSET_StgClosure_payload) + (#size StgHeader)
    119 
    +
    120 
    +sizeStgClosure :: Int
    121 
    +sizeStgClosure = bytesToWords (#size StgHeader)
    122 
    +
    123 
    +byteOffsetToWordOffset :: ByteOffset -> WordOffset
    124 
    +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger
    125 
    +
    126 
    +bytesToWords :: Int -> Int
    127 
    +bytesToWords b =
    128 
    +  if b `mod` bytesInWord == 0 then
    129 
    +      fromIntegral $ b `div` bytesInWord
    130 
    +    else
    131 
    +      error "Unexpected struct alignment!"
    132 
    +
    133 
    +bytesInWord :: Int
    134 
    +bytesInWord = (#const SIZEOF_VOID_P)
    135 
    +

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +{-# LANGUAGE BangPatterns #-}
    3 
    +{-# LANGUAGE DuplicateRecordFields #-}
    4 
    +{-# LANGUAGE FlexibleInstances #-}
    5 
    +{-# LANGUAGE GHCForeignImportPrim #-}
    6 
    +{-# LANGUAGE MagicHash #-}
    7 
    +{-# LANGUAGE RankNTypes #-}
    8 
    +{-# LANGUAGE RecordWildCards #-}
    9 
    +{-# LANGUAGE ScopedTypeVariables #-}
    10 
    +{-# LANGUAGE TypeFamilies #-}
    11 
    +{-# LANGUAGE TypeInType #-}
    12 
    +{-# LANGUAGE UnboxedTuples #-}
    13 
    +{-# LANGUAGE UnliftedFFITypes #-}
    14 
    +
    15 
    +module GHC.Internal.Stack.Decode (
    16 
    +  decodeStack,
    17 
    +  decodeStackWithIpe,
    18 
    +  prettyStackFrameWithIpe,
    19 
    +  -- * StackEntry
    20 
    +  StackEntry(..),
    21 
    +  prettyStackEntry,
    22 
    +  decode,
    23 
    +  )
    24 
    +where
    25 
    +
    26 
    +import GHC.Internal.Base
    27 
    +import GHC.Internal.Show
    28 
    +import GHC.Internal.Real
    29 
    +import GHC.Internal.Word
    30 
    +import GHC.Internal.Num
    31 
    +import GHC.Internal.Data.Bits
    32 
    +import GHC.Internal.Data.Functor
    33 
    +import GHC.Internal.Data.List
    34 
    +import GHC.Internal.Data.Tuple
    35 
    +import GHC.Internal.Foreign.Ptr
    36 
    +import GHC.Internal.Foreign.Storable
    37 
    +import GHC.Internal.Exts
    38 
    +import GHC.Internal.Unsafe.Coerce
    39 
    +
    40 
    +import GHC.Internal.ClosureTypes
    41 
    +import GHC.Internal.Heap.Closures
    42 
    +  ( Box (..),
    43 
    +    StackFrame,
    44 
    +    GenStackFrame (..),
    45 
    +    StgStackClosure,
    46 
    +    GenStgStackClosure (..),
    47 
    +    StackField,
    48 
    +    GenStackField(..)
    49 
    +  )
    50 
    +import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
    51 
    +import GHC.Internal.Heap.InfoTable
    52 
    +import GHC.Internal.Stack.Annotation
    53 
    +import GHC.Internal.Stack.Constants
    54 
    +import GHC.Internal.Stack.CloneStack
    55 
    +import GHC.Internal.InfoProv.Types (InfoProv (..), lookupIPE)
    56 
    +
    57 
    +{- Note [Decoding the stack]
    58 
    +   ~~~~~~~~~~~~~~~~~~~~~~~~~
    59 
    +
    60 
    +The stack is represented by a chain of StgStack closures. Each of these closures
    61 
    +is subject to garbage collection. I.e. they can be moved in memory (in a
    62 
    +simplified perspective) at any time.
    63 
    +
    64 
    +The array of closures inside an StgStack (that makeup the execution stack; the
    65 
    +stack frames) is moved as bare memory by the garbage collector. References
    66 
    +(pointers) to stack frames are not updated by the garbage collector.
    67 
    +
    68 
    +As the StgStack closure is moved as whole, the relative offsets inside it stay
    69 
    +the same. (Though, the absolute addresses change!)
    70 
    +
    71 
    +Decoding
    72 
    +========
    73 
    +
    74 
    +Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and
    75 
    +their relative offset. This tuple is described by `StackFrameLocation`.
    76 
    +
    77 
    +`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we
    78 
    +have to deal with three cases:
    79 
    +
    80 
    +- If the payload can only be a closure, we put it in a `Box` for later decoding
    81 
    +  by the heap closure functions.
    82 
    +
    83 
    +- If the payload can either be a closure or a word-sized value (this happens for
    84 
    +  bitmap-encoded payloads), we use a `StackField` which is a sum type to
    85 
    +  represent either a `Word` or a `Box`.
    86 
    +
    87 
    +- Fields that are just simple (i.e. non-closure) values are decoded as such.
    88 
    +
    89 
    +The decoding happens in two phases:
    90 
    +
    91 
    +1. The whole stack is decoded into `StackFrameLocation`s.
    92 
    +
    93 
    +2. All `StackFrameLocation`s are decoded into `StackFrame`s.
    94 
    +
    95 
    +`StackSnapshot#` parameters are updated by the garbage collector and thus safe
    96 
    +to hand around.
    97 
    +
    98 
    +The head of the stack frame array has offset (index) 0. To traverse the stack
    99 
    +frames the latest stack frame's offset is incremented by the closure size. The
    100 
    +unit of the offset is machine words (32bit or 64bit.)
    101 
    +
    102 
    +IO
    103 
    +==
    104 
    +
    105 
    +Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames`
    106 
    +also being decoded in `IO`, due to references to `Closure`s.
    107 
    +
    108 
    +Technical details
    109 
    +=================
    110 
    +
    111 
    +- All access to StgStack/StackSnapshot# closures is made through Cmm code. This
    112 
    +  keeps the closure from being moved by the garbage collector during the
    113 
    +  operation.
    114 
    +
    115 
    +- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is
    116 
    +  implemented in Cmm and C. It's just easier to reuse existing helper macros and
    117 
    +  functions, than reinventing them in Haskell.
    118 
    +
    119 
    +- Offsets and sizes of closures are imported from DerivedConstants.h via HSC.
    120 
    +  This keeps the code very portable.
    121 
    +-}
    122 
    +
    123 
    +foreign import prim "getUnderflowFrameNextChunkzh"
    124 
    +  getUnderflowFrameNextChunk# ::
    125 
    +    StackSnapshot# -> Word# -> StackSnapshot#
    126 
    +
    127 
    +getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot
    128 
    +getUnderflowFrameNextChunk stackSnapshot# index =
    129 
    +  StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index))
    130 
    +
    131 
    +foreign import prim "getWordzh"
    132 
    +  getWord# ::
    133 
    +    StackSnapshot# -> Word# -> Word#
    134 
    +
    135 
    +getWord :: StackSnapshot# -> WordOffset -> Word
    136 
    +getWord stackSnapshot# index =
    137 
    +  W# (getWord# stackSnapshot# (wordOffsetToWord# index))
    138 
    +
    139 
    +foreign import prim "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int#
    140 
    +
    141 
    +isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool
    142 
    +isArgGenBigRetFunType stackSnapshot# index =
    143 
    +  I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0
    144 
    +
    145 
    +-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@)
    146 
    +--
    147 
    +-- The first two arguments identify the location of the frame on the stack.
    148 
    +-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size.
    149 
    +type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #)
    150 
    +
    151 
    +foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
    152 
    +
    153 
    +foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter
    154 
    +
    155 
    +foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter
    156 
    +
    157 
    +-- | Gets contents of a small bitmap (fitting in one @StgWord@)
    158 
    +--
    159 
    +-- The first two arguments identify the location of the frame on the stack.
    160 
    +-- Returned is the bitmap and it's size.
    161 
    +type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #)
    162 
    +
    163 
    +foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
    164 
    +
    165 
    +foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
    166 
    +
    167 
    +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
    168 
    +
    169 
    +foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
    170 
    +
    171 
    +-- | Get the 'StgInfoTable' of the stack frame.
    172 
    +-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
    173 
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
    174 
    +getInfoTableOnStack stackSnapshot# index =
    175 
    +  let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
    176 
    +   in
    177 
    +    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#)
    178 
    +
    179 
    +getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    180 
    +getInfoTableForStack stackSnapshot# =
    181 
    +  peekItbl $
    182 
    +    Ptr (getStackInfoTableAddr# stackSnapshot#)
    183 
    +
    184 
    +foreign import prim "getStackClosurezh"
    185 
    +  getStackClosure# ::
    186 
    +    StackSnapshot# -> Word# ->  Any
    187 
    +
    188 
    +foreign import prim "getStackFieldszh"
    189 
    +  getStackFields# ::
    190 
    +    StackSnapshot# -> Word32#
    191 
    +
    192 
    +getStackFields :: StackSnapshot# -> Word32
    193 
    +getStackFields stackSnapshot# =
    194 
    +  case getStackFields# stackSnapshot# of
    195 
    +    sSize# -> W32# sSize#
    196 
    +
    197 
    +-- | `StackFrameLocation` of the top-most stack frame
    198 
    +stackHead :: StackSnapshot# -> StackFrameLocation
    199 
    +stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty
    200 
    +
    201 
    +-- | Advance to the next stack frame (if any)
    202 
    +--
    203 
    +-- The last `Int#` in the result tuple is meant to be treated as bool
    204 
    +-- (has_next).
    205 
    +foreign import prim "advanceStackFrameLocationzh"
    206 
    +  advanceStackFrameLocation# ::
    207 
    +    StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
    208 
    +
    209 
    +-- | Advance to the next stack frame (if any)
    210 
    +advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
    211 
    +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
    212 
    +  let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)
    213 
    +   in if I# hasNext > 0
    214 
    +        then Just (StackSnapshot s', primWordToWordOffset i')
    215 
    +        else Nothing
    216 
    +  where
    217 
    +    primWordToWordOffset :: Word# -> WordOffset
    218 
    +    primWordToWordOffset w# = fromIntegral (W# w#)
    219 
    +
    220 
    +getClosureBox :: StackSnapshot# -> WordOffset -> Box
    221 
    +getClosureBox stackSnapshot# index =
    222 
    +        case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of
    223 
    +          -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and
    224 
    +          -- will later be decoded as such)
    225 
    +          !c -> Box c
    226 
    +
    227 
    +-- | Representation of @StgLargeBitmap@ (RTS)
    228 
    +data LargeBitmap = LargeBitmap
    229 
    +  { largeBitmapSize :: Word,
    230 
    +    largebitmapWords :: Ptr Word
    231 
    +  }
    232 
    +
    233 
    +-- | Is a bitmap entry a closure pointer or a primitive non-pointer?
    234 
    +data Pointerness = Pointer | NonPointer
    235 
    +  deriving (Show)
    236 
    +
    237 
    +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
    238 
    +decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
    239 
    +  let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
    240 
    +        (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#)
    241 
    +  bitmapWords <- largeBitmapToList largeBitmap
    242 
    +  pure $ decodeBitmaps
    243 
    +          stackSnapshot#
    244 
    +          (index + relativePayloadOffset)
    245 
    +          (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords)
    246 
    +  where
    247 
    +    largeBitmapToList :: LargeBitmap -> IO [Word]
    248 
    +    largeBitmapToList LargeBitmap {..} =
    249 
    +      cWordArrayToList largebitmapWords $
    250 
    +        (usedBitmapWords . fromIntegral) largeBitmapSize
    251 
    +
    252 
    +    cWordArrayToList :: Ptr Word -> Int -> IO [Word]
    253 
    +    cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)]
    254 
    +
    255 
    +    usedBitmapWords :: Int -> Int
    256 
    +    usedBitmapWords 0 = error "Invalid large bitmap size 0."
    257 
    +    usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1
    258 
    +
    259 
    +    bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
    260 
    +    bitmapWordsPointerness size _ | size <= 0 = []
    261 
    +    bitmapWordsPointerness _ [] = []
    262 
    +    bitmapWordsPointerness size (w : wds) =
    263 
    +      bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w
    264 
    +        ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds
    265 
    +
    266 
    +bitmapWordPointerness :: Word -> Word -> [Pointerness]
    267 
    +bitmapWordPointerness 0 _ = []
    268 
    +bitmapWordPointerness bSize bitmapWord =
    269 
    +  ( if (bitmapWord .&. 1) /= 0
    270 
    +      then NonPointer
    271 
    +      else Pointer
    272 
    +  )
    273 
    +    : bitmapWordPointerness
    274 
    +      (bSize - 1)
    275 
    +      (bitmapWord `shiftR` 1)
    276 
    +
    277 
    +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField]
    278 
    +decodeBitmaps stack# index ps =
    279 
    +  zipWith toPayload ps [index ..]
    280 
    +  where
    281 
    +    toPayload :: Pointerness -> WordOffset -> StackField
    282 
    +    toPayload p i = case p of
    283 
    +      NonPointer -> StackWord (getWord stack# i)
    284 
    +      Pointer -> StackBox (getClosureBox stack# i)
    285 
    +
    286 
    +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
    287 
    +decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
    288 
    +  let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
    289 
    +        (# b#, s# #) -> (W# b#, W# s#)
    290 
    +  in decodeBitmaps
    291 
    +      stackSnapshot#
    292 
    +      (index + relativePayloadOffset)
    293 
    +      (bitmapWordPointerness size bitmap)
    294 
    +
    295 
    +unpackStackFrame :: StackFrameLocation -> IO StackFrame
    296 
    +unpackStackFrame stackFrameLoc = do
    297 
    +  unpackStackFrameTo stackFrameLoc
    298 
    +    (\ info nextChunk -> do
    299 
    +      stackClosure <- decodeStack nextChunk
    300 
    +      pure $
    301 
    +        UnderflowFrame
    302 
    +          { info_tbl = info,
    303 
    +            nextChunk = stackClosure
    304 
    +          }
    305 
    +    )
    306 
    +    (\ frame _ -> pure frame)
    307 
    +
    308 
    +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
    309 
    +unpackStackFrameWithIpe stackFrameLoc = do
    310 
    +  unpackStackFrameTo stackFrameLoc
    311 
    +    (\ _ nextChunk -> do
    312 
    +      decodeStackWithIpe nextChunk
    313 
    +    )
    314 
    +    (\ frame mIpe -> pure [(frame, mIpe)])
    315 
    +
    316 
    +unpackStackFrameTo ::
    317 
    +  forall a .
    318 
    +  StackFrameLocation ->
    319 
    +  (StgInfoTable -> StackSnapshot -> IO a) ->
    320 
    +  (StackFrame -> Maybe InfoProv -> IO a) ->
    321 
    +  IO a
    322 
    +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
    323 
    +  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    324 
    +  unpackStackFrame' info
    325 
    +    (`finaliseStackFrame` m_info_prov)
    326 
    +  where
    327 
    +    unpackStackFrame' ::
    328 
    +      StgInfoTable ->
    329 
    +      (StackFrame -> IO a) ->
    330 
    +      IO a
    331 
    +    unpackStackFrame' info mkStackFrameResult =
    332 
    +      case tipe info of
    333 
    +        RET_BCO -> do
    334 
    +          let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
    335 
    +          -- The arguments begin directly after the payload's one element
    336 
    +          bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
    337 
    +          mkStackFrameResult
    338 
    +            RetBCO
    339 
    +              { info_tbl = info,
    340 
    +                bco = bco',
    341 
    +                bcoArgs = bcoArgs'
    342 
    +              }
    343 
    +        RET_SMALL ->
    344 
    +          let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
    345 
    +          in
    346 
    +            mkStackFrameResult $
    347 
    +              RetSmall
    348 
    +                { info_tbl = info,
    349 
    +                  stack_payload = payload'
    350 
    +                }
    351 
    +        RET_BIG -> do
    352 
    +          payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
    353 
    +          mkStackFrameResult $
    354 
    +            RetBig
    355 
    +              { info_tbl = info,
    356 
    +                stack_payload = payload'
    357 
    +              }
    358 
    +        RET_FUN -> do
    359 
    +          let retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
    360 
    +              retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)
    361 
    +          retFunPayload' <-
    362 
    +            if isArgGenBigRetFunType stackSnapshot# index == True
    363 
    +              then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    364 
    +              else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    365 
    +          mkStackFrameResult $
    366 
    +            RetFun
    367 
    +              { info_tbl = info,
    368 
    +                retFunSize = retFunSize',
    369 
    +                retFunFun = retFunFun',
    370 
    +                retFunPayload = retFunPayload'
    371 
    +              }
    372 
    +        UPDATE_FRAME ->
    373 
    +          let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
    374 
    +          in
    375 
    +            mkStackFrameResult $
    376 
    +              UpdateFrame
    377 
    +                { info_tbl = info,
    378 
    +                  updatee = updatee'
    379 
    +                }
    380 
    +        CATCH_FRAME -> do
    381 
    +          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
    382 
    +          mkStackFrameResult $
    383 
    +            CatchFrame
    384 
    +              { info_tbl = info,
    385 
    +                handler = handler'
    386 
    +              }
    387 
    +        UNDERFLOW_FRAME -> do
    388 
    +          let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
    389 
    +          unpackUnderflowFrame info nextChunk'
    390 
    +        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
    391 
    +        ATOMICALLY_FRAME -> do
    392 
    +          let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
    393 
    +              result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
    394 
    +          mkStackFrameResult $
    395 
    +            AtomicallyFrame
    396 
    +              { info_tbl = info,
    397 
    +                atomicallyFrameCode = atomicallyFrameCode',
    398 
    +                result = result'
    399 
    +              }
    400 
    +        CATCH_RETRY_FRAME ->
    401 
    +          let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
    402 
    +              first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
    403 
    +              alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
    404 
    +          in
    405 
    +            mkStackFrameResult $
    406 
    +              CatchRetryFrame
    407 
    +                { info_tbl = info,
    408 
    +                  running_alt_code = running_alt_code',
    409 
    +                  first_code = first_code',
    410 
    +                  alt_code = alt_code'
    411 
    +                }
    412 
    +        CATCH_STM_FRAME ->
    413 
    +          let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
    414 
    +              handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
    415 
    +          in
    416 
    +            mkStackFrameResult $
    417 
    +              CatchStmFrame
    418 
    +                { info_tbl = info,
    419 
    +                  catchFrameCode = catchFrameCode',
    420 
    +                  handler = handler'
    421 
    +                }
    422 
    +        ANN_FRAME ->
    423 
    +          let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
    424 
    +           in
    425 
    +             mkStackFrameResult $
    426 
    +               AnnFrame
    427 
    +                { info_tbl = info,
    428 
    +                  annotation = annotation
    429 
    +                }
    430 
    +        x -> error $ "Unexpected closure type on stack: " ++ show x
    431 
    +
    432 
    +-- | Unbox 'Int#' from 'Int'
    433 
    +toInt# :: Int -> Int#
    434 
    +toInt# (I# i) = i
    435 
    +
    436 
    +-- | Convert `Int` to `Word#`
    437 
    +intToWord# :: Int -> Word#
    438 
    +intToWord# i = int2Word# (toInt# i)
    439 
    +
    440 
    +wordOffsetToWord# :: WordOffset -> Word#
    441 
    +wordOffsetToWord# wo = intToWord# (fromIntegral wo)
    442 
    +
    443 
    +-- | Location of a stackframe on the stack
    444 
    +--
    445 
    +-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
    446 
    +-- of the stack.
    447 
    +type StackFrameLocation = (StackSnapshot, WordOffset)
    448 
    +
    449 
    +-- | Decode `StackSnapshot` to a `StgStackClosure`
    450 
    +--
    451 
    +-- The return value is the representation of the @StgStack@ itself.
    452 
    +--
    453 
    +-- See /Note [Decoding the stack]/.
    454 
    +decodeStack :: StackSnapshot -> IO StgStackClosure
    455 
    +decodeStack snapshot@(StackSnapshot stack#) = do
    456 
    +  (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
    457 
    +  pure
    458 
    +    GenStgStackClosure
    459 
    +      { ssc_info = stackInfo,
    460 
    +        ssc_stack_size = getStackFields stack#,
    461 
    +        ssc_stack = ssc_stack
    462 
    +      }
    463 
    +
    464 
    +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
    465 
    +decodeStackWithIpe snapshot =
    466 
    +  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
    467 
    +
    468 
    +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
    469 
    +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    470 
    +  info <- getInfoTableForStack stack#
    471 
    +  case tipe info of
    472 
    +    STACK -> do
    473 
    +      let sfls = stackFrameLocations stack#
    474 
    +      stack' <- mapM unpackFrame sfls
    475 
    +      pure (info, stack')
    476 
    +    _ -> error $ "Expected STACK closure, got " ++ show info
    477 
    +  where
    478 
    +    stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
    479 
    +    stackFrameLocations s# =
    480 
    +      stackHead s#
    481 
    +        : go (advanceStackFrameLocation (stackHead s#))
    482 
    +      where
    483 
    +        go :: Maybe StackFrameLocation -> [StackFrameLocation]
    484 
    +        go Nothing = []
    485 
    +        go (Just r) = r : go (advanceStackFrameLocation r)
    486 
    +
    487 
    +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
    488 
    +prettyStackFrameWithIpe (frame, mipe) =
    489 
    +  case frame of
    490 
    +    AnnFrame _ (Box ann) ->
    491 
    +      Just $ displayStackAnnotation (unsafeCoerce ann :: SomeStackAnnotation)
    492 
    +    _ ->
    493 
    +      (prettyStackEntry . toStackEntry) <$> mipe
    494 
    +
    495 
    +
    496 
    +-- TODO @fendor: deprecate
    497 
    +prettyStackEntry :: StackEntry -> String
    498 
    +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
    499 
    +  mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help