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

Commits:

8 changed files:

Changes:

  • libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
    ... ... @@ -3,65 +3,106 @@
    3 3 
     {-# LANGUAGE MagicHash #-}
    4 4 
     {-# LANGUAGE UnboxedTuples #-}
    5 5 
     {-# LANGUAGE ImplicitParams #-}
    6 
    -module GHC.Stack.Annotation.Experimental where
    6 
    +module GHC.Stack.Annotation.Experimental (
    7 
    +  IsStackAnnotation(..),
    8 
    +  SomeStackAnnotation(..),
    9 
    +  -- * Source Location annotations
    10 
    +  SrcLocAnnotation,
    11 
    +  UnknownSrcLocAnnotation,
    12 
    +  -- * Stack annotations
    13 
    +  annotateStack,
    14 
    +  annotateShow,
    15 
    +  annotateStackM,
    16 
    +  annotateStringM,
    17 
    +  annotateStackShowM,
    18 
    +  annotateCallStackM,
    19 
    +  ) where
    7 20
    8 21 
     import Data.Typeable
    9 22 
     import GHC.Exts
    10 23 
     import GHC.IO
    11 
    -import GHC.Internal.Stack.Types
    24 
    +import GHC.Internal.Stack
    12 25
    13 
    -data StackAnnotation where
    14 
    -  StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation
    26 
    +-- ----------------------------------------------------------------------------
    27 
    +-- IsStackAnnotation
    28 
    +-- ----------------------------------------------------------------------------
    15 29
    16 30 
     class IsStackAnnotation a where
    17 
    -  display :: a -> String
    31 
    +  displayStackAnnotation :: a -> String
    18 32
    19 
    -instance IsStackAnnotation StackAnnotation where
    20 
    -  display (StackAnnotation a) = show a
    33 
    +-- ----------------------------------------------------------------------------
    34 
    +-- Annotations
    35 
    +-- ----------------------------------------------------------------------------
    21 36
    22 
    -newtype SrcLocAnno = MkSrcLocAnno SrcLoc
    37 
    +{- |
    38 
    +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
    39 
    +When the call stack is annotated with a value of type @a@, behind the scenes it is
    40 
    +encapsulated in a @SomeStackAnnotation@.
    41 
    +-}
    42 
    +data SomeStackAnnotation where
    43 
    +  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
    23 44
    24 
    -data UnknownSrcLocAnno = UnknownSrcLocAnno
    45 
    +instance IsStackAnnotation SomeStackAnnotation where
    46 
    +  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
    47 
    +
    48 
    +data StringAnnotation where
    49 
    +  StringAnnotation :: String -> StringAnnotation
    50 
    +
    51 
    +instance IsStackAnnotation StringAnnotation where
    52 
    +  displayStackAnnotation (StringAnnotation str) = str
    53 
    +
    54 
    +-- ----------------------------------------------------------------------------
    55 
    +-- Source location annotations
    56 
    +-- ----------------------------------------------------------------------------
    57 
    +
    58 
    +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc
    59 
    +
    60 
    +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation
    25 61 
       deriving Show
    26 62
    27 
    -instance Show SrcLocAnno where
    28 
    -  show (MkSrcLocAnno l) =
    29 
    -    concat
    30 
    -      [ srcLocPackage l
    31 
    -      , ":"
    32 
    -      , srcLocModule l
    33 
    -      , " "
    34 
    -      , srcLocFile l
    35 
    -      , ":"
    36 
    -      , show $ srcLocStartLine l
    37 
    -      , "-"
    38 
    -      , show $ srcLocStartCol l
    39 
    -      , ":"
    40 
    -      , show $ srcLocEndLine l
    41 
    -      , "-"
    42 
    -      , show $ srcLocEndCol l
    43 
    -      ]
    44 
    -
    45 
    -instance IsStackAnnotation SrcLocAnno where
    46 
    -  display = show
    47 
    -
    48 
    -instance IsStackAnnotation UnknownSrcLocAnno where
    49 
    -  display UnknownSrcLocAnno = "UnknownSrcLocAnno"
    63 
    +instance Show SrcLocAnnotation where
    64 
    +  show (SrcLocAnnotation l) = prettySrcLoc l
    65 
    +
    66 
    +instance IsStackAnnotation SrcLocAnnotation where
    67 
    +  displayStackAnnotation = show
    68 
    +
    69 
    +instance IsStackAnnotation UnknownSrcLocAnnotation where
    70 
    +  displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>"
    71 
    +
    72 
    +-- ----------------------------------------------------------------------------
    73 
    +-- Annotate the CallStack!
    74 
    +-- ----------------------------------------------------------------------------
    50 75
    51 76 
     {-# NOINLINE annotateStack #-}
    52 
    -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b
    77 
    +-- TODO @fendor: it seems the pure interface doesnt work,
    78 
    +-- investigate more and then decide what to do
    79 
    +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b
    53 80 
     annotateStack ann b = unsafePerformIO $
    54 81 
       annotateStackM ann (pure b)
    55 82
    56 
    -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b
    83 
    +-- TODO @fendor: it seems the pure interface doesnt work,
    84 
    +-- investigate more and then decide what to do
    85 
    +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b
    86 
    +annotateShow ann =
    87 
    +  annotateStack (StringAnnotation $ show ann)
    88 
    +
    89 
    +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b
    57 90 
     annotateStackM ann (IO act) =
    58 
    -  IO $ \s -> annotateStack# (StackAnnotation ann) act s
    91 
    +  IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s
    92 
    +
    93 
    +annotateStringM :: forall b . String -> IO b -> IO b
    94 
    +annotateStringM ann =
    95 
    +  annotateStackM (StringAnnotation ann)
    96 
    +
    97 
    +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b
    98 
    +annotateStackShowM ann =
    99 
    +  annotateStringM (show ann)
    59 100
    60 101 
     annotateCallStackM :: HasCallStack => IO a -> IO a
    61 102 
     annotateCallStackM act =
    62 103 
       let
    63 104 
         cs = getCallStack ?callStack
    64 105 
       in case cs of
    65 
    -    [] -> annotateStackM UnknownSrcLocAnno act
    66 
    -    [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act
    67 
    -    (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act
    106 
    +    [] -> annotateStackM UnknownSrcLocAnnotation act
    107 
    +    [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act
    108 
    +    (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act

  • libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
    ... ... @@ -24,7 +24,7 @@ import Foreign
    24 24
    25 25 
     -- | Read an InfoTable from the heap into a haskell type.
    26 26 
     -- WARNING: This code assumes it is passed a pointer to a "standard" info
    27 
    --- table. If tables_next_to_code is enabled, it will look 1 byte before the
    27 
    +-- table. If tables_next_to_code is disabled, it will look 1 word before the
    28 28 
     -- start for the entry field.
    29 29 
     peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
    30 30 
     peekItbl a0 = do

  • libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
    ... ... @@ -15,6 +15,7 @@
    15 15
    16 16 
     module GHC.Exts.Stack.Decode
    17 17 
       ( decodeStack,
    18 
    +    decodeStackWithIpe,
    18 19 
       )
    19 20 
     where
    20 21
    ... ... @@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures
    36 37 
     import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
    37 38 
     import GHC.Exts.Heap.InfoTable
    38 39 
     import GHC.Exts.Stack.Constants
    40 
    +import qualified GHC.Internal.InfoProv.Types as IPE
    39 41 
     import GHC.Stack.CloneStack
    40 42 
     import GHC.Word
    41 43 
     import Prelude
    ... ... @@ -150,14 +152,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
    150 152
    151 153 
     foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
    152 154
    153 
    -foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
    155 
    +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
    154 156
    155 157 
     foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
    156 158
    157 
    -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
    159 
    +-- | Get the 'StgInfoTable' of the stack frame.
    160 
    +-- Additionally, provides 'IPE.InfoProv' for the 'StgInfoTable' if there is any.
    161 
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.InfoProv)
    158 162 
     getInfoTableOnStack stackSnapshot# index =
    159 
    -  let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
    160 
    -   in peekItbl infoTablePtr
    163 
    +  let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
    164 
    +   in
    165 
    +    (,) <$> peekItbl (Ptr itbl_struct#) <*> IPE.lookupIPE (Ptr itbl_ptr#)
    161 166
    162 167 
     getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    163 168 
     getInfoTableForStack stackSnapshot# =
    ... ... @@ -276,18 +281,49 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
    276 281 
           (bitmapWordPointerness size bitmap)
    277 282
    278 283 
     unpackStackFrame :: StackFrameLocation -> IO StackFrame
    279 
    -unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    280 
    -  info <- getInfoTableOnStack stackSnapshot# index
    284 
    +unpackStackFrame stackFrameLoc = do
    285 
    +  unpackStackFrameTo stackFrameLoc
    286 
    +    (\ info nextChunk -> do
    287 
    +      stackClosure <- decodeStack nextChunk
    288 
    +      pure $
    289 
    +        UnderflowFrame
    290 
    +          { info_tbl = info,
    291 
    +            nextChunk = stackClosure
    292 
    +          }
    293 
    +    )
    294 
    +    (\ frame _ -> pure frame)
    295 
    +
    296 
    +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe IPE.InfoProv)]
    297 
    +unpackStackFrameWithIpe stackFrameLoc = do
    298 
    +  unpackStackFrameTo stackFrameLoc
    299 
    +    (\ _ nextChunk -> do
    300 
    +      decodeStackWithIpe nextChunk
    301 
    +    )
    302 
    +    (\ frame mIpe -> pure [(frame, mIpe)])
    303 
    +
    304 
    +unpackStackFrameTo ::
    305 
    +  StackFrameLocation ->
    306 
    +  (StgInfoTable -> StackSnapshot -> IO a) ->
    307 
    +  (StackFrame -> Maybe IPE.InfoProv -> IO a) ->
    308 
    +  IO a
    309 
    +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
    310 
    +  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    281 311 
       unpackStackFrame' info
    312 
    +    unpackUnderflowFrame
    313 
    +    (`finaliseStackFrame` m_info_prov)
    282 314 
       where
    283 
    -    unpackStackFrame' :: StgInfoTable -> IO StackFrame
    284 
    -    unpackStackFrame' info =
    315 
    +    unpackStackFrame' ::
    316 
    +      StgInfoTable ->
    317 
    +      (StgInfoTable -> StackSnapshot -> IO a) ->
    318 
    +      (StackFrame -> IO a) ->
    319 
    +      IO a
    320 
    +    unpackStackFrame' info unpackUnderflowFrame mkStackFrameResult =
    285 321 
           case tipe info of
    286 322 
             RET_BCO -> do
    287 323 
               let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
    288 324 
               -- The arguments begin directly after the payload's one element
    289 325 
               bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
    290 
    -          pure
    326 
    +          mkStackFrameResult
    291 327 
                 RetBCO
    292 328 
                   { info_tbl = info,
    293 329 
                     bco = bco',
    ... ... @@ -296,14 +332,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    296 332 
             RET_SMALL ->
    297 333 
               let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
    298 334 
               in
    299 
    -            pure $
    335 
    +            mkStackFrameResult $
    300 336 
                   RetSmall
    301 337 
                     { info_tbl = info,
    302 338 
                       stack_payload = payload'
    303 339 
                     }
    304 340 
             RET_BIG -> do
    305 341 
               payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
    306 
    -          pure $
    342 
    +          mkStackFrameResult $
    307 343 
                 RetBig
    308 344 
                   { info_tbl = info,
    309 345 
                     stack_payload = payload'
    ... ... @@ -315,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    315 351 
                 if isArgGenBigRetFunType stackSnapshot# index == True
    316 352 
                   then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    317 353 
                   else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    318 
    -          pure $
    354 
    +          mkStackFrameResult $
    319 355 
                 RetFun
    320 356 
                   { info_tbl = info,
    321 357 
                     retFunSize = retFunSize',
    ... ... @@ -325,31 +361,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    325 361 
             UPDATE_FRAME ->
    326 362 
               let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
    327 363 
               in
    328 
    -            pure $
    364 
    +            mkStackFrameResult $
    329 365 
                   UpdateFrame
    330 366 
                     { info_tbl = info,
    331 367 
                       updatee = updatee'
    332 368 
                     }
    333 369 
             CATCH_FRAME -> do
    334 370 
               let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
    335 
    -          pure $
    371 
    +          mkStackFrameResult $
    336 372 
                 CatchFrame
    337 373 
                   { info_tbl = info,
    338 374 
                     handler = handler'
    339 375 
                   }
    340 376 
             UNDERFLOW_FRAME -> do
    341 377 
               let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
    342 
    -          stackClosure <- decodeStack nextChunk'
    343 
    -          pure $
    344 
    -            UnderflowFrame
    345 
    -              { info_tbl = info,
    346 
    -                nextChunk = stackClosure
    347 
    -              }
    348 
    -        STOP_FRAME -> pure $ StopFrame {info_tbl = info}
    378 
    +          unpackUnderflowFrame info nextChunk'
    379 
    +        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
    349 380 
             ATOMICALLY_FRAME -> do
    350 381 
               let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
    351 382 
                   result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
    352 
    -          pure $
    383 
    +          mkStackFrameResult $
    353 384 
                 AtomicallyFrame
    354 385 
                   { info_tbl = info,
    355 386 
                     atomicallyFrameCode = atomicallyFrameCode',
    ... ... @@ -360,7 +391,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    360 391 
                   first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
    361 392 
                   alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
    362 393 
               in
    363 
    -            pure $
    394 
    +            mkStackFrameResult $
    364 395 
                   CatchRetryFrame
    365 396 
                     { info_tbl = info,
    366 397 
                       running_alt_code = running_alt_code',
    ... ... @@ -371,7 +402,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    371 402 
               let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
    372 403 
                   handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
    373 404 
               in
    374 
    -            pure $
    405 
    +            mkStackFrameResult $
    375 406 
                   CatchStmFrame
    376 407 
                     { info_tbl = info,
    377 408 
                       catchFrameCode = catchFrameCode',
    ... ... @@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    380 411 
             ANN_FRAME ->
    381 412 
               let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
    382 413 
                in
    383 
    -             pure $
    414 
    +             mkStackFrameResult $
    384 415 
                    AnnFrame
    385 416 
                     { info_tbl = info,
    386 417 
                       annotation = annotation
    ... ... @@ -410,19 +441,27 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
    410 441 
     --
    411 442 
     -- See /Note [Decoding the stack]/.
    412 443 
     decodeStack :: StackSnapshot -> IO StgStackClosure
    413 
    -decodeStack (StackSnapshot stack#) = do
    444 
    +decodeStack snapshot@(StackSnapshot stack#) = do
    445 
    +  (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
    446 
    +  pure
    447 
    +    GenStgStackClosure
    448 
    +      { ssc_info = stackInfo,
    449 
    +        ssc_stack_size = getStackFields stack#,
    450 
    +        ssc_stack = ssc_stack
    451 
    +      }
    452 
    +
    453 
    +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe IPE.InfoProv)]
    454 
    +decodeStackWithIpe snapshot =
    455 
    +  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
    456 
    +
    457 
    +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
    458 
    +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    414 459 
       info <- getInfoTableForStack stack#
    415 460 
       case tipe info of
    416 461 
         STACK -> do
    417 
    -      let stack_size' = getStackFields stack#
    418 
    -          sfls = stackFrameLocations stack#
    419 
    -      stack' <- mapM unpackStackFrame sfls
    420 
    -      pure $
    421 
    -        GenStgStackClosure
    422 
    -          { ssc_info = info,
    423 
    -            ssc_stack_size = stack_size',
    424 
    -            ssc_stack = stack'
    425 
    -          }
    462 
    +      let sfls = stackFrameLocations stack#
    463 
    +      stack' <- mapM unpackFrame sfls
    464 
    +      pure (info, stack')
    426 465 
         _ -> error $ "Expected STACK closure, got " ++ show info
    427 466 
       where
    428 467 
         stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]

  • libraries/ghc-heap/cbits/Stack.cmm
    ... ... @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
    146 146 
       return (type);
    147 147 
     }
    148 148
    149 
    -// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
    150 
    -getInfoTableAddrzh(P_ stack, W_ offsetWords) {
    151 
    -  P_ p, info;
    149 
    +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
    150 
    +getInfoTableAddrszh(P_ stack, W_ offsetWords) {
    151 
    +  P_ p, info_struct, info_ptr;
    152 152 
       p = StgStack_sp(stack) + WDS(offsetWords);
    153 153 
       ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
    154 
    -  info = %GET_STD_INFO(UNTAG(p));
    155 
    -
    156 
    -  return (info);
    154 
    +  info_struct = %GET_STD_INFO(UNTAG(p));
    155 
    +  info_ptr = %INFO_PTR(UNTAG(p));
    156 
    +  return (info_struct, info_ptr);
    157 157 
     }
    158 158
    159 159 
     // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)

  • libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
    ... ... @@ -7,7 +7,7 @@ import System.IO.Unsafe
    7 7 
     import Unsafe.Coerce
    8 8
    9 9 
     hello :: Int -> Int -> Int
    10 
    -hello x y = annotateStack (x,y) $
    10 
    +hello x y = annotateShow (x,y) $
    11 11 
       decodeAndPrintAnnotationFrames $!
    12 12 
         x + y + 42
    13 13 
     {-# OPAQUE hello #-}
    ... ... @@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a
    17 17 
     decodeAndPrintAnnotationFrames a = unsafePerformIO $ do
    18 18 
       stack <- GHC.Stack.CloneStack.cloneMyStack
    19 19 
       decoded <- GHC.Exts.Stack.Decode.decodeStack stack
    20 
    -  print [ show a
    20 
    +  print [ displayStackAnnotation a
    21 21 
             | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded
    22 
    -        , StackAnnotation a <- pure $ unsafeCoerce ann
    22 
    +        , SomeStackAnnotation a <- pure $ unsafeCoerce ann
    23 23 
             ]
    24 24 
       pure a
    25 25
    ... ... @@ -30,13 +30,13 @@ main = do
    30 30
    31 31 
     {-# INLINE tailCallEx #-}
    32 32 
     tailCallEx :: Int -> Int -> Int
    33 
    -tailCallEx a b = annotateStack "tailCallEx" $ foo a b
    33 
    +tailCallEx a b = annotateShow "tailCallEx" $ foo a b
    34 34
    35 35 
     {-# INLINE foo #-}
    36 36 
     foo :: Int -> Int -> Int
    37 
    -foo a b = annotateStack "foo" $ bar $ a * b
    37 
    +foo a b = annotateShow "foo" $ bar $ a * b
    38 38
    39 
    -bar c = annotateStack "bar" $
    39 
    +bar c = annotateShow "bar" $
    40 40 
       decodeAndPrintAnnotationFrames $
    41 41 
         c + c
    42 42

  • libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs
    ... ... @@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack
    12 12
    13 13 
     import System.IO.Unsafe
    14 14 
     import Unsafe.Coerce
    15 
    -
    16 
    -{-# NOINLINE decodeAnnotationFrames #-}
    17 
    -decodeAnnotationFrames :: IO [String]
    18 
    -decodeAnnotationFrames = do
    19 
    -  stack <- CloneStack.cloneMyStack
    20 
    -  decoded <- Decode.decodeStack stack
    21 
    -  pure
    22 
    -      [ show a
    23 
    -      | AnnFrame _ (Box ann) <- ssc_stack decoded
    24 
    -      , StackAnnotation a <- [unsafeCoerce ann]
    25 
    -      ]
    15 
    +import GHC.Exts.Heap.Closures (GenStgStackClosure)
    26 16
    27 17 
     {-# NOINLINE printAnnotationStack #-}
    28 18 
     printAnnotationStack :: [String] -> IO ()
    ... ... @@ -47,8 +37,8 @@ baz = annotateCallStackM $ do
    47 37 
       decodeAnnotationFrames >>= printAnnotationStack
    48 38
    49 39 
     bar :: IO ()
    50 
    -bar = annotateCallStackM $ annotateStackM "bar" $ do
    51 
    -  putStrLn "Some more ork in bar"
    40 
    +bar = annotateCallStackM $ annotateStringM "bar" $ do
    41 
    +  putStrLn "Some more work in bar"
    52 42 
       print (fib 21)
    53 43 
       decodeAnnotationFrames >>= printAnnotationStack
    54 44
    ... ... @@ -56,3 +46,23 @@ fib :: Int -> Int
    56 46 
     fib n
    57 47 
       | n <= 1 = 1
    58 48 
       | otherwise = fib (n - 1) + fib (n - 2)
    49 
    +
    50 
    +{-# NOINLINE decodeAnnotationFrames #-}
    51 
    +decodeAnnotationFrames :: IO [String]
    52 
    +decodeAnnotationFrames = do
    53 
    +  stack <- CloneStack.cloneMyStack
    54 
    +  decoded <- Decode.decodeStack stack
    55 
    +  pure $ unwindStack decoded
    56 
    +
    57 
    +unwindStack :: GenStgStackClosure Box -> [String]
    58 
    +unwindStack stack_closure =
    59 
    +  [ ann
    60 
    +  | a <- ssc_stack stack_closure
    61 
    +  , ann <- case a of
    62 
    +          AnnFrame _ (Box ann) ->
    63 
    +            [ displayStackAnnotation a
    64 
    +            | SomeStackAnnotation a <- [unsafeCoerce ann]
    65 
    +            ]
    66 
    +          UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure
    67 
    +          _ -> []
    68 
    +  ]

  • libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout
    1 1 
     Start some work
    2 2 
     10946
    3 3 
     Annotation stack:
    4 
    -main:Main ann_frame002.hs:35-7:35-10
    5 
    -main:Main ann_frame002.hs:35-3:35-6
    4 
    +ann_frame002.hs:25:7 in main:Main
    5 
    +ann_frame002.hs:25:3 in main:Main
    6 6 
     Finish some work
    7 7 
     Some more ork in bar
    8 8 
     17711
    9 9 
     Annotation stack:
    10 
    -"bar"
    11 
    -main:Main ann_frame002.hs:50-7:50-25
    10 
    +bar
    11 
    +ann_frame002.hs:40:7 in main:Main

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -37,6 +37,14 @@ data EnabledBacktraceMechanisms =
    37 37 
           , ipeBacktraceEnabled          :: !Bool
    38 38 
           }
    39 39
    40 
    +data DisplayBacktraceMechanisms =
    41 
    +    DisplayBacktraceMechanisms
    42 
    +      { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String
    43 
    +      , displayHasCallStackBacktrace :: HCS.CallStack -> String
    44 
    +      , displayExecutionBacktrace :: [ExecStack.Location] -> String
    45 
    +      , displayIpeBacktrace :: CloneStack.StackSnapshot -> String
    46 
    +      }
    47 
    +
    40 48 
     defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms
    41 49 
     defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms
    42 50 
       { costCentreBacktraceEnabled   = False
    ... ... @@ -45,6 +53,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms
    45 53 
       , ipeBacktraceEnabled          = False
    46 54 
       }
    47 55
    56 
    +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms
    57 
    +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms
    58 
    +  { displayCostCentreBacktrace   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
    59 
    +  , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    60 
    +  , displayExecutionBacktrace    = unlines . map (indent 2 . flip ExecStack.showLocation "")
    61 
    +  , displayIpeBacktrace          = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
    62 
    +  }
    63 
    +  where
    64 
    +    indent :: Int -> String -> String
    65 
    +    indent n s  = replicate n ' ' ++ s
    66 
    +
    67 
    +    prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    68 
    +
    48 69 
     backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
    49 70 
     backtraceMechanismEnabled bm =
    50 71 
       case bm of
    ... ... @@ -69,6 +90,11 @@ enabledBacktraceMechanismsRef =
    69 90 
         unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms
    70 91 
     {-# NOINLINE enabledBacktraceMechanismsRef #-}
    71 92
    93 
    +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms
    94 
    +displayBacktraceMechanismsRef =
    95 
    +    unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms
    96 
    +{-# NOINLINE displayBacktraceMechanismsRef #-}
    97 
    +
    72 98 
     -- | Returns the currently enabled 'BacktraceMechanism's.
    73 99 
     getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms
    74 100 
     getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef
    ... ... @@ -86,37 +112,41 @@ setBacktraceMechanismState bm enabled = do
    86 112 
         _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled)
    87 113 
         return ()
    88 114
    115 
    +-- TODO @fendor
    116 
    +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms
    117 
    +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef
    118 
    +
    119 
    +-- TODO @fendor:
    120 
    +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO ()
    121 
    +setDisplayBacktraceMechanismsState dbm = do
    122 
    +    _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm)
    123 
    +    return ()
    124 
    +
    89 125 
     -- | A collection of backtraces.
    90 126 
     data Backtraces =
    91 127 
         Backtraces {
    92 128 
             btrCostCentre :: Maybe (Ptr CCS.CostCentreStack),
    129 
    +        btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String,
    93 130 
             btrHasCallStack :: Maybe HCS.CallStack,
    131 
    +        btrDisplayHasCallStack :: HCS.CallStack -> String,
    94 132 
             btrExecutionStack :: Maybe [ExecStack.Location],
    95 
    -        btrIpe :: Maybe [CloneStack.StackEntry]
    133 
    +        btrDisplayExecutionStack :: [ExecStack.Location] -> String,
    134 
    +        btrIpe :: Maybe CloneStack.StackSnapshot,
    135 
    +        btrDisplayIpe :: CloneStack.StackSnapshot -> String
    96 136 
         }
    97 137
    98 138 
     -- | Render a set of backtraces to a human-readable string.
    99 139 
     displayBacktraces :: Backtraces -> String
    100 140 
     displayBacktraces bts = concat
    101 
    -    [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc
    102 
    -    , displayOne "Native stack backtrace" btrExecutionStack displayExec
    103 
    -    , displayOne "IPE backtrace" btrIpe displayIpe
    104 
    -    , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc
    141 
    +    [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre
    142 
    +    , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack
    143 
    +    , displayOne "IPE backtrace" btrIpe btrDisplayIpe
    144 
    +    , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack
    105 145 
         ]
    106 146 
       where
    107 
    -    indent :: Int -> String -> String
    108 
    -    indent n s  = replicate n ' ' ++ s
    109 
    -
    110 
    -    -- The unsafePerformIO here is safe as we don't currently unload cost-centres.
    111 
    -    displayCc   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
    112 
    -    displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "")
    113 
    -    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry)
    114 
    -    displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    115 
    -      where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    116 
    -
    117 
    -    displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
    147 
    +    displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String
    118 148 
         displayOne label getBt displ
    119 
    -      | Just bt <- getBt bts = concat [label, ":\n", displ bt]
    149 
    +      | Just bt <- getBt bts = concat [label, ":\n", displ bts bt]
    120 150 
           | otherwise            = ""
    121 151
    122 152 
     instance ExceptionAnnotation Backtraces where
    ... ... @@ -125,12 +155,14 @@ instance ExceptionAnnotation Backtraces where
    125 155 
     -- | Collect a set of 'Backtraces'.
    126 156 
     collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
    127 157 
     collectBacktraces = HCS.withFrozenCallStack $ do
    128 
    -    getEnabledBacktraceMechanisms >>= collectBacktraces'
    158 
    +    bm <- getEnabledBacktraceMechanisms
    159 
    +    dpm <- getDisplayBacktraceMechanisms
    160 
    +    collectBacktraces' bm dpm
    129 161
    130 162 
     collectBacktraces'
    131 163 
         :: (?callStack :: CallStack)
    132 
    -    => EnabledBacktraceMechanisms -> IO Backtraces
    133 
    -collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    164 
    +    => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces
    165 
    +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do
    134 166 
         let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
    135 167 
             collect mech f
    136 168 
               | backtraceMechanismEnabled mech enabled = f
    ... ... @@ -144,14 +176,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    144 176
    145 177 
         ipe <- collect IPEBacktrace $ do
    146 178 
             stack <- CloneStack.cloneMyStack
    147 
    -        stackEntries <- CloneStack.decode stack
    148 
    -        return (Just stackEntries)
    179 
    +        return (Just stack)
    149 180
    150 181 
         hcs <- collect HasCallStackBacktrace $ do
    151 182 
             return (Just ?callStack)
    152 183
    153 184 
         return (Backtraces { btrCostCentre = ccs
    185 
    +                       , btrDisplayCostCentre = displayCostCentreBacktrace renderers
    154 186 
                            , btrHasCallStack = hcs
    187 
    +                       , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers
    155 188 
                            , btrExecutionStack = exec
    189 
    +                       , btrDisplayExecutionStack = displayExecutionBacktrace renderers
    156 190 
                            , btrIpe = ipe
    191 
    +                       , btrDisplayIpe = displayIpeBacktrace renderers
    157 192 
                            })

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