Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc
    ... ... @@ -15,6 +15,7 @@ module GHC.Internal.InfoProv.Types
    15 15
         , getIPE
    
    16 16
         , StgInfoTable
    
    17 17
         , lookupIPE
    
    18
    +    , lookupIpProvId
    
    18 19
         ) where
    
    19 20
     
    
    20 21
     import GHC.Internal.Base
    
    ... ... @@ -60,6 +61,13 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do
    60 61
         1 -> Just `fmap` peekInfoProv (ipeProv p)
    
    61 62
         _ -> return Nothing
    
    62 63
     
    
    64
    +lookupIpProvId :: Ptr StgInfoTable -> IO (Maybe Word64)
    
    65
    +lookupIpProvId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do
    
    66
    +  res <- c_lookupIPE itbl p
    
    67
    +  case res of
    
    68
    +    1 -> Just `fmap` peekIpProvId (ipeProv p)
    
    69
    +    _ -> return Nothing
    
    70
    +
    
    63 71
     getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r
    
    64 72
     getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s ->
    
    65 73
       case whereFrom## obj (unPtr p) s of
    

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    ... ... @@ -25,6 +25,10 @@ module GHC.Internal.Stack.Decode (
    25 25
       -- * Pretty printing
    
    26 26
       prettyStackEntry,
    
    27 27
       prettyStackFrameWithIpe,
    
    28
    +  -- * Low level decoding functions
    
    29
    +  StackFrameLocation(..),
    
    30
    +  unpackStackFrameTo,
    
    31
    +  getStackFields,
    
    28 32
       )
    
    29 33
     where
    
    30 34
     
    
    ... ... @@ -59,6 +63,7 @@ import GHC.Internal.Stack.Annotation
    59 63
     import GHC.Internal.Stack.Constants
    
    60 64
     import GHC.Internal.Stack.CloneStack
    
    61 65
     import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
    
    66
    +import qualified GHC.Internal.InfoProv.Types as IPE
    
    62 67
     
    
    63 68
     {- Note [Decoding the stack]
    
    64 69
        ~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ... ... @@ -176,11 +181,11 @@ foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSna
    176 181
     
    
    177 182
     -- | Get the 'StgInfoTable' of the stack frame.
    
    178 183
     -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
    
    179
    -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
    
    184
    +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Ptr IPE.StgInfoTable)
    
    180 185
     getInfoTableOnStack stackSnapshot# index =
    
    181 186
       let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
    
    182 187
        in
    
    183
    -    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
    
    188
    +    (,) <$> peekItbl (Ptr itbl_struct#) <*> pure (Ptr itbl_ptr_ipe_key#)
    
    184 189
     
    
    185 190
     getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
    
    186 191
     getInfoTableForStack stackSnapshot# =
    
    ... ... @@ -314,8 +319,9 @@ unpackStackFrame stackFrameLoc = do
    314 319
     unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
    
    315 320
     unpackStackFrameWithIpe stackFrameLoc = do
    
    316 321
       unpackStackFrameTo stackFrameLoc
    
    317
    -    (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
    
    322
    +    (\ info infoKey nextChunk@(StackSnapshot stack#) -> do
    
    318 323
           framesWithIpe <- decodeStackWithIpe nextChunk
    
    324
    +      mIpe <- lookupIPE infoKey
    
    319 325
           pure
    
    320 326
             [ ( UnderflowFrame
    
    321 327
                 { info_tbl = info,
    
    ... ... @@ -330,22 +336,26 @@ unpackStackFrameWithIpe stackFrameLoc = do
    330 336
               )
    
    331 337
             ]
    
    332 338
         )
    
    333
    -    (\ frame mIpe -> pure [(frame, mIpe)])
    
    339
    +    (\ frame infoKey -> do
    
    340
    +      mIpe <- lookupIPE infoKey
    
    341
    +      pure [(frame, mIpe)])
    
    334 342
     
    
    335 343
     unpackStackFrameTo ::
    
    336 344
       forall a .
    
    337 345
       StackFrameLocation ->
    
    338 346
       -- ^ Decode the given 'StackFrame'.
    
    339
    -  (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
    
    347
    +  (StgInfoTable -> Ptr IPE.StgInfoTable -> StackSnapshot -> IO a) ->
    
    340 348
       -- ^ How to handle 'UNDERFLOW_FRAME's.
    
    341
    -  (StackFrame -> Maybe InfoProv -> IO a) ->
    
    349
    +  -- The pointer is the key for the 'lookupIPE'.
    
    350
    +  (StackFrame -> Ptr IPE.StgInfoTable -> IO a) ->
    
    342 351
       -- ^ How to handle all other 'StackFrame' values.
    
    352
    +  -- The pointer is the key for the 'lookupIPE'.
    
    343 353
       IO a
    
    344 354
     unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
    
    345
    -  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    
    355
    +  (info, infoTablePtr) <- getInfoTableOnStack stackSnapshot# index
    
    346 356
       unpackStackFrame' info
    
    347
    -    (unpackUnderflowFrame info m_info_prov)
    
    348
    -    (`finaliseStackFrame` m_info_prov)
    
    357
    +    (unpackUnderflowFrame info infoTablePtr)
    
    358
    +    (`finaliseStackFrame` infoTablePtr)
    
    349 359
       where
    
    350 360
         unpackStackFrame' ::
    
    351 361
           StgInfoTable ->