[Git][ghc/ghc][wip/decode_cloned_stack] 3 commits: Get rid of StackFrameIter
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Apr 15 15:44:09 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
1a05765e by Sven Tennie at 2023-04-15T15:01:34+00:00
Get rid of StackFrameIter
- - - - -
bfc556e1 by Sven Tennie at 2023-04-15T15:07:44+00:00
Formatting
- - - - -
46e8e371 by Sven Tennie at 2023-04-15T15:42:47+00:00
Add docs / rename
- - - - -
2 changed files:
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/cbits/Stack.cmm
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -18,21 +18,27 @@ module GHC.Exts.Stack.Decode
)
where
+import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import GHC.Exts
+import GHC.Exts.Heap (Box (..), getBoxedClosureData)
import GHC.Exts.Heap.ClosureTypes
-import GHC.Exts.Heap.Closures (RetFunType(..), Closure, GenClosure(UnknownTypeWordSizedPrimitive), StackFrame(..), StgStackClosure(..))
+import GHC.Exts.Heap.Closures
+ ( Closure,
+ GenClosure (UnknownTypeWordSizedPrimitive),
+ RetFunType (..),
+ StackFrame (..),
+ StgStackClosure (..),
+ )
import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
-import GHC.Exts.Heap (Box(..), getBoxedClosureData)
import GHC.Exts.Heap.InfoTable
import GHC.Exts.Stack.Constants
import GHC.IO (IO (..))
import GHC.Stack.CloneStack
import GHC.Word
import Prelude
-import Debug.Trace
{- Note [Decoding the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -146,6 +152,11 @@ getRetFunType stackSnapshot# index =
(# s1, rft# #) -> (# s1, W# rft# #)
)
+-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. The
+-- `RealWorld` token is used to run this in an `IO` context.
type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
@@ -154,6 +165,11 @@ foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGette
foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter
+-- | Gets contents of a small bitmap (fitting in one @StgWord@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the bitmap and it's size. The `RealWorld` token is used to run
+-- this in an `IO` context.
type SmallBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
@@ -188,24 +204,24 @@ getStackFields stackSnapshot# = IO $ \s ->
(# s1, sSize#, sDirty#, sMarking# #) ->
(# s1, (W32# sSize#, W8# sDirty#, W8# sMarking#) #)
--- | Get an interator starting with the top-most stack frame
-stackHead :: StackSnapshot -> (StackSnapshot, WordOffset)
+-- | `StackFrameLocation` of the top-most stack frame
+stackHead :: StackSnapshot -> StackFrameLocation
stackHead (StackSnapshot s#) = (StackSnapshot s#, 0) -- GHC stacks are never empty
-- | Advance to the next stack frame (if any)
--
-- The last `Int#` in the result tuple is meant to be treated as bool
-- (has_next).
-foreign import prim "advanceStackFrameIterzh"
- advanceStackFrameIter# ::
+foreign import prim "advanceStackFrameLocationzh"
+ advanceStackFrameLocation# ::
StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
--- | Advance iterator to the next stack frame (if any)
-advanceStackFrameIter :: StackSnapshot -> WordOffset -> Maybe (StackSnapshot, WordOffset)
-advanceStackFrameIter (StackSnapshot stackSnapshot#) index =
- let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
+-- | Advance to the next stack frame (if any)
+advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
+advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
+ let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)
in if I# hasNext > 0
- then Just $ (StackSnapshot s', (primWordToWordOffset i'))
+ then Just (StackSnapshot s', primWordToWordOffset i')
else Nothing
where
primWordToWordOffset :: Word# -> WordOffset
@@ -223,49 +239,45 @@ getClosure stackSnapshot# index =
)
>>= getBoxedClosureData
--- | Iterator state for stack decoding
-data StackFrameIter
- = -- | Represents a closure on the stack
- SfiClosure !StackSnapshot# !WordOffset
- | -- | Represents a primitive word on the stack
- SfiPrimitive !StackSnapshot# !WordOffset
-
+-- | Representation of @StgLargeBitmap@ (RTS)
data LargeBitmap = LargeBitmap
- { largeBitmapSize :: Word
- , largebitmapWords :: Ptr Word
- }
+ { largeBitmapSize :: Word,
+ largebitmapWords :: Ptr Word
+ }
-- | Is a bitmap entry a closure pointer or a primitive non-pointer?
data Pointerness = Pointer | NonPointer
- deriving Show
+ deriving (Show)
decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
largeBitmap <- IO $ \s ->
case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, wordsAddr#, size# #) -> (# s1, LargeBitmap (W# size#) (Ptr wordsAddr#) #)
- bitmapWords <-largeBitmapToList largeBitmap
- decodeBitmaps stackSnapshot#
+ bitmapWords <- largeBitmapToList largeBitmap
+ decodeBitmaps
+ stackSnapshot#
(index + relativePayloadOffset)
(bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords)
where
largeBitmapToList :: LargeBitmap -> IO [Word]
- largeBitmapToList LargeBitmap {..} = cWordArrayToList largebitmapWords $
- (usedBitmapWords.fromIntegral) largeBitmapSize
+ largeBitmapToList LargeBitmap {..} =
+ cWordArrayToList largebitmapWords $
+ (usedBitmapWords . fromIntegral) largeBitmapSize
cWordArrayToList :: Ptr Word -> Int -> IO [Word]
- cWordArrayToList ptr size = mapM (peekElemOff ptr) [0..(size-1)]
+ cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)]
usedBitmapWords :: Int -> Int
usedBitmapWords 0 = error "Invalid large bitmap size 0."
- usedBitmapWords size = (size `div` (fromIntegral wORD_SIZE_IN_BITS)) + 1
+ usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1
bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
bitmapWordsPointerness size _ | size <= 0 = []
bitmapWordsPointerness _ [] = []
- bitmapWordsPointerness size (w:wds) =
- bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w ++
- bitmapWordsPointerness (size - (fromIntegral wORD_SIZE_IN_BITS)) wds
+ bitmapWordsPointerness size (w : wds) =
+ bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w
+ ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds
bitmapWordPointerness :: Word -> Word -> [Pointerness]
bitmapWordPointerness 0 _ = []
@@ -279,26 +291,15 @@ bitmapWordPointerness bSize bitmapWord =
(bitmapWord `shiftR` 1)
decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [Closure]
-decodeBitmaps stackSnapshot# index bitmapWords =
- let bes = toEntries index bitmapWords
- in do
- traceM $ "decodeBitmaps - index: " ++ show index ++ " words: " ++ show bitmapWords
- mapM toBitmapPayload bes
+decodeBitmaps stack# index ps =
+ zipWithM toPayload ps [index ..]
where
- toBitmapPayload :: StackFrameIter -> IO Closure
- toBitmapPayload (SfiPrimitive stack# i) = do
- w <- getWord stack# i
- pure $ UnknownTypeWordSizedPrimitive w
- toBitmapPayload (SfiClosure stack# i) = getClosure stack# i
-
- toEntries :: WordOffset -> [Pointerness] -> [StackFrameIter]
- toEntries _ [] = []
- toEntries i (p:ps) =
- let sn = case p of
- NonPointer -> SfiPrimitive stackSnapshot# i
- Pointer -> SfiClosure stackSnapshot# i
- in
- sn : toEntries (i + 1) ps
+ toPayload :: Pointerness -> WordOffset -> IO Closure
+ toPayload p i = case p of
+ NonPointer -> do
+ w <- getWord stack# i
+ pure $ UnknownTypeWordSizedPrimitive w
+ Pointer -> getClosure stack# i
decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
@@ -306,7 +307,10 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
(bitmap, size) <- IO $ \s ->
case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, b#, s# #) -> (# s1, (W# b#, W# s#) #)
- decodeBitmaps stackSnapshot# (index + relativePayloadOffset) (bitmapWordPointerness size bitmap)
+ decodeBitmaps
+ stackSnapshot#
+ (index + relativePayloadOffset)
+ (bitmapWordPointerness size bitmap)
unpackStackFrame :: StackFrameLocation -> IO StackFrame
unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
@@ -449,12 +453,13 @@ decodeStack (StackSnapshot stack#) = do
stackFrameLocations :: StackSnapshot -> [StackFrameLocation]
stackFrameLocations s =
stackHead s
- : go (uncurry advanceStackFrameIter (stackHead s))
+ : go (advanceStackFrameLocation (stackHead s))
where
go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Nothing = []
- go (Just r) = r : go (uncurry advanceStackFrameIter r)
+ go (Just r) = r : go (advanceStackFrameLocation r)
#else
module GHC.Exts.Stack.Decode where
+import qualified GHC.Base as stack
#endif
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -8,8 +8,8 @@
// developed.
#if defined(StgStack_marking)
-// advanceStackFrameIterzh(StgStack* stack, StgWord offsetWords)
-advanceStackFrameIterzh (P_ stack, W_ offsetWords) {
+// advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
+advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
W_ frameSize;
(frameSize) = ccall stackFrameSize(stack, offsetWords);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8848c8842f573b700a3594c901382e9375969616...46e8e371a42b00299fa5d34d3c22227cf88ee876
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8848c8842f573b700a3594c901382e9375969616...46e8e371a42b00299fa5d34d3c22227cf88ee876
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230415/142dd50e/attachment-0001.html>
More information about the ghc-commits
mailing list