[Git][ghc/ghc][wip/decode_cloned_stack] Add info table to closures
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Jan 21 22:01:14 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
0ec31bc8 by Sven Tennie at 2023-01-21T22:00:53+00:00
Add info table to closures
- - - - -
8 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/stack_big_ret.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_stm_frames.hs
- libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -34,6 +34,7 @@ import GHC.Exts
import GHC.Exts.Heap.Closures as CL
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.DecodeHeap
+import GHC.Exts.Heap.InfoTable
foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
@@ -92,6 +93,13 @@ foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnaps
foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
+
+getInfoTable :: StackFrameIter -> IO StgInfoTable
+getInfoTable StackFrameIter {..} =
+ let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
+ in peekItbl infoTablePtr
+
data StackFrameIter = StackFrameIter {
stackSnapshot# :: StackSnapshot#,
index :: WordOffset
@@ -191,25 +199,23 @@ byteArrayToList bArray = go 0
| otherwise = []
maxIndex = sizeofByteArray bArray `quot` sizeOf (undefined :: Word)
-byteOffsetToWord# :: ByteOffset -> Word#
-byteOffsetToWord# bo = intToWord# (fromIntegral bo)
-
wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# wo = intToWord# (fromIntegral wo)
unpackStackFrameIter :: StackFrameIter -> IO CL.Closure
-unpackStackFrameIter sfi =
- case getInfoTableType sfi of
+unpackStackFrameIter sfi = do
+ info <- getInfoTable sfi
+ case tipe info of
RET_BCO -> do
bco' <- getClosure sfi offsetStgClosurePayload
-- The arguments begin directly after the payload's one element
args' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
- pure $ CL.RetBCO bco' args'
+ pure $ CL.RetBCO info bco' args'
RET_SMALL -> do
payloads <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
let special = getRetSmallSpecialType sfi
- pure $ CL.RetSmall special payloads
- RET_BIG -> CL.RetBig <$> decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ pure $ CL.RetSmall info special payloads
+ RET_BIG -> CL.RetBig info <$> decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
RET_FUN -> do
let t = getRetFunType sfi
size' = getWord sfi offsetStgRetFunFrameSize
@@ -219,31 +225,31 @@ unpackStackFrameIter sfi =
decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
else
decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
- pure $ CL.RetFun t size' fun' payload'
+ pure $ CL.RetFun info t size' fun' payload'
-- TODO: Decode update frame type
UPDATE_FRAME -> let
!t = getUpdateFrameType sfi
c = getClosure sfi offsetStgUpdateFrameUpdatee
in
- (CL.UpdateFrame t ) <$> c
+ (CL.UpdateFrame info t ) <$> c
CATCH_FRAME -> do
let exceptionsBlocked = getWord sfi offsetStgCatchFrameExceptionsBlocked
c <- getClosure sfi offsetStgCatchFrameHandler
- pure $ CL.CatchFrame exceptionsBlocked c
+ pure $ CL.CatchFrame info exceptionsBlocked c
UNDERFLOW_FRAME -> let
nextChunk = getUnderflowFrameNextChunk sfi
in
- pure $ CL.UnderflowFrame nextChunk
- STOP_FRAME -> pure CL.StopFrame
- ATOMICALLY_FRAME -> CL.AtomicallyFrame
+ pure $ CL.UnderflowFrame info nextChunk
+ STOP_FRAME -> pure $ CL.StopFrame info
+ ATOMICALLY_FRAME -> CL.AtomicallyFrame info
<$> getClosure sfi offsetStgAtomicallyFrameCode
<*> getClosure sfi offsetStgAtomicallyFrameResult
CATCH_RETRY_FRAME -> do
let running_alt_code' = getWord sfi offsetStgCatchRetryFrameRunningAltCode
first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
alt_code' <- getClosure sfi offsetStgCatchRetryFrameAltCode
- pure $ CL.CatchRetryFrame running_alt_code' first_code' alt_code'
- CATCH_STM_FRAME -> CL.CatchStmFrame
+ pure $ CL.CatchRetryFrame info running_alt_code' first_code' alt_code'
+ CATCH_STM_FRAME -> CL.CatchStmFrame info
<$> getClosure sfi offsetStgCatchSTMFrameCode
<*> getClosure sfi offsetStgCatchSTMFrameHandler
x -> error $ "Unexpected closure type on stack: " ++ show x
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -331,47 +331,59 @@ data GenClosure b
}
-- TODO: Add `info :: !StgInfoTable` fields
| UpdateFrame
- { knownUpdateFrameType :: !UpdateFrameType
+ { info :: !StgInfoTable
+ , knownUpdateFrameType :: !UpdateFrameType
, updatee :: !b
}
| CatchFrame
- { exceptions_blocked :: Word
+ { info :: !StgInfoTable
+ , exceptions_blocked :: Word
, handler :: !b
}
| CatchStmFrame
- { catchFrameCode :: !b
+ { info :: !StgInfoTable
+ , catchFrameCode :: !b
, handler :: !b
}
| CatchRetryFrame
- { running_alt_code :: !Word
+ { info :: !StgInfoTable
+ , running_alt_code :: !Word
, first_code :: !b
, alt_code :: !b
}
| AtomicallyFrame
- { atomicallyFrameCode :: !b
+ { info :: !StgInfoTable
+ , atomicallyFrameCode :: !b
, result :: !b
}
-- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
| UnderflowFrame
- { nextChunk:: !StackSnapshot }
+ { info :: !StgInfoTable
+ , nextChunk:: !StackSnapshot
+ }
| StopFrame
+ { info :: !StgInfoTable }
| RetSmall
- { knownRetSmallType :: !SpecialRetSmall
+ { info :: !StgInfoTable
+ , knownRetSmallType :: !SpecialRetSmall
, payload :: ![b]
}
| RetBig
- { payload :: ![b] }
+ { info :: !StgInfoTable
+ , payload :: ![b]
+ }
| RetFun
- { retFunType :: RetFunType
+ { info :: !StgInfoTable
+ , retFunType :: RetFunType
, retFunSize :: Word
, retFunFun :: !b
, retFunPayload :: ![b]
@@ -379,9 +391,9 @@ data GenClosure b
| RetBCO
-- TODO: Add pre-defined BCO closures (like knownUpdateFrameType)
- {
- bco :: !b, -- must be a BCOClosure
- bcoArgs :: ![b]
+ { info :: !StgInfoTable
+ , bco :: !b -- must be a BCOClosure
+ , bcoArgs :: ![b]
}
#endif
------------------------------------------------------------
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -175,3 +175,13 @@ getRetFunTypezh(P_ stack, W_ offsetWords){
(type) = ccall getRetFunType(c);
return (type);
}
+
+getInfoTableAddrzh(P_ stack, W_ offsetWords){
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ info;
+ (info) = ccall getInfo(UNTAG(c));
+ return (info);
+}
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -36,7 +36,7 @@ assertStackInvariants stack decodedStack = do
assertThat
"Last frame is stop frame"
( \case
- StopFrame -> True
+ StopFrame info -> tipe info == STOP_FRAME
_ -> False
)
(last decodedStack)
@@ -91,18 +91,18 @@ stackFrameToClosureTypes = getClosureTypes
where
getClosureTypes :: Closure -> [ClosureType]
-- Stack frame closures
- getClosureTypes (UpdateFrame {updatee, ..}) = UPDATE_FRAME : getClosureTypes (unbox updatee)
- getClosureTypes (CatchFrame {handler, ..}) = CATCH_FRAME : getClosureTypes (unbox handler)
- getClosureTypes (CatchStmFrame {catchFrameCode, handler}) = CATCH_STM_FRAME : getClosureTypes (unbox catchFrameCode) ++ getClosureTypes (unbox handler)
- getClosureTypes (CatchRetryFrame {first_code, alt_code, ..}) = CATCH_RETRY_FRAME : getClosureTypes (unbox first_code) ++ getClosureTypes (unbox alt_code)
- getClosureTypes (AtomicallyFrame {atomicallyFrameCode, result}) = ATOMICALLY_FRAME : getClosureTypes (unbox atomicallyFrameCode) ++ getClosureTypes (unbox result)
- getClosureTypes (UnderflowFrame {..}) = [UNDERFLOW_FRAME]
- getClosureTypes StopFrame = [STOP_FRAME]
- getClosureTypes (RetSmall {payload, ..}) = RET_SMALL : getBitmapClosureTypes payload
- getClosureTypes (RetBig {payload}) = RET_BIG : getBitmapClosureTypes payload
- getClosureTypes (RetFun {retFunFun, retFunPayload, ..}) = RET_FUN : getClosureTypes (unbox retFunFun) ++ getBitmapClosureTypes retFunPayload
- getClosureTypes (RetBCO {bco, bcoArgs, ..}) =
- RET_BCO : getClosureTypes (unbox bco) ++ getBitmapClosureTypes bcoArgs
+ getClosureTypes (UpdateFrame {info, updatee, ..}) = tipe info : getClosureTypes (unbox updatee)
+ getClosureTypes (CatchFrame {info, handler, ..}) = tipe info : getClosureTypes (unbox handler)
+ getClosureTypes (CatchStmFrame {info, catchFrameCode, handler}) = tipe info : getClosureTypes (unbox catchFrameCode) ++ getClosureTypes (unbox handler)
+ getClosureTypes (CatchRetryFrame {info, first_code, alt_code, ..}) = tipe info : getClosureTypes (unbox first_code) ++ getClosureTypes (unbox alt_code)
+ getClosureTypes (AtomicallyFrame {info, atomicallyFrameCode, result}) = tipe info : getClosureTypes (unbox atomicallyFrameCode) ++ getClosureTypes (unbox result)
+ getClosureTypes (UnderflowFrame {..}) = [tipe info]
+ getClosureTypes (StopFrame info) = [tipe info]
+ getClosureTypes (RetSmall {info, payload, ..}) = tipe info : getBitmapClosureTypes payload
+ getClosureTypes (RetBig {info, payload}) = tipe info : getBitmapClosureTypes payload
+ getClosureTypes (RetFun {info, retFunFun, retFunPayload, ..}) = tipe info : getClosureTypes (unbox retFunFun) ++ getBitmapClosureTypes retFunPayload
+ getClosureTypes (RetBCO {info, bco, bcoArgs, ..}) =
+ tipe info : getClosureTypes (unbox bco) ++ getBitmapClosureTypes bcoArgs
-- Other closures
getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
getClosureTypes (FunClosure {info, ..}) = [tipe info]
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -59,7 +59,7 @@ checkArg w bp =
assertEqual [w] (dataArgs c)
pure ()
-isBigReturnFrame (RetBig _) = True
+isBigReturnFrame (RetBig info _) = tipe info == RET_BIG
isBigReturnFrame _ = False
{-# NOINLINE bigFun #-}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -94,24 +94,28 @@ main = do
test any_update_frame# $
\case
UpdateFrame {..} -> do
+ assertEqual (tipe info) UPDATE_FRAME
assertEqual knownUpdateFrameType NormalUpdateFrame
assertEqual 1 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
e -> error $ "Wrong closure type: " ++ show e
test any_catch_frame# $
\case
CatchFrame {..} -> do
+ assertEqual (tipe info) CATCH_FRAME
assertEqual exceptions_blocked 1
assertConstrClosure 1 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
test any_catch_stm_frame# $
\case
CatchStmFrame {..} -> do
+ assertEqual (tipe info) CATCH_STM_FRAME
assertConstrClosure 1 =<< getBoxedClosureData catchFrameCode
assertConstrClosure 2 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
test any_catch_retry_frame# $
\case
CatchRetryFrame {..} -> do
+ assertEqual (tipe info) CATCH_RETRY_FRAME
assertEqual running_alt_code 1
assertConstrClosure 1 =<< getBoxedClosureData first_code
assertConstrClosure 2 =<< getBoxedClosureData alt_code
@@ -119,6 +123,7 @@ main = do
test any_atomically_frame# $
\case
AtomicallyFrame {..} -> do
+ assertEqual (tipe info) ATOMICALLY_FRAME
assertConstrClosure 1 =<< getBoxedClosureData atomicallyFrameCode
assertConstrClosure 2 =<< getBoxedClosureData result
e -> error $ "Wrong closure type: " ++ show e
@@ -126,6 +131,7 @@ main = do
test any_ret_small_prim_frame# $
\case
RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
assertEqual knownRetSmallType RetN
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 1
@@ -134,6 +140,7 @@ main = do
test any_ret_small_closure_frame# $
\case
RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
assertEqual knownRetSmallType RetP
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 1
@@ -142,6 +149,7 @@ main = do
test any_ret_small_closures_frame# $
\case
RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
assertEqual knownRetSmallType None
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
@@ -151,6 +159,7 @@ main = do
test any_ret_small_prims_frame# $
\case
RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
assertEqual knownRetSmallType None
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
@@ -160,6 +169,7 @@ main = do
test any_ret_big_prims_min_frame# $
\case
RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
@@ -168,6 +178,7 @@ main = do
test any_ret_big_prims_min_frame# $
\case
RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
@@ -176,6 +187,7 @@ main = do
test any_ret_big_closures_min_frame# $
\case
RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromConstr01 pCs
@@ -184,6 +196,7 @@ main = do
test any_ret_big_closures_two_words_frame# $
\case
RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 65
let wds = map getWordFromConstr01 pCs
@@ -192,6 +205,7 @@ main = do
test any_ret_fun_arg_n_prim_framezh# $
\case
RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
assertEqual retFunType ARG_N
assertEqual retFunSize 1
assertFun01Closure 1 =<< getBoxedClosureData retFunFun
@@ -203,6 +217,7 @@ main = do
test any_ret_fun_arg_gen_framezh# $
\case
RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
assertEqual retFunType ARG_GEN
assertEqual retFunSize 9
fc <- getBoxedClosureData retFunFun
@@ -220,6 +235,7 @@ main = do
test any_ret_fun_arg_gen_big_framezh# $
\case
RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
assertEqual retFunType ARG_GEN_BIG
assertEqual retFunSize 59
fc <- getBoxedClosureData retFunFun
@@ -236,6 +252,7 @@ main = do
test any_bco_frame# $
\case
RetBCO {..} -> do
+ assertEqual (tipe info) RET_BCO
pCs <- mapM getBoxedClosureData bcoArgs
assertEqual (length pCs) 1
let wds = map getWordFromConstr01 pCs
@@ -283,7 +300,7 @@ test setup assertion = do
assertThat
"Last frame is stop frame"
( \case
- StopFrame -> True
+ StopFrame info -> tipe info == STOP_FRAME
_ -> False
)
(last stack)
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -1,10 +1,14 @@
+{-# LANGUAGE RecordWildCards #-}
+
module Main where
import Control.Concurrent.STM
import Control.Exception
import GHC.Conc
-import GHC.Exts.Heap.Closures
import GHC.Exts.DecodeStack
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
import GHC.Stack.CloneStack
import TestUtils
@@ -26,14 +30,14 @@ main = do
getDecodedStack :: IO (StackSnapshot, [Closure])
getDecodedStack = do
- s <-cloneMyStack
+ s <- cloneMyStack
fs <- decodeStack' s
pure (s, fs)
isCatchStmFrame :: Closure -> Bool
-isCatchStmFrame (CatchStmFrame _ _) = True
+isCatchStmFrame (CatchStmFrame {..}) = tipe info == CATCH_STM_FRAME
isCatchStmFrame _ = False
isAtomicallyFrame :: Closure -> Bool
-isAtomicallyFrame (AtomicallyFrame _ _) = True
+isAtomicallyFrame (AtomicallyFrame {..}) = tipe info == ATOMICALLY_FRAME
isAtomicallyFrame _ = False
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -1,10 +1,13 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
module Main where
import Data.Bool (Bool (True))
-import GHC.Exts.Heap.Closures
import GHC.Exts.DecodeStack
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
import TestUtils
@@ -29,7 +32,7 @@ getStack = do
assertStackChunksAreDecodable decodedStack
return ()
-isUnderflowFrame (UnderflowFrame _) = True
+isUnderflowFrame (UnderflowFrame {..}) = tipe info == UNDERFLOW_FRAME
isUnderflowFrame _ = False
assertStackChunksAreDecodable :: HasCallStack => [Closure] -> IO ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ec31bc8f95ae10d44e126f93b02871f37c6da7d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ec31bc8f95ae10d44e126f93b02871f37c6da7d
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/20230121/38771963/attachment-0001.html>
More information about the ghc-commits
mailing list