[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Add missing bang patterns to StackFrames
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Thu May 4 17:25:44 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
8420e1d7 by Sven Tennie at 2023-05-04T16:19:55+00:00
Add missing bang patterns to StackFrames
- - - - -
03425236 by Sven Tennie at 2023-05-04T17:25:00+00:00
Try more general data structure
- - - - -
2 changed files:
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -20,8 +20,12 @@ module GHC.Exts.Heap.Closures (
, closureSize
-- * Stack
- , StgStackClosure(..)
- , StackFrame(..)
+ , StgStackClosure
+ , GenStgStackClosure(..)
+ , StackFrame
+ , GenStackFrame(..)
+ , StackField
+ , GenStackField(..)
-- * Boxes
, Box(..)
@@ -374,54 +378,63 @@ data GenClosure b
-- primitives and one for closures. This turned out to be a nightmare with lots
-- of pattern matches and leaking data structures to enable access to primitives
-- on the stack...
-data StgStackClosure = StgStackClosure
+type StgStackClosure = GenStgStackClosure Box
+
+data GenStgStackClosure b = GenStgStackClosure
{ ssc_info :: !StgInfoTable
, ssc_stack_size :: !Word32 -- ^ stack size in *words*
, ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty
, ssc_stack_marking :: !Word8
- , ssc_stack :: ![StackFrame]
+ , ssc_stack :: ![GenStackFrame b]
}
- deriving Show
+ deriving (Show, Generic)
+
+type StackField = GenStackField Box
+
+data GenStackField b
+ -- | A non-pointer field
+ = StackWord !Word
+ -- | A pointer field
+ | StackBox !b
+ deriving (Show, Generic)
+
+type StackFrame = GenStackFrame Box
-- | A single stack frame
---
--- It doesn't use `Box`es because that would require a `Box` constructor for
--- primitive values (bitmap encoded payloads), which introduces lots of pattern
--- matches and complicates the whole implementation (and breaks existing code.)
-data StackFrame =
+data GenStackFrame b =
UpdateFrame
{ info_tbl :: !StgInfoTable
- , updatee :: !Closure
+ , updatee :: !b
}
| CatchFrame
{ info_tbl :: !StgInfoTable
- , exceptions_blocked :: Word
- , handler :: !Closure
+ , exceptions_blocked :: !Word
+ , handler :: !b
}
| CatchStmFrame
{ info_tbl :: !StgInfoTable
- , catchFrameCode :: !Closure
- , handler :: !Closure
+ , catchFrameCode :: !b
+ , handler :: !b
}
| CatchRetryFrame
{ info_tbl :: !StgInfoTable
, running_alt_code :: !Word
- , first_code :: !Closure
- , alt_code :: !Closure
+ , first_code :: !b
+ , alt_code :: !b
}
| AtomicallyFrame
{ info_tbl :: !StgInfoTable
- , atomicallyFrameCode :: !Closure
- , result :: !Closure
+ , atomicallyFrameCode :: !b
+ , result :: !b
}
| UnderflowFrame
{ info_tbl :: !StgInfoTable
- , nextChunk :: !StgStackClosure
+ , nextChunk :: !(GenStgStackClosure b)
}
| StopFrame
@@ -429,26 +442,26 @@ data StackFrame =
| RetSmall
{ info_tbl :: !StgInfoTable
- , stack_payload :: ![Closure]
+ , stack_payload :: ![GenStackField b]
}
| RetBig
{ info_tbl :: !StgInfoTable
- , stack_payload :: ![Closure]
+ , stack_payload :: ![GenStackField b]
}
| RetFun
{ info_tbl :: !StgInfoTable
- , retFunType :: RetFunType
- , retFunSize :: Word
- , retFunFun :: !Closure
- , retFunPayload :: ![Closure]
+ , retFunType :: !RetFunType
+ , retFunSize :: !Word
+ , retFunFun :: !b
+ , retFunPayload :: ![GenStackField b]
}
| RetBCO
{ info_tbl :: !StgInfoTable
- , bco :: !Closure -- must be a BCOClosure
- , bcoArgs :: ![Closure]
+ , bco :: !b -- is always a BCOClosure
+ , bcoArgs :: ![GenStackField b]
}
deriving (Show, Generic)
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -23,14 +23,16 @@ import Data.Bits
import Data.Maybe
import Foreign
import GHC.Exts
-import GHC.Exts.Heap (Box (..), getBoxedClosureData)
+import GHC.Exts.Heap (Box (..))
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Closures
- ( Closure,
- GenClosure (UnknownTypeWordSizedPrimitive),
- RetFunType (..),
- StackFrame (..),
- StgStackClosure (..),
+ ( RetFunType (..),
+ StackFrame,
+ GenStackFrame (..),
+ StgStackClosure,
+ GenStgStackClosure (..),
+ StackField,
+ GenStackField(..)
)
import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Exts.Heap.InfoTable
@@ -211,20 +213,18 @@ advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
primWordToWordOffset :: Word# -> WordOffset
primWordToWordOffset w# = fromIntegral (W# w#)
-getClosure :: StackSnapshot# -> WordOffset -> IO Closure
-getClosure stackSnapshot# index =
+getClosureBox :: StackSnapshot# -> WordOffset -> IO Box
+getClosureBox stackSnapshot# index =
-- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage
-- collector might move the referenced closure, without updating our reference
-- (pointer) to it.
- ( IO $ \s ->
+ IO $ \s ->
case getStackClosure#
stackSnapshot#
(wordOffsetToWord# index)
s of
(# s1, ptr #) ->
(# s1, Box ptr #)
- )
- >>= getBoxedClosureData
-- | Representation of @StgLargeBitmap@ (RTS)
data LargeBitmap = LargeBitmap
@@ -236,7 +236,7 @@ data LargeBitmap = LargeBitmap
data Pointerness = Pointer | NonPointer
deriving (Show)
-decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
+decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
(# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#)
@@ -276,17 +276,17 @@ bitmapWordPointerness bSize bitmapWord =
(bSize - 1)
(bitmapWord `shiftR` 1)
-decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [Closure]
+decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [StackField]
decodeBitmaps stack# index ps =
zipWithM toPayload ps [index ..]
where
- toPayload :: Pointerness -> WordOffset -> IO Closure
+ toPayload :: Pointerness -> WordOffset -> IO StackField
toPayload p i = case p of
NonPointer ->
- pure $ UnknownTypeWordSizedPrimitive (getWord stack# i)
- Pointer -> getClosure stack# i
+ pure $ StackWord (getWord stack# i)
+ Pointer -> StackBox <$> getClosureBox stack# i
-decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
+decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
(# b#, s# #) -> (W# b#, W# s#)
@@ -304,7 +304,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
unpackStackFrame' info =
case tipe info of
RET_BCO -> do
- bco' <- getClosure stackSnapshot# (index + offsetStgClosurePayload)
+ bco' <- getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
-- The arguments begin directly after the payload's one element
bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
pure
@@ -330,7 +330,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
RET_FUN -> do
let retFunType' = getRetFunType stackSnapshot# index
retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
- retFunFun' <- getClosure stackSnapshot# (index + offsetStgRetFunFrameFun)
+ retFunFun' <- getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)
retFunPayload' <-
if retFunType' == ARG_GEN_BIG
then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
@@ -344,7 +344,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
retFunPayload = retFunPayload'
}
UPDATE_FRAME -> do
- updatee' <- getClosure stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
+ updatee' <- getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
pure $
UpdateFrame
{ info_tbl = info,
@@ -352,7 +352,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
}
CATCH_FRAME -> do
let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked)
- handler' <- getClosure stackSnapshot# (index + offsetStgCatchFrameHandler)
+ handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
pure $
CatchFrame
{ info_tbl = info,
@@ -369,8 +369,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
}
STOP_FRAME -> pure $ StopFrame {info_tbl = info}
ATOMICALLY_FRAME -> do
- atomicallyFrameCode' <- getClosure stackSnapshot# (index + offsetStgAtomicallyFrameCode)
- result' <- getClosure stackSnapshot# (index + offsetStgAtomicallyFrameResult)
+ atomicallyFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
+ result' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
pure $
AtomicallyFrame
{ info_tbl = info,
@@ -379,8 +379,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
}
CATCH_RETRY_FRAME -> do
let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
- first_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
- alt_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
+ first_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
+ alt_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
pure $
CatchRetryFrame
{ info_tbl = info,
@@ -389,8 +389,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
alt_code = alt_code'
}
CATCH_STM_FRAME -> do
- catchFrameCode' <- getClosure stackSnapshot# (index + offsetStgCatchSTMFrameCode)
- handler' <- getClosure stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
+ catchFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
+ handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
pure $
CatchStmFrame
{ info_tbl = info,
@@ -430,7 +430,7 @@ decodeStack (StackSnapshot stack#) = do
sfls = stackFrameLocations stack#
stack' <- mapM unpackStackFrame sfls
pure $
- StgStackClosure
+ GenStgStackClosure
{ ssc_info = info,
ssc_stack_size = stack_size',
ssc_stack_dirty = stack_dirty',
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc135403e75c95c697d48afc7b085ae757560ca5...03425236b30f2e9bb3ceef58a0e31cc048137da5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc135403e75c95c697d48afc7b085ae757560ca5...03425236b30f2e9bb3ceef58a0e31cc048137da5
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/20230504/9c292bad/attachment-0001.html>
More information about the ghc-commits
mailing list