[Git][ghc/ghc][wip/decode_cloned_stack] validate succeeds
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Feb 4 18:17:31 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
4a14733b by Sven Tennie at 2023-02-04T18:17:05+00:00
validate succeeds
- - - - -
6 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/cbits/Stack.cmm
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -19,31 +19,38 @@ module GHC.Stack.CloneStack (
StackEntry(..),
cloneMyStack,
cloneThreadStack,
- decode
+ decode,
+ stackSnapshotToWord
) where
import Control.Concurrent.MVar
import Data.Maybe (catMaybes)
import Foreign
import GHC.Conc.Sync
-import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#, Word#, unsafeCoerce#, eqWord#, isTrue#)
+import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#, Word#)
import GHC.IO (IO (..))
import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipLoc, ipeProv, peekInfoProv)
import GHC.Stable
+import GHC.Word
+import Numeric
-- | A frozen snapshot of the state of an execution stack.
--
-- @since 4.17.0.0
data StackSnapshot = StackSnapshot !StackSnapshot#
+instance Show StackSnapshot where
+ showsPrec _ stack rs =
+ "StackSnapshot(" ++ pad_out (showHex addr "") ++ ")" ++ rs
+ where
+ addr = stackSnapshotToWord stack
+ pad_out ls = '0':'x':ls
--- TODO: Cast to Addr representation instead?
-instance Eq StackSnapshot where
- (StackSnapshot s1#) == (StackSnapshot s2#) = isTrue# (((unsafeCoerce# s1#) :: Word#) `eqWord#` ((unsafeCoerce# s2#) :: Word#))
+stackSnapshotToWord :: StackSnapshot -> Word
+stackSnapshotToWord (StackSnapshot s#) = W# (stackSnapshotToWord# s#)
--- TODO: Show and Eq instances are mainly here to fulfill Closure deriving requirements
--- instance Show StackSnapshot where
--- show _ = "StackSnapshot"
+instance Eq StackSnapshot where
+ s1 == s2 = stackSnapshotToWord s1 == stackSnapshotToWord s2
foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #)
@@ -51,6 +58,8 @@ foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (#
foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #)
+foreign import prim "stackSnapshotToWordzh" stackSnapshotToWord# :: StackSnapshot# -> Word#
+
{-
Note [Stack Cloning]
~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/cbits/StackCloningDecoding.cmm
=====================================
@@ -24,3 +24,8 @@ stg_decodeStackzh (gcptr stgStack) {
return (stackEntries);
}
+
+// Just a cast
+stackSnapshotToWordzh(P_ stack) {
+ return (stack);
+}
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -103,11 +103,6 @@ Technical details
This keeps the code very portable.
-}
-foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
-
-derefStackWord :: StackFrameIter -> Word
-derefStackWord (StackFrameIter {..}) = W# (derefStackWord# stackSnapshot# (wordOffsetToWord# index))
-
foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
getUpdateFrameType :: StackFrameIter -> IO UpdateFrameType
@@ -123,8 +118,6 @@ getUnderflowFrameNextChunk (StackFrameIter {..}) = IO $ \s ->
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-foreign import prim "getAddrzh" getAddr# :: StackSnapshot# -> Word# -> Addr#
-
getWord :: StackFrameIter -> WordOffset -> IO Word
getWord (StackFrameIter {..}) relativeOffset = IO $ \s ->
case getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset) s of
@@ -164,7 +157,7 @@ getInfoTable StackFrameIter {..} | sfiKind == SfiClosure =
let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
in peekItbl infoTablePtr
getInfoTable StackFrameIter {..} | sfiKind == SfiStack = peekItbl $ Ptr (getStackInfoTableAddr# stackSnapshot#)
-getInfoTable StackFrameIter {..} | sfiKind == SfiPrimitive = error "Primitives have no info table!"
+getInfoTable _ = error "Primitives have no info table!"
foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #)
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -194,7 +194,7 @@ getBoxedClosureData b@(StackFrameBox sfi) = trace ("unpack " ++ show b) $ unpack
-- @since 8.10.1
closureSize :: Box -> IO Int
closureSize (Box x) = pure $ I# (closureSize# x)
-#if MIN_VERSION_base(4,17,0)
+#if MIN_TOOL_VERSION_ghc(9,5,0)
closureSize (StackFrameBox sfi) = unpackStackFrameIter sfi <&>
\c ->
case c of
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -55,10 +55,8 @@ import GHC.Generics
import Numeric
#if MIN_TOOL_VERSION_ghc(9,5,0)
-import GHC.Stack.CloneStack (StackSnapshot(..))
+import GHC.Stack.CloneStack (StackSnapshot(..), stackSnapshotToWord)
import GHC.Exts.StackConstants
-import Unsafe.Coerce (unsafeCoerce)
-import Data.Functor
#endif
------------------------------------------------------------------------
@@ -70,10 +68,6 @@ foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
#if MIN_TOOL_VERSION_ghc(9,5,0)
-foreign import prim "stackSnapshotToWordzh" stackSnapshotToWord# :: StackSnapshot# -> Word#
-
-foreign import prim "eqStackSnapshotszh" eqStackSnapshots# :: StackSnapshot# -> StackSnapshot# -> Word#
-
data SfiKind = SfiClosure | SfiPrimitive | SfiStack
deriving (Eq, Show)
@@ -88,15 +82,7 @@ instance Show StackFrameIter where
-- TODO: Record syntax could be nicer to read
"StackFrameIter(" ++ pad_out (showHex addr "") ++ ", " ++ show i ++ ", " ++ show p ++ ")" ++ rs
where
- addr = W# (stackSnapshotToWord# s#)
- pad_out ls = '0':'x':ls
-
-instance Show StackSnapshot where
- showsPrec _ (StackSnapshot s#) rs =
- -- TODO: Record syntax could be nicer to read
- "StackSnapshot(" ++ pad_out (showHex addr "") ++ ")" ++ rs
- where
- addr = W# (stackSnapshotToWord# s#)
+ addr = stackSnapshotToWord (StackSnapshot s#)
pad_out ls = '0':'x':ls
-- | An arbitrary Haskell value in a safe Box.
@@ -149,10 +135,11 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
-- TODO: Could be used for `instance Eq StackFrameIter`
areBoxesEqual
(StackFrameBox (StackFrameIter s1# i1 p1))
- (StackFrameBox (StackFrameIter s2# i2 p2)) = pure $
- W# (eqStackSnapshots# s1# s2#) == 1
- && i1 == i2
- && p1 == p2
+ (StackFrameBox (StackFrameIter s2# i2 p2)) =
+ pure $
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ && i1 == i2
+ && p1 == p2
areBoxesEqual _ _ = pure False
#endif
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -43,13 +43,6 @@ advanceStackFrameIterzh (P_ stack, W_ offsetWords) {
return (newStack, newOffsetWords, hasNext);
}
-derefStackWordzh (P_ stack, W_ offsetWords) {
- P_ sp;
- sp = StgStack_sp(stack);
-
- return (W_[sp + WDS(offsetWords)]);
-}
-
getSmallBitmapzh(P_ stack, W_ offsetWords) {
P_ c;
c = StgStack_sp(stack) + WDS(offsetWords);
@@ -182,17 +175,6 @@ getStackInfoTableAddrzh(P_ stack){
return (info);
}
-// Just a cast
-stackSnapshotToWordzh(P_ stack) {
- return (stack);
-}
-
-eqStackSnapshotszh(P_ stack1, P_ stack2) {
- ccall checkSTACK(stack1);
- ccall checkSTACK(stack2);
- return (stack1 == stack2);
-}
-
getBoxedClosurezh(P_ stack, W_ offsetWords){
ccall debugBelch("getBoxedClosurezh - stack %p , offsetWords %lu", stack, offsetWords);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a14733bb7130f1518df414d477ba4178b7ab952
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a14733bb7130f1518df414d477ba4178b7ab952
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/20230204/cee0f6c0/attachment-0001.html>
More information about the ghc-commits
mailing list