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,10 +24,7 @@ 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
    ... ... @@ -58,7 +45,6 @@ import GHC.Internal.Heap.InfoTable
    58 45 
     import GHC.Internal.Stack.Annotation
    59 46 
     import GHC.Internal.Stack.Constants
    60 47 
     import GHC.Internal.Stack.CloneStack
    61 
    -import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
    62 48
    63 49 
     {- Note [Decoding the stack]
    64 50 
        ~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -170,17 +156,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
    170 156
    171 157 
     foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
    172 158
    173 
    -foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
    159 
    +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
    174 160
    175 161 
     foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
    176 162
    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)
    163 
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
    180 164 
     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#)
    165 
    +  let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
    166 
    +   in peekItbl infoTablePtr
    184 167
    185 168 
     getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    186 169 
     getInfoTableForStack stackSnapshot# =
    ... ... @@ -299,66 +282,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
    299 282 
           (bitmapWordPointerness size bitmap)
    300 283
    301 284 
     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
    285 
    +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    286 
    +  info <- getInfoTableOnStack stackSnapshot# index
    346 287 
       unpackStackFrame' info
    347 
    -    (unpackUnderflowFrame info m_info_prov)
    348 
    -    (`finaliseStackFrame` m_info_prov)
    349 288 
       where
    350 
    -    unpackStackFrame' ::
    351 
    -      StgInfoTable ->
    352 
    -      (StackSnapshot -> IO a) ->
    353 
    -      (StackFrame -> IO a) ->
    354 
    -      IO a
    355 
    -    unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
    289 
    +    unpackStackFrame' :: StgInfoTable -> IO StackFrame
    290 
    +    unpackStackFrame' info =
    356 291 
           case tipe info of
    357 292 
             RET_BCO -> do
    358 293 
               let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
    359 294 
               -- The arguments begin directly after the payload's one element
    360 295 
               bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
    361 
    -          mkStackFrameResult
    296 
    +          pure
    362 297 
                 RetBCO
    363 298 
                   { info_tbl = info,
    364 299 
                     bco = bco',
    ... ... @@ -367,14 +302,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    367 302 
             RET_SMALL ->
    368 303 
               let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
    369 304 
               in
    370 
    -            mkStackFrameResult $
    305 
    +            pure $
    371 306 
                   RetSmall
    372 307 
                     { info_tbl = info,
    373 308 
                       stack_payload = payload'
    374 309 
                     }
    375 310 
             RET_BIG -> do
    376 311 
               payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
    377 
    -          mkStackFrameResult $
    312 
    +          pure $
    378 313 
                 RetBig
    379 314 
                   { info_tbl = info,
    380 315 
                     stack_payload = payload'
    ... ... @@ -386,7 +321,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    386 321 
                 if isArgGenBigRetFunType stackSnapshot# index == True
    387 322 
                   then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    388 323 
                   else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
    389 
    -          mkStackFrameResult $
    324 
    +          pure $
    390 325 
                 RetFun
    391 326 
                   { info_tbl = info,
    392 327 
                     retFunSize = retFunSize',
    ... ... @@ -396,26 +331,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    396 331 
             UPDATE_FRAME ->
    397 332 
               let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
    398 333 
               in
    399 
    -            mkStackFrameResult $
    334 
    +            pure $
    400 335 
                   UpdateFrame
    401 336 
                     { info_tbl = info,
    402 337 
                       updatee = updatee'
    403 338 
                     }
    404 339 
             CATCH_FRAME -> do
    405 340 
               let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
    406 
    -          mkStackFrameResult $
    341 
    +          pure $
    407 342 
                 CatchFrame
    408 343 
                   { info_tbl = info,
    409 344 
                     handler = handler'
    410 345 
                   }
    411 346 
             UNDERFLOW_FRAME -> do
    412 347 
               let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
    413 
    -          mkUnderflowResult nextChunk'
    414 
    -        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
    348 
    +          stackClosure <- decodeStack nextChunk'
    349 
    +          pure $
    350 
    +            UnderflowFrame
    351 
    +              { info_tbl = info,
    352 
    +                nextChunk = stackClosure
    353 
    +              }
    354 
    +        STOP_FRAME -> pure $ StopFrame {info_tbl = info}
    415 355 
             ATOMICALLY_FRAME -> do
    416 356 
               let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
    417 357 
                   result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
    418 
    -          mkStackFrameResult $
    358 
    +          pure $
    419 359 
                 AtomicallyFrame
    420 360 
                   { info_tbl = info,
    421 361 
                     atomicallyFrameCode = atomicallyFrameCode',
    ... ... @@ -426,7 +366,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    426 366 
                   first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
    427 367 
                   alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
    428 368 
               in
    429 
    -            mkStackFrameResult $
    369 
    +            pure $
    430 370 
                   CatchRetryFrame
    431 371 
                     { info_tbl = info,
    432 372 
                       running_alt_code = running_alt_code',
    ... ... @@ -437,7 +377,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    437 377 
               let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
    438 378 
                   handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
    439 379 
               in
    440 
    -            mkStackFrameResult $
    380 
    +            pure $
    441 381 
                   CatchStmFrame
    442 382 
                     { info_tbl = info,
    443 383 
                       catchFrameCode = catchFrameCode',
    ... ... @@ -446,7 +386,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    446 386 
             ANN_FRAME ->
    447 387 
               let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
    448 388 
                in
    449 
    -             mkStackFrameResult $
    389 
    +             pure $
    450 390 
                    AnnFrame
    451 391 
                     { info_tbl = info,
    452 392 
                       annotation = annotation
    ... ... @@ -464,54 +404,6 @@ intToWord# i = int2Word# (toInt# i)
    464 404 
     wordOffsetToWord# :: WordOffset -> Word#
    465 405 
     wordOffsetToWord# wo = intToWord# (fromIntegral wo)
    466 406
    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 407 
     -- | Location of a stackframe on the stack
    516 408 
     --
    517 409 
     -- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
    ... ... @@ -524,31 +416,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
    524 416 
     --
    525 417 
     -- See /Note [Decoding the stack]/.
    526 418 
     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
    419 
    +decodeStack (StackSnapshot stack#) = do
    546 420 
       info <- getInfoTableForStack stack#
    547 421 
       case tipe info of
    548 422 
         STACK -> do
    549 
    -      let sfls = stackFrameLocations stack#
    550 
    -      stack' <- mapM unpackFrame sfls
    551 
    -      pure (info, stack')
    423 
    +      let stack_size' = getStackFields stack#
    424 
    +          sfls = stackFrameLocations stack#
    425 
    +      stack' <- mapM unpackStackFrame sfls
    426 
    +      pure $
    427 
    +        GenStgStackClosure
    428 
    +          { ssc_info = info,
    429 
    +            ssc_stack_size = stack_size',
    430 
    +            ssc_stack = stack'
    431 
    +          }
    552 432 
         _ -> error $ "Expected STACK closure, got " ++ show info
    553 433 
       where
    554 434 
         stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
    ... ... @@ -559,21 +439,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    559 439 
             go :: Maybe StackFrameLocation -> [StackFrameLocation]
    560 440 
             go Nothing = []
    561 441 
             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