[Git][ghc/ghc][wip/decode_cloned_stack] Decode Atomically and CatchRetry frames
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Oct 29 10:10:03 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
f8ecdcb7 by Sven Tennie at 2022-10-29T10:09:29+00:00
Decode Atomically and CatchRetry frames
- - - - -
6 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- + libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- libraries/ghc-heap/cbits/Stack.cmm
- + libraries/ghc-heap/tests/stack_big_ret.hs
- + libraries/ghc-heap/tests/stack_stm_frames.hs
- + libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -149,11 +149,20 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
in
UnderflowFrame (StackSnapshot nextChunk#)
STOP_FRAME -> StopFrame
- ATOMICALLY_FRAME -> AtomicallyFrame
- CATCH_RETRY_FRAME -> CatchRetryFrame
+ ATOMICALLY_FRAME -> let
+ c = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgAtomicallyFrameCode)) sfi
+ r = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgAtomicallyFrameResult)) sfi
+ in
+ AtomicallyFrame c r
+ CATCH_RETRY_FRAME -> let
+ running_alt_code = W# (getWord# s# i# (intToWord# offsetStgCatchRetryFrameRunningAltCode))
+ first_code = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchRetryFrameRunningFirstCode)) sfi
+ alt_code = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchRetryFrameRunningAltCode)) sfi
+ in
+ CatchRetryFrame running_alt_code first_code alt_code
CATCH_STM_FRAME -> let
c = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchSTMFrameCode)) sfi
- h = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchSTMFrameHandler)) sfi
+ h = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchSTMFrameHandler)) sfi
in
CatchStmFrame c h
x -> error $ "Unexpected closure type on stack: " ++ show x
@@ -199,6 +208,8 @@ foreign import prim "getCatchFrameExceptionsBlockedzh" getCatchFrameExceptionsBl
foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> StackSnapshot#
+foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+
data BitmapPayload = Closure CL.Closure | Primitive Word
instance Show BitmapPayload where
@@ -207,7 +218,7 @@ instance Show BitmapPayload where
-- TODO There are likely more. See MiscClosures.h
data SpecialRetSmall =
- -- TODO: Shoudn't `None` be better `Maybe ...`
+ -- TODO: Shoudn't `None` be better `Maybe ...`?
None |
ApV |
ApF |
@@ -240,8 +251,8 @@ data StackFrame =
UpdateFrame { knownUpdateFrameType :: UpdateFrameType, updatee :: CL.Closure } |
CatchFrame { exceptions_blocked :: Word, handler :: CL.Closure } |
CatchStmFrame { code :: CL.Closure, handler :: CL.Closure } |
- CatchRetryFrame |
- AtomicallyFrame |
+ CatchRetryFrame {running_alt_code :: Word, first_code :: CL.Closure, alt_code :: CL.Closure} |
+ AtomicallyFrame { code :: CL.Closure, result :: CL.Closure} |
UnderflowFrame { nextChunk:: StackSnapshot } |
StopFrame |
RetSmall { knownRetSmallType :: SpecialRetSmall, payload :: [BitmapPayload]} |
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -0,0 +1,36 @@
+module GHC.Exts.StackConstants where
+
+import Prelude
+
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+offsetStgCatchSTMFrameCode :: Int
+offsetStgCatchSTMFrameCode = (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+
+offsetStgCatchFrameHandler :: Int
+offsetStgCatchFrameHandler = (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+
+offsetStgCatchSTMFrameHandler :: Int
+offsetStgCatchSTMFrameHandler = (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+
+offsetStgUpdateFrameUpdatee :: Int
+offsetStgUpdateFrameUpdatee = (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+
+offsetStgAtomicallyFrameCode :: Int
+offsetStgAtomicallyFrameCode = (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+
+offsetStgAtomicallyFrameResult :: Int
+offsetStgAtomicallyFrameResult = (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningAltCode :: Int
+offsetStgCatchRetryFrameRunningAltCode = (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningFirstCode :: Int
+offsetStgCatchRetryFrameRunningFirstCode = (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameAltCode :: Int
+offsetStgCatchRetryFrameAltCode = (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -135,15 +135,13 @@ getUpdateFrameTypezh(P_ stack, W_ index){
// Reduce duplication by using offsets instead on pointer macros.
unpackClosureReferencedByFramezh(W_ offset, P_ stack, W_ index){
P_ closurePtr, closurePtrPrime, codePtr;
- closurePtr = (StgStack_sp(stack) + WDS(index));
+ closurePtr = (StgStack_sp(stack) + WDS(index) + offset);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
- codePtr = StgCatchSTMFrame_code(closurePtr);
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(codePtr));
- jump stg_unpackClosurezh(codePtr);
+ jump stg_unpackClosurezh(closurePtr);
}
getCatchFrameExceptionsBlockedzh(P_ stack, W_ index){
- P_ closurePtr, closurePtrPrime, updateePtr;
+ P_ closurePtr;
closurePtr = (StgStack_sp(stack) + WDS(index));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
@@ -152,6 +150,13 @@ getCatchFrameExceptionsBlockedzh(P_ stack, W_ index){
return (exceptions_blocked);
}
+// TODO: Rename: index -> wordOffset, offset -> byteOffset
+getWordzh(P_ stack, W_ index, W_ offset){
+ P_ wordAddr;
+ wordAddr = (StgStack_sp(stack) + WDS(index) + offset);
+ return (W_[wordAddr]);
+}
+
getUnderflowFrameNextChunkzh(P_ stack, W_ index){
P_ closurePtr, closurePtrPrime, updateePtr;
closurePtr = (StgStack_sp(stack) + WDS(index));
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -0,0 +1,137 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import Control.Concurrent
+import Data.IORef
+import Data.Maybe
+import GHC.Exts (StackSnapshot#)
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures qualified as CL
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.IO.Unsafe
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import System.IO (hPutStrLn, stderr)
+import System.Mem
+import TestUtils
+
+cloneStackReturnInt :: IORef (Maybe StackSnapshot) -> Int
+cloneStackReturnInt ioRef = unsafePerformIO $ do
+ stackSnapshot <- cloneMyStack
+
+ writeIORef ioRef (Just stackSnapshot)
+
+ pure 42
+
+-- | Clone a stack with a RET_BIG closure and decode it.
+main :: HasCallStack => IO ()
+main = do
+ stackRef <- newIORef Nothing
+
+ bigFun (cloneStackReturnInt stackRef) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
+
+ stackSnapshot <- readIORef stackRef
+
+ !decodedStack <- decodeStack (fromJust stackSnapshot)
+
+ assertStackInvariants decodedStack
+ assertThat
+ "Stack contains one big return frame"
+ (== 1)
+ (length $ filter isBigReturnFrame decodedStack)
+ let xs = zip [1 ..] $ (payload . head) $ filter isBigReturnFrame decodedStack
+ mapM_ (uncurry checkArg) xs
+
+checkArg :: Word -> BitmapPayload -> IO ()
+checkArg w bp =
+ case bp of
+ Primitive _ -> error "Unexpected payload type from bitmap."
+ Closure c -> do
+ assertEqual CONSTR_0_1 $ (tipe . CL.info) c
+ assertEqual "I#" (CL.name c)
+ assertEqual "ghc-prim" (CL.pkg c)
+ assertEqual "GHC.Types" (CL.modl c)
+ assertEqual True $ (null . CL.ptrArgs) c
+ assertEqual [w] (CL.dataArgs c)
+ pure ()
+
+isBigReturnFrame (RetBig _) = True
+isBigReturnFrame _ = False
+
+{-# NOINLINE bigFun #-}
+bigFun ::
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ IO ()
+bigFun !a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 =
+ do
+ print $ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + a60 + a61 + a62 + a63 + a64 + a65
+
+ pure ()
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -0,0 +1,27 @@
+module Main where
+
+import Control.Concurrent.STM
+import Control.Exception
+import GHC.Conc
+import GHC.Exts.DecodeStack
+import GHC.Stack.CloneStack
+import TestUtils
+
+main :: IO ()
+main = do
+ decodedStack <-
+ atomically $
+ catchSTM @SomeException (unsafeIOToSTM getDecodedStack) throwSTM
+
+ assertStackInvariants decodedStack
+ assertThat
+ "Stack contains one catch stm frame"
+ (== 1)
+ (length $ filter isCatchStmFrame decodedStack)
+
+getDecodedStack :: IO [StackFrame]
+getDecodedStack = cloneMyStack >>= decodeStack
+
+isCatchStmFrame :: StackFrame -> Bool
+isCatchStmFrame (CatchStmFrame _ _) = True
+isCatchStmFrame _ = False
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+import Data.Bool (Bool (True))
+import GHC.Exts.DecodeStack
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import TestUtils
+
+main = loop 128
+
+{-# NOINLINE loop #-}
+loop 0 = () <$ getStack
+loop n = print "x" >> loop (n - 1) >> print "x"
+
+getStack :: HasCallStack => IO ()
+getStack = do
+ !s <- cloneMyStack
+ !decodedStack <- decodeStack s
+ -- Uncomment to see the frames (for debugging purposes)
+ -- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
+ assertStackInvariants decodedStack
+ assertThat
+ "Stack contains underflow frames"
+ (== True)
+ (any isUnderflowFrame decodedStack)
+ assertStackChunksAreDecodable decodedStack
+ return ()
+
+isUnderflowFrame (UnderflowFrame _) = True
+isUnderflowFrame _ = False
+
+assertStackChunksAreDecodable :: HasCallStack => [StackFrame] -> IO ()
+assertStackChunksAreDecodable s = do
+ let underflowFrames = filter isUnderflowFrame s
+ framesOfChunks <- mapM (decodeStack . nextChunk) underflowFrames
+ assertThat
+ "No empty stack chunks"
+ (== True)
+ ( not (any null framesOfChunks)
+ )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8ecdcb7f442d353aa71152614928d3ef42c279f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8ecdcb7f442d353aa71152614928d3ef42c279f
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/20221029/85dd6554/attachment-0001.html>
More information about the ghc-commits
mailing list