Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC

Commits:

14 changed files:

Changes:

  • libraries/base/src/GHC/Stack/CloneStack.hs
    ... ... @@ -17,4 +17,3 @@ module GHC.Stack.CloneStack (
    17 17 
       ) where
    18 18
    19 19 
     import GHC.Internal.Stack.CloneStack
    20 
    -import GHC.Internal.Stack.Decode

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

  • libraries/ghc-internal/cbits/Stack_c.c
    ... ... @@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
    30 30 
     const StgInfoTable *getItbl(StgClosure *closure) {
    31 31 
       ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
    32 32 
       return get_itbl(closure);
    33 
    -}
    33 
    +};
    34 34
    35 35 
     StgWord getBitmapSize(StgClosure *c) {
    36 36 
       ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));

  • libraries/ghc-internal/jsbits/base.js
    ... ... @@ -1245,21 +1245,9 @@ function h$mkdir(path, path_offset, mode) {
    1245 1245
    1246 1246 
     // It is required by Google Closure Compiler to be at least defined if
    1247 1247 
     // somewhere it is used
    1248 
    -var h$stg_cloneMyStackzh,
    1249 
    -    h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh,
    1250 
    -    h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh,
    1251 
    -    h$isArgGenBigRetFunTypezh,
    1252 
    -    h$getUnderflowFrameNextChunkzh,
    1253 
    -    h$getInfoTableAddrszh,
    1254 
    -    h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh
    1248 
    +var h$stg_cloneMyStackzh, h$stg_decodeStackzh
    1255 1249 
     h$stg_cloneMyStackzh
    1256 
    -  = h$advanceStackFrameLocationzh
    1257 
    -  = h$getStackFieldszh = h$getStackClosurezh
    1258 
    -  = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh
    1259 
    -  = h$isArgGenBigRetFunTypezh
    1260 
    -  = h$getUnderflowFrameNextChunkzh
    1261 
    -  = h$getInfoTableAddrszh
    1262 
    -  = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh
    1250 
    +  = h$stg_decodeStackzh
    1263 1251 
       = function () {
    1264 1252 
         throw new Error('Stack Cloning Decoding: Not Implemented Yet')
    1265 1253 
       }

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -11,12 +11,11 @@ import GHC.Internal.IORef
    11 11 
     import GHC.Internal.IO.Unsafe (unsafePerformIO)
    12 12 
     import GHC.Internal.Exception.Context
    13 13 
     import GHC.Internal.Ptr
    14 
    -import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
    14 
    +import GHC.Internal.Data.Maybe (fromMaybe)
    15 15 
     import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
    16 16 
     import qualified GHC.Internal.Stack as HCS
    17 17 
     import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
    18 18 
     import qualified GHC.Internal.Stack.CloneStack as CloneStack
    19 
    -import qualified GHC.Internal.Stack.Decode as CloneStack
    20 19 
     import qualified GHC.Internal.Stack.CCS as CCS
    21 20
    22 21 
     -- | How to collect a backtrace when an exception is thrown.
    ... ... @@ -144,7 +143,7 @@ displayBacktraces bts = concat
    144 143 
         displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
    145 144 
         -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
    146 145 
         -- references closures can be garbage collected.
    147 
    -    displayIpe  = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe
    146 
    +    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
    148 147 
         displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
    149 148 
           where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
    150 149

  • libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
    ... ... @@ -15,20 +15,34 @@
    15 15 
     -- @since base-4.17.0.0
    16 16 
     module GHC.Internal.Stack.CloneStack (
    17 17 
       StackSnapshot(..),
    18 
    +  StackEntry(..),
    18 19 
       cloneMyStack,
    19 20 
       cloneThreadStack,
    21 
    +  decode,
    22 
    +  prettyStackEntry
    20 23 
       ) where
    21 24
    22 25 
     import GHC.Internal.MVar
    26 
    +import GHC.Internal.Data.Maybe (catMaybes)
    23 27 
     import GHC.Internal.Base
    28 
    +import GHC.Internal.Foreign.Storable
    24 29 
     import GHC.Internal.Conc.Sync
    30 
    +import GHC.Internal.IO (unsafeInterleaveIO)
    31 
    +import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable)
    32 
    +import GHC.Internal.Num
    33 
    +import GHC.Internal.Real (div)
    25 34 
     import GHC.Internal.Stable
    35 
    +import GHC.Internal.Text.Show
    36 
    +import GHC.Internal.Ptr
    37 
    +import GHC.Internal.ClosureTypes
    26 38
    27 39 
     -- | A frozen snapshot of the state of an execution stack.
    28 40 
     --
    29 41 
     -- @since base-4.17.0.0
    30 42 
     data StackSnapshot = StackSnapshot !StackSnapshot#
    31 43
    44 
    +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
    45 
    +
    32 46 
     foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
    33 47
    34 48 
     foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #)
    ... ... @@ -191,3 +205,64 @@ cloneThreadStack (ThreadId tid#) = do
    191 205 
       IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #)
    192 206 
       freeStablePtr boxedPtr
    193 207 
       takeMVar resultVar
    208 
    +
    209 
    +-- | Representation for the source location where a return frame was pushed on the stack.
    210 
    +-- This happens every time when a @case ... of@ scrutinee is evaluated.
    211 
    +data StackEntry = StackEntry
    212 
    +  { functionName :: String,
    213 
    +    moduleName :: String,
    214 
    +    srcLoc :: String,
    215 
    +    closureType :: ClosureType
    216 
    +  }
    217 
    +  deriving (Show, Eq)
    218 
    +
    219 
    +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
    220 
    +-- The stack trace is created from return frames with according 'InfoProvEnt'
    221 
    +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
    222 
    +-- no 'InfoProvEnt' entries, an empty list is returned.
    223 
    +--
    224 
    +-- Please note:
    225 
    +--
    226 
    +--   * To gather 'StackEntry' from libraries, these have to be
    227 
    +--     compiled with @-finfo-table-map@, too.
    228 
    +--   * Due to optimizations by GHC (e.g. inlining) the stacktrace may change
    229 
    +--     with different GHC parameters and versions.
    230 
    +--   * The stack trace is empty (by design) if there are no return frames on
    231 
    +--     the stack. (These are pushed every time when a @case ... of@ scrutinee
    232 
    +--     is evaluated.)
    233 
    +--
    234 
    +-- @since base-4.17.0.0
    235 
    +decode :: StackSnapshot -> IO [StackEntry]
    236 
    +decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot
    237 
    +
    238 
    +toStackEntry :: InfoProv -> StackEntry
    239 
    +toStackEntry infoProv =
    240 
    +  StackEntry
    241 
    +  { functionName = ipLabel infoProv,
    242 
    +    moduleName = ipMod infoProv,
    243 
    +    srcLoc = ipLoc infoProv,
    244 
    +    closureType = ipDesc infoProv
    245 
    +  }
    246 
    +
    247 
    +getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
    248 
    +getDecodedStackArray (StackSnapshot s) =
    249 
    +  IO $ \s0 -> case decodeStack# s s0 of
    250 
    +    (# s1, arr #) ->
    251 
    +      let n = I# (sizeofByteArray# arr) `div` wordSize - 1
    252 
    +       in unIO (go arr n) s1
    253 
    +  where
    254 
    +    go :: ByteArray# -> Int -> IO [Maybe StackEntry]
    255 
    +    go _stack (-1) = return []
    256 
    +    go stack i = do
    257 
    +      infoProv <- lookupIPE (stackEntryAt stack i)
    258 
    +      rest <- unsafeInterleaveIO $ go stack (i-1)
    259 
    +      return ((toStackEntry `fmap` infoProv) : rest)
    260 
    +
    261 
    +    stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable
    262 
    +    stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i)
    263 
    +
    264 
    +    wordSize = sizeOf (nullPtr :: Ptr ())
    265 
    +
    266 
    +prettyStackEntry :: StackEntry -> String
    267 
    +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
    268 
    +    "  " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    ... ... @@ -14,17 +14,7 @@
    14 14 
     {-# LANGUAGE UnliftedFFITypes #-}
    15 15
    16 16 
     module GHC.Internal.Stack.Decode (
    17 
    -  -- * High-level stack decoders
    18 
    -  decode,
    19 17 
       decodeStack,
    20 
    -  decodeStackWithIpe,
    21 
    -  -- * Stack decoder helpers
    22 
    -  decodeStackWithFrameUnpack,
    23 
    -  -- * StackEntry
    24 
    -  StackEntry(..),
    25 
    -  -- * Pretty printing
    26 
    -  prettyStackEntry,
    27 
    -  prettyStackFrameWithIpe,
    28 18 
       )
    29 19 
     where
    30 20
    ... ... @@ -34,14 +24,10 @@ import GHC.Internal.Real
    34 24 
     import GHC.Internal.Word
    35 25 
     import GHC.Internal.Num
    36 26 
     import GHC.Internal.Data.Bits
    37 
    -import GHC.Internal.Data.Functor
    38 
    -import GHC.Internal.Data.Maybe (catMaybes)
    39 27 
     import GHC.Internal.Data.List
    40 
    -import GHC.Internal.Data.Tuple
    41 28 
     import GHC.Internal.Foreign.Ptr
    42 29 
     import GHC.Internal.Foreign.Storable
    43 30 
     import GHC.Internal.Exts
    44 
    -import GHC.Internal.Unsafe.Coerce
    45 31
    46 32 
     import GHC.Internal.ClosureTypes
    47 33 
     import GHC.Internal.Heap.Closures
    ... ... @@ -55,10 +41,8 @@ import GHC.Internal.Heap.Closures
    55 41 
       )
    56 42 
     import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
    57 43 
     import GHC.Internal.Heap.InfoTable
    58 
    -import GHC.Internal.Stack.Annotation
    59 44 
     import GHC.Internal.Stack.Constants
    60 45 
     import GHC.Internal.Stack.CloneStack
    61 
    -import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
    62 46
    63 47 
     {- Note [Decoding the stack]
    64 48 
        ~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -170,17 +154,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
    170 154
    171 155 
     foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
    172 156
    173 
    -foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
    157 
    +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
    174 158
    175 159 
     foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
    176 160
    177 
    --- | Get the 'StgInfoTable' of the stack frame.
    178 
    --- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
    179 
    -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
    161 
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
    180 162 
     getInfoTableOnStack stackSnapshot# index =
    181 
    -  let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
    182 
    -   in
    183 
    -    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
    163 
    +  let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
    164 
    +   in peekItbl infoTablePtr
    184 165
    185 166 
     getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    186 167 
     getInfoTableForStack stackSnapshot# =
    ... ... @@ -299,66 +280,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
    299 280 
           (bitmapWordPointerness size bitmap)
    300 281
    301 282 
     unpackStackFrame :: StackFrameLocation -> IO StackFrame
    302 
    -unpackStackFrame stackFrameLoc = do
    303 
    -  unpackStackFrameTo stackFrameLoc
    304 
    -    (\ info _ nextChunk -> do
    305 
    -      stackClosure <- decodeStack nextChunk
    306 
    -      pure $
    307 
    -        UnderflowFrame
    308 
    -          { info_tbl = info,
    309 
    -            nextChunk = stackClosure
    310 
    -          }
    311 
    -    )
    312 
    -    (\ frame _ -> pure frame)
    313 
    -
    314 
    -unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
    315 
    -unpackStackFrameWithIpe stackFrameLoc = do
    316 
    -  unpackStackFrameTo stackFrameLoc
    317 
    -    (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
    318 
    -      framesWithIpe <- decodeStackWithIpe nextChunk
    319 
    -      pure
    320 
    -        [ ( UnderflowFrame
    321 
    -            { info_tbl = info,
    322 
    -              nextChunk =
    323 
    -                GenStgStackClosure
    324 
    -                  { ssc_info = info,
    325 
    -                    ssc_stack_size = getStackFields stack#,
    326 
    -                    ssc_stack = map fst framesWithIpe
    327 
    -                  }
    328 
    -            }
    329 
    -          , mIpe
    330 
    -          )
    331 
    -        ]
    332 
    -    )
    333 
    -    (\ frame mIpe -> pure [(frame, mIpe)])
    334 
    -
    335 
    -unpackStackFrameTo ::
    336 
    -  forall a .
    337 
    -  StackFrameLocation ->
    338 
    -  -- ^ Decode the given 'StackFrame'.
    339 
    -  (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
    340 
    -  -- ^ How to handle 'UNDERFLOW_FRAME's.
    341 
    -  (StackFrame -> Maybe InfoProv -> IO a) ->
    342 
    -  -- ^ How to handle all other 'StackFrame' values.
    343 
    -  IO a
    344 
    -unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
    345 
    -  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    283 
    +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    284 
    +  info <- getInfoTableOnStack stackSnapshot# index
    346 285 
       unpackStackFrame' info
    347 
    -    (unpackUnderflowFrame info m_info_prov)
    348 
    -    (`finaliseStackFrame` m_info_prov)
    349 286 
       where
    350 
    -    unpackStackFrame' ::
    351 
    -      StgInfoTable ->
    352 
    -      (StackSnapshot -> IO a) ->
    353 
    -      (StackFrame -> IO a) ->
    354 
    -      IO a
    355 
    -    unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
    287 
    +    unpackStackFrame' :: StgInfoTable -> IO StackFrame
    288 
    +    unpackStackFrame' info =
    356 289 
           case tipe info of
    357 290 
             RET_BCO -> do
    358 291 
               let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
    359 292 
               -- The arguments begin directly after the payload's one element
    360 293 
               bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
    361 
    -          mkStackFrameResult
    294 
    +          pure
    362 295 
                 RetBCO
    363 296 
                   { info_tbl = info,
    364 297 
                     bco = bco',
    ... ... @@ -367,14 +300,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    367 300 
             RET_SMALL ->
    368 301 
               let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
    369 302 
               in
    370 
    -            mkStackFrameResult $
    303 
    +            pure $
    371 304 
                   RetSmall
    372 305 
                     { info_tbl = info,
    373 306 
                       stack_payload = payload'
    374 307 
                     }
    375 308 
             RET_BIG -> do
    376 309 
               payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
    377 
    -          mkStackFrameResult $
    310 
    +          pure $
    378 311 
                 RetBig
    379 312 
                   { info_tbl = info,
    380 313 
                     stack_payload = payload'
    ... ... @@ -386,7 +319,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    386 319 
                 if isArgGenBigRetFunType stackSnapshot# index == True
    387 320 
                   then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    388 321 
                   else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    389 
    -          mkStackFrameResult $
    322 
    +          pure $
    390 323 
                 RetFun
    391 324 
                   { info_tbl = info,
    392 325 
                     retFunSize = retFunSize',
    ... ... @@ -396,26 +329,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    396 329 
             UPDATE_FRAME ->
    397 330 
               let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
    398 331 
               in
    399 
    -            mkStackFrameResult $
    332 
    +            pure $
    400 333 
                   UpdateFrame
    401 334 
                     { info_tbl = info,
    402 335 
                       updatee = updatee'
    403 336 
                     }
    404 337 
             CATCH_FRAME -> do
    405 338 
               let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
    406 
    -          mkStackFrameResult $
    339 
    +          pure $
    407 340 
                 CatchFrame
    408 341 
                   { info_tbl = info,
    409 342 
                     handler = handler'
    410 343 
                   }
    411 344 
             UNDERFLOW_FRAME -> do
    412 345 
               let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
    413 
    -          mkUnderflowResult nextChunk'
    414 
    -        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
    346 
    +          stackClosure <- decodeStack nextChunk'
    347 
    +          pure $
    348 
    +            UnderflowFrame
    349 
    +              { info_tbl = info,
    350 
    +                nextChunk = stackClosure
    351 
    +              }
    352 
    +        STOP_FRAME -> pure $ StopFrame {info_tbl = info}
    415 353 
             ATOMICALLY_FRAME -> do
    416 354 
               let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
    417 355 
                   result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
    418 
    -          mkStackFrameResult $
    356 
    +          pure $
    419 357 
                 AtomicallyFrame
    420 358 
                   { info_tbl = info,
    421 359 
                     atomicallyFrameCode = atomicallyFrameCode',
    ... ... @@ -426,7 +364,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    426 364 
                   first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
    427 365 
                   alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
    428 366 
               in
    429 
    -            mkStackFrameResult $
    367 
    +            pure $
    430 368 
                   CatchRetryFrame
    431 369 
                     { info_tbl = info,
    432 370 
                       running_alt_code = running_alt_code',
    ... ... @@ -437,7 +375,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    437 375 
               let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
    438 376 
                   handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
    439 377 
               in
    440 
    -            mkStackFrameResult $
    378 
    +            pure $
    441 379 
                   CatchStmFrame
    442 380 
                     { info_tbl = info,
    443 381 
                       catchFrameCode = catchFrameCode',
    ... ... @@ -446,7 +384,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    446 384 
             ANN_FRAME ->
    447 385 
               let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
    448 386 
                in
    449 
    -             mkStackFrameResult $
    387 
    +             pure $
    450 388 
                    AnnFrame
    451 389 
                     { info_tbl = info,
    452 390 
                       annotation = annotation
    ... ... @@ -464,54 +402,6 @@ intToWord# i = int2Word# (toInt# i)
    464 402 
     wordOffsetToWord# :: WordOffset -> Word#
    465 403 
     wordOffsetToWord# wo = intToWord# (fromIntegral wo)
    466 404
    467 
    --- ----------------------------------------------------------------------------
    468 
    --- Simplified source location representation of provenance information
    469 
    --- ----------------------------------------------------------------------------
    470 
    -
    471 
    --- | Representation for the source location where a return frame was pushed on the stack.
    472 
    --- This happens every time when a @case ... of@ scrutinee is evaluated.
    473 
    -data StackEntry = StackEntry
    474 
    -  { functionName :: String,
    475 
    -    moduleName :: String,
    476 
    -    srcLoc :: String,
    477 
    -    closureType :: ClosureType
    478 
    -  }
    479 
    -  deriving (Show, Eq)
    480 
    -
    481 
    -toStackEntry :: InfoProv -> StackEntry
    482 
    -toStackEntry infoProv =
    483 
    -  StackEntry
    484 
    -  { functionName = ipLabel infoProv,
    485 
    -    moduleName = ipMod infoProv,
    486 
    -    srcLoc = ipLoc infoProv,
    487 
    -    closureType = ipDesc infoProv
    488 
    -  }
    489 
    -
    490 
    --- ----------------------------------------------------------------------------
    491 
    --- Stack decoders
    492 
    --- ----------------------------------------------------------------------------
    493 
    -
    494 
    --- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
    495 
    --- The stack trace is created from return frames with according 'InfoProvEnt'
    496 
    --- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
    497 
    --- no 'InfoProvEnt' entries, an empty list is returned.
    498 
    ---
    499 
    --- Please note:
    500 
    ---
    501 
    ---   * To gather 'StackEntry' from libraries, these have to be
    502 
    ---     compiled with @-finfo-table-map@, too.
    503 
    ---   * Due to optimizations by GHC (e.g. inlining) the stacktrace may change
    504 
    ---     with different GHC parameters and versions.
    505 
    ---   * The stack trace is empty (by design) if there are no return frames on
    506 
    ---     the stack. (These are pushed every time when a @case ... of@ scrutinee
    507 
    ---     is evaluated.)
    508 
    ---
    509 
    --- @since base-4.17.0.0
    510 
    -decode :: StackSnapshot -> IO [StackEntry]
    511 
    -decode stackSnapshot =
    512 
    -  (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot
    513 
    -
    514 
    -
    515 405 
     -- | Location of a stackframe on the stack
    516 406 
     --
    517 407 
     -- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
    ... ... @@ -524,31 +414,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
    524 414 
     --
    525 415 
     -- See /Note [Decoding the stack]/.
    526 416 
     decodeStack :: StackSnapshot -> IO StgStackClosure
    527 
    -decodeStack snapshot@(StackSnapshot stack#) = do
    528 
    -  (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
    529 
    -  pure
    530 
    -    GenStgStackClosure
    531 
    -      { ssc_info = stackInfo,
    532 
    -        ssc_stack_size = getStackFields stack#,
    533 
    -        ssc_stack = ssc_stack
    534 
    -      }
    535 
    -
    536 
    -decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
    537 
    -decodeStackWithIpe snapshot =
    538 
    -  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
    539 
    -
    540 
    --- ----------------------------------------------------------------------------
    541 
    --- Write your own stack decoder!
    542 
    --- ----------------------------------------------------------------------------
    543 
    -
    544 
    -decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
    545 
    -decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    417 
    +decodeStack (StackSnapshot stack#) = do
    546 418 
       info <- getInfoTableForStack stack#
    547 419 
       case tipe info of
    548 420 
         STACK -> do
    549 
    -      let sfls = stackFrameLocations stack#
    550 
    -      stack' <- mapM unpackFrame sfls
    551 
    -      pure (info, stack')
    421 
    +      let stack_size' = getStackFields stack#
    422 
    +          sfls = stackFrameLocations stack#
    423 
    +      stack' <- mapM unpackStackFrame sfls
    424 
    +      pure $
    425 
    +        GenStgStackClosure
    426 
    +          { ssc_info = info,
    427 
    +            ssc_stack_size = stack_size',
    428 
    +            ssc_stack = stack'
    429 
    +          }
    552 430 
         _ -> error $ "Expected STACK closure, got " ++ show info
    553 431 
       where
    554 432 
         stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
    ... ... @@ -559,21 +437,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    559 437 
             go :: Maybe StackFrameLocation -> [StackFrameLocation]
    560 438 
             go Nothing = []
    561 439 
             go (Just r) = r : go (advanceStackFrameLocation r)
    562 
    -
    563 
    --- ----------------------------------------------------------------------------
    564 
    --- Pretty printing functions for stack entries, stack frames and provenance info
    565 
    --- ----------------------------------------------------------------------------
    566 
    -
    567 
    -prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
    568 
    -prettyStackFrameWithIpe (frame, mipe) =
    569 
    -  case frame of
    570 
    -    AnnFrame {annotation = Box someStackAnno } ->
    571 
    -      case unsafeCoerce someStackAnno of
    572 
    -        SomeStackAnnotation ann ->
    573 
    -          Just $ displayStackAnnotation ann
    574 
    -    _ ->
    575 
    -      (prettyStackEntry . toStackEntry) <$> mipe
    576 
    -
    577 
    -prettyStackEntry :: StackEntry -> String
    578 
    -prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
    579 
    -  mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"

  • libraries/ghc-internal/tests/backtraces/T26507.hs
    1 
    +import GHC.Internal.Control.Exception
    2 
    +import GHC.Internal.Exception.Backtrace
    3 
    +
    4 
    +main :: IO ()
    5 
    +main = do
    6 
    +  setBacktraceMechanismState IPEBacktrace True
    7 
    +  throwIO $ ErrorCall "Throw error"

  • libraries/ghc-internal/tests/backtraces/T26507.stderr
    1 
    +T26507: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
    2 
    +
    3 
    +Throw error
    4 
    +
    5 
    +IPE backtrace:
    6 
    +HasCallStack backtrace:
    7 
    +  throwIO, called at T26507.hs:7:3 in main:Main
    8 
    +

  • libraries/ghc-internal/tests/backtraces/all.T
    1 1 
     test('T14532a', [], compile_and_run, [''])
    2 2 
     test('T14532b', [], compile_and_run, [''])
    3 
    +test('T26507', [extra_ways(['prof']), when(js_arch(), skip), exit_code(1)], compile_and_run, [''])
    4 
    +

  • testsuite/tests/interface-stability/base-exports.stdout
    ... ... @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11682 11682 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11683 11683 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11684 11684 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11685 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11685 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11686 11686 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11687 11687 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11688 11688 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13197 13197 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13198 13198 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13199 13199 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13200 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13201 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13200 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13202 13201 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13203 13202 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13204 13203 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
    ... ... @@ -14717,7 +14717,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    14717 14717 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    14718 14718 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    14719 14719 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    14720 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    14720 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    14721 14721 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    14722 14722 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    14723 14723 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -16229,8 +16229,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    16229 16229 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    16230 16230 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    16231 16231 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    16232 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    16233 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    16232 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    16234 16233 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    16235 16234 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    16236 16235 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-mingw32
    ... ... @@ -11938,7 +11938,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11938 11938 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11939 11939 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11940 11940 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11941 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11941 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11942 11942 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11943 11943 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11944 11944 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13469,8 +13469,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13469 13469 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13470 13470 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13471 13471 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13472 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13473 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13472 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13474 13473 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13475 13474 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13476 13475 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-ws-32
    ... ... @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11682 11682 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11683 11683 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11684 11684 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11685 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11685 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11686 11686 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11687 11687 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11688 11688 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13197 13197 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13198 13198 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13199 13199 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13200 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13201 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13200 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13202 13201 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13203 13202 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13204 13203 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

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