Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • hadrian/src/Rules/ToolArgs.hs
    ... ... @@ -160,7 +160,7 @@ toolTargets = [ cabalSyntax
    160 160 
                   , ghcPlatform
    161 161 
                   , ghcToolchain
    162 162 
                   , ghcToolchainBin
    163 
    -              , ghcHeap
    163 
    +              -- , ghcHeap -- # depends on ghcInternal library
    164 164 
                   , ghci
    165 165 
                   , ghcPkg  -- # executable
    166 166 
                   , haddock -- # depends on ghc library

  • libraries/base/src/GHC/Stack/CloneStack.hs
    ... ... @@ -17,3 +17,4 @@ 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*) 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_entry;
    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_entry  = %GET_ENTRY(UNTAG(p));
    156 
    +  return (info_struct, info_entry);
    157 157 
     }
    158 158
    159 159 
     // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)

  • libraries/ghc-internal/cbits/StackCloningDecoding.cmm
    ... ... @@ -17,10 +17,3 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) {
    17 17
    18 18 
         return ();
    19 19 
     }
    20 
    -
    21 
    -stg_decodeStackzh (gcptr stgStack) {
    22 
    -    gcptr stackEntries;
    23 
    -    ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr");
    24 
    -
    25 
    -    return (stackEntries);
    26 
    -}

  • libraries/ghc-internal/jsbits/base.js
    ... ... @@ -1245,9 +1245,8 @@ 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, h$stg_decodeStackzh
    1248 
    +var h$stg_cloneMyStackzh
    1249 1249 
     h$stg_cloneMyStackzh
    1250 
    -  = h$stg_decodeStackzh
    1251 1250 
       = function () {
    1252 1251 
         throw new Error('Stack Cloning Decoding: Not Implemented Yet')
    1253 1252 
       }

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -16,6 +16,7 @@ import qualified GHC.Internal.Stack as HCS
    16 16 
     import qualified GHC.Internal.ExecutionStack as ExecStack
    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
    19 20 
     import qualified GHC.Internal.Stack.CCS as CCS
    20 21
    21 22 
     -- | How to collect a backtrace when an exception is thrown.

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

  • rts/CloneStack.c
    ... ... @@ -26,11 +26,6 @@
    26 26 
     #include <string.h>
    27 27
    28 28
    29 
    -static StgWord getStackFrameCount(StgStack* stack);
    30 
    -static StgWord getStackChunkClosureCount(StgStack* stack);
    31 
    -static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes);
    32 
    -static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack);
    33 
    -
    34 29 
     static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
    35 30 
     {
    36 31 
       StgWord spOffset = stack->sp - stack->stack;
    ... ... @@ -112,94 +107,3 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED)
    112 107 
     }
    113 108
    114 109 
     #endif // end !defined(THREADED_RTS)
    115 
    -
    116 
    -// Creates a MutableArray# (Haskell representation) that contains a
    117 
    -// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the
    118 
    -// array is the count of stack frames.
    119 
    -// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack
    120 
    -// frame it's represented by null.
    121 
    -StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) {
    122 
    -  StgWord closureCount = getStackFrameCount(stack);
    123 
    -
    124 
    -  StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount);
    125 
    -
    126 
    -  copyPtrsToArray(array, stack);
    127 
    -
    128 
    -  return array;
    129 
    -}
    130 
    -
    131 
    -// Count the stack frames that are on the given stack.
    132 
    -// This is the sum of all stack frames in all stack chunks of this stack.
    133 
    -StgWord getStackFrameCount(StgStack* stack) {
    134 
    -  StgWord closureCount = 0;
    135 
    -  StgStack *last_stack = stack;
    136 
    -  while (true) {
    137 
    -    closureCount += getStackChunkClosureCount(last_stack);
    138 
    -
    139 
    -    // check whether the stack ends in an underflow frame
    140 
    -    StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack
    141 
    -      + last_stack->stack_size - sizeofW(StgUnderflowFrame));
    142 
    -    if (frame->info == &stg_stack_underflow_frame_d_info
    143 
    -      ||frame->info == &stg_stack_underflow_frame_v16_info
    144 
    -      ||frame->info == &stg_stack_underflow_frame_v32_info
    145 
    -      ||frame->info == &stg_stack_underflow_frame_v64_info) {
    146 
    -      last_stack = frame->next_chunk;
    147 
    -    } else {
    148 
    -      break;
    149 
    -    }
    150 
    -  }
    151 
    -  return closureCount;
    152 
    -}
    153 
    -
    154 
    -StgWord getStackChunkClosureCount(StgStack* stack) {
    155 
    -    StgWord closureCount = 0;
    156 
    -    StgPtr sp = stack->sp;
    157 
    -    StgPtr spBottom = stack->stack + stack->stack_size;
    158 
    -    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
    159 
    -      closureCount++;
    160 
    -    }
    161 
    -
    162 
    -    return closureCount;
    163 
    -}
    164 
    -
    165 
    -// Allocate and initialize memory for a ByteArray# (Haskell representation).
    166 
    -StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) {
    167 
    -  // Idea stolen from PrimOps.cmm:stg_newArrayzh()
    168 
    -  StgWord words = sizeofW(StgArrBytes) + bytes;
    169 
    -
    170 
    -  StgArrBytes* array = (StgArrBytes*) allocate(cap, words);
    171 
    -
    172 
    -  SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
    173 
    -  array->bytes  = bytes;
    174 
    -  return array;
    175 
    -}
    176 
    -
    177 
    -static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) {
    178 
    -  StgWord index = 0;
    179 
    -  StgStack *last_stack = stack;
    180 
    -  const StgInfoTable **result = (const StgInfoTable **) arr->payload;
    181 
    -  while (true) {
    182 
    -    StgPtr sp = last_stack->sp;
    183 
    -    StgPtr spBottom = last_stack->stack + last_stack->stack_size;
    184 
    -    for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
    185 
    -      const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info;
    186 
    -      result[index] = infoTable;
    187 
    -      index++;
    188 
    -    }
    189 
    -
    190 
    -    // Ensure that we didn't overflow the result array
    191 
    -    ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*));
    192 
    -
    193 
    -    // check whether the stack ends in an underflow frame
    194 
    -    StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack
    195 
    -      + last_stack->stack_size - sizeofW(StgUnderflowFrame));
    196 
    -    if (frame->info == &stg_stack_underflow_frame_d_info
    197 
    -      ||frame->info == &stg_stack_underflow_frame_v16_info
    198 
    -      ||frame->info == &stg_stack_underflow_frame_v32_info
    199 
    -      ||frame->info == &stg_stack_underflow_frame_v64_info) {
    200 
    -      last_stack = frame->next_chunk;
    201 
    -    } else {
    202 
    -      break;
    203 
    -    }
    204 
    -  }
    205 
    -}

  • rts/CloneStack.h
    ... ... @@ -15,8 +15,6 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack);
    15 15
    16 16 
     void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
    17 17
    18 
    -StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack);
    19 
    -
    20 18 
     #include "BeginPrivate.h"
    21 19
    22 20 
     #if defined(THREADED_RTS)

  • rts/RtsSymbols.c
    ... ... @@ -950,7 +950,6 @@ extern char **environ;
    950 950 
           SymI_HasProto(lookupIPE)                                          \
    951 951 
           SymI_HasProto(sendCloneStackMessage)                              \
    952 952 
           SymI_HasProto(cloneStack)                                         \
    953 
    -      SymI_HasProto(decodeClonedStack)                                  \
    954 953 
           SymI_HasProto(stg_newPromptTagzh)                                 \
    955 954 
           SymI_HasProto(stg_promptzh)                                       \
    956 955 
           SymI_HasProto(stg_control0zh)                                     \

  • testsuite/tests/interface-stability/base-exports.stdout
    ... ... @@ -11678,7 +11678,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11678 11678 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11679 11679 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11680 11680 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11681 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11681 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11682 11682 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11683 11683 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11684 11684 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13137,7 +13137,8 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13137 13137 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13138 13138 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13139 13139 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13140 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13140 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13141 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13141 13142 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13142 13143 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13143 13144 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
    ... ... @@ -14713,7 +14713,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    14713 14713 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    14714 14714 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    14715 14715 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    14716 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    14716 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    14717 14717 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    14718 14718 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    14719 14719 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -16169,7 +16169,8 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    16169 16169 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    16170 16170 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    16171 16171 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    16172 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    16172 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    16173 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    16173 16174 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    16174 16175 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    16175 16176 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-mingw32
    ... ... @@ -11934,7 +11934,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11934 11934 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11935 11935 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11936 11936 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11937 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11937 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11938 11938 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11939 11939 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11940 11940 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13409,7 +13409,8 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13409 13409 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13410 13410 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13411 13411 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13412 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13412 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13413 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13413 13414 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13414 13415 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13415 13416 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’

  • testsuite/tests/interface-stability/base-exports.stdout-ws-32
    ... ... @@ -11678,7 +11678,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in
    11678 11678 
     instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’
    11679 11679 
     instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’
    11680 11680 
     instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’
    11681 
    -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    11681 
    +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    11682 11682 
     instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’
    11683 11683 
     instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’
    11684 11684 
     instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’
    ... ... @@ -13137,7 +13137,8 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS
    13137 13137 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’
    13138 13138 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’
    13139 13139 
     instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’
    13140 
    -instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’
    13140 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’
    13141 
    +instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’
    13141 13142 
     instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’
    13142 13143 
     instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’
    13143 13144 
     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