[Git][ghc/ghc][wip/decode_cloned_stack] Use for boxes: StackFrameIter
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Tue Jan 31 14:38:15 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
c7c7d4ff by Sven Tennie at 2023-01-31T14:37:08+00:00
Use for boxes: StackFrameIter
- - - - -
11 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- 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.c
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_misc_closures_c.c
- libraries/ghci/GHCi/Run.hs
- rts/sm/Sanity.c
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -42,8 +42,8 @@ instance Eq StackSnapshot where
(StackSnapshot s1#) == (StackSnapshot s2#) = isTrue# (((unsafeCoerce# s1#) :: Word#) `eqWord#` ((unsafeCoerce# s2#) :: Word#))
-- TODO: Show and Eq instances are mainly here to fulfill Closure deriving requirements
-instance Show StackSnapshot where
- show _ = "StackSnapshot"
+-- instance Show StackSnapshot where
+-- show _ = "StackSnapshot"
foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #)
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -18,6 +18,7 @@
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack
( decodeStack,
+ unpackStackFrameIter
)
where
@@ -150,10 +151,7 @@ getInfoTable StackFrameIter {..} =
let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
in peekItbl infoTablePtr
-data StackFrameIter = StackFrameIter
- { stackSnapshot# :: StackSnapshot#,
- index :: WordOffset
- }
+foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> Any
-- -- TODO: Remove this instance (debug only)
-- instance Show StackFrameIter where
@@ -161,23 +159,22 @@ data StackFrameIter = StackFrameIter
-- | Get an interator starting with the top-most stack frame
stackHead :: StackSnapshot -> StackFrameIter
-stackHead (StackSnapshot s) = StackFrameIter s 0 -- GHC stacks are never empty
+stackHead (StackSnapshot s) = StackFrameIter s 0 False -- GHC stacks are never empty
-- | Advance iterator to the next stack frame (if any)
advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
advanceStackFrameIter (StackFrameIter {..}) =
let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
in if (I# hasNext) > 0
- then Just $ StackFrameIter s' (primWordToWordOffset i')
+ then Just $ StackFrameIter s' (primWordToWordOffset i') False
else Nothing
primWordToWordOffset :: Word# -> WordOffset
primWordToWordOffset w# = fromIntegral (W# w#)
+-- TODO: can be just StackFrameIter
data BitmapEntry = BitmapEntry
- { closureFrame :: StackFrameIter,
- isPrimitive :: Bool
- }
+ { closureFrame :: StackFrameIter }
wordsToBitmapEntries :: StackFrameIter -> [Word] -> Word -> [BitmapEntry]
wordsToBitmapEntries _ [] 0 = []
@@ -189,7 +186,7 @@ wordsToBitmapEntries sfi (b : bs) bitmapSize =
mbLastFrame = fmap closureFrame mbLastEntry
in case mbLastFrame of
Just (StackFrameIter {..}) ->
- entries ++ wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) bs (subtractDecodedBitmapWord bitmapSize)
+ entries ++ wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + 1) False) bs (subtractDecodedBitmapWord bitmapSize)
Nothing -> error "This should never happen! Recursion ended not in base case."
where
subtractDecodedBitmapWord :: Word -> Word
@@ -198,26 +195,26 @@ wordsToBitmapEntries sfi (b : bs) bitmapSize =
toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
toBitmapEntries _ _ 0 = []
toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize =
+ -- TODO: overriding isPrimitive field is a bit weird. Could be calculated before
BitmapEntry
- { closureFrame = sfi,
- isPrimitive = (bitmapWord .&. 1) /= 0
+ { closureFrame = sfi {
+ isPrimitive = (bitmapWord .&. 1) /= 0
+ }
}
- : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) (bitmapWord `shiftR` 1) (bSize - 1)
+ : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1) False) (bitmapWord `shiftR` 1) (bSize - 1)
toBitmapPayload :: BitmapEntry -> Box
toBitmapPayload e
- | isPrimitive e =
- let !b = (UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame) e
- in DecodedBox b
+ | (isPrimitive . closureFrame) e = trace "PRIM" $ StackFrameBox $ (closureFrame e) {
+ isPrimitive = True
+ }
toBitmapPayload e = getClosure (closureFrame e) 0
getClosure :: StackFrameIter -> WordOffset -> Box
getClosure StackFrameIter {..} relativeOffset =
- -- TODO: What happens if the GC kicks in here?
- let offset = wordOffsetToWord# (index + relativeOffset)
- !ptr = (getAddr# stackSnapshot# offset)
- !a :: Any = unsafeCoerce# ptr
- in Box a
+ let !c = (getBoxedClosure# stackSnapshot# (wordOffsetToWord# (index + relativeOffset)))
+ in
+ Box c
decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> [Box]
decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
@@ -227,7 +224,7 @@ decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> [Box]
decodeBitmaps (StackFrameIter {..}) relativePayloadOffset bitmapWords size =
- let bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset)) bitmapWords size
+ let bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset) False) bitmapWords size
in map toBitmapPayload bes
decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> WordOffset -> [Box]
@@ -248,11 +245,13 @@ byteArrayToList bArray = go 0
wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# wo = intToWord# (fromIntegral wo)
-unpackStackFrameIter :: StackFrameIter -> IO Box
+unpackStackFrameIter :: StackFrameIter -> IO Closure
+unpackStackFrameIter sfi | isPrimitive sfi = pure $ UnknownTypeWordSizedPrimitive (getWord sfi 0)
unpackStackFrameIter sfi = do
info <- getInfoTable sfi
- let c = unpackStackFrameIter' info
- pure $ DecodedBox c
+ traceM $ "unpackStackFrameIter - sfi " ++ show sfi
+ traceM $ "unpackStackFrameIter - unpacked " ++ show (unpackStackFrameIter' info)
+ pure $ unpackStackFrameIter' info
where
unpackStackFrameIter' :: StgInfoTable -> Closure
unpackStackFrameIter' info =
@@ -265,6 +264,7 @@ unpackStackFrameIter sfi = do
bcoArgs = decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
}
RET_SMALL ->
+ trace "RET_SMALL" $
RetSmall
{ info = info,
knownRetSmallType = getRetSmallSpecialType sfi,
@@ -338,17 +338,15 @@ toInt# (I# i) = i
intToWord# :: Int -> Word#
intToWord# i = int2Word# (toInt# i)
-decodeStack :: StackSnapshot -> IO Closure
-decodeStack s = do
- stack <- decodeStack' s
- pure $ SimpleStack stack
+decodeStack :: StackSnapshot -> Closure
+decodeStack = SimpleStack . decodeStack'
-decodeStack' :: StackSnapshot -> IO [Box]
-decodeStack' s = unpackStackFrameIter (stackHead s) >>= \frame -> (frame :) <$> go (advanceStackFrameIter (stackHead s))
+decodeStack' :: StackSnapshot -> [Box]
+decodeStack' s = StackFrameBox (stackHead s) : go (advanceStackFrameIter (stackHead s))
where
- go :: Maybe StackFrameIter -> IO [Box]
- go Nothing = pure []
- go (Just sfi) = (trace "decode\n" (unpackStackFrameIter sfi)) >>= \frame -> (frame :) <$> go (advanceStackFrameIter sfi)
+ go :: Maybe StackFrameIter -> [Box]
+ go Nothing = []
+ go (Just sfi) = (StackFrameBox sfi) : go (advanceStackFrameIter sfi)
#else
module GHC.Exts.DecodeStack where
#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,6 +7,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+{-# LANGUAGE RecordWildCards #-}
+#endif
{-# LANGUAGE UnliftedFFITypes #-}
{-|
@@ -53,6 +57,7 @@ module GHC.Exts.Heap (
-- * Closure inspection
, getBoxedClosureData
, allClosures
+ , closureSize
-- * Boxes
, Box(..)
@@ -77,6 +82,9 @@ import GHC.Word
#if MIN_TOOL_VERSION_ghc(9,5,0)
import GHC.Stack.CloneStack
import GHC.Exts.DecodeStack
+import GHC.Exts.StackConstants
+import Data.Functor
+import Debug.Trace
#endif
@@ -135,7 +143,7 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
#if MIN_TOOL_VERSION_ghc(9,5,0)
instance {-# OVERLAPPING #-} HasHeapRep StackSnapshot# where
- getClosureData s# = decodeStack (StackSnapshot s#)
+ getClosureData s# = pure $ decodeStack (StackSnapshot s#)
#endif
-- | Get the heap representation of a closure _at this moment_, even if it is
@@ -174,7 +182,31 @@ getClosureDataFromHeapObject x = do
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
-getBoxedClosureData (Box a) = getClosureData a
+getBoxedClosureData (Box a) = let !a' = a
+ in getClosureData a'
#if MIN_TOOL_VERSION_ghc(9,5,0)
-getBoxedClosureData (DecodedBox a) = pure a
+getBoxedClosureData b@(StackFrameBox sfi) = trace ("unpack " ++ show b) $ unpackStackFrameIter sfi
+#endif
+
+-- | Get the size of the top-level closure in words.
+-- Includes header and payload. Does not follow pointers.
+--
+-- @since 8.10.1
+closureSize :: Box -> IO Int
+closureSize (Box x) = pure $ I# (closureSize# x)
+#if MIN_VERSION_base(4,17,0)
+closureSize (StackFrameBox sfi) = unpackStackFrameIter sfi <&>
+ \c ->
+ case c of
+ UpdateFrame {} -> sizeStgUpdateFrame
+ CatchFrame {} -> sizeStgCatchFrame
+ CatchStmFrame {} -> sizeStgCatchSTMFrame
+ CatchRetryFrame {} -> sizeStgCatchRetryFrame
+ AtomicallyFrame {} -> sizeStgAtomicallyFrame
+ RetSmall {..} -> sizeStgClosure + length payload
+ RetBig {..} -> sizeStgClosure + length payload
+ RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
+ -- The one additional word is a pointer to the StgBCO in the closure's payload
+ RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
+ _ -> error "Unexpected closure type"
#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -19,12 +19,14 @@ module GHC.Exts.Heap.Closures (
, SpecialRetSmall(..)
, RetFunType(..)
, allClosures
- , closureSize
-- * Boxes
, Box(..)
, areBoxesEqual
, asBox
+#if MIN_VERSION_base(4,17,0)
+ , StackFrameIter(..)
+#endif
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -55,6 +57,7 @@ import Numeric
import GHC.Stack.CloneStack (StackSnapshot(..))
import GHC.Exts.StackConstants
import Unsafe.Coerce (unsafeCoerce)
+import Data.Functor
#endif
------------------------------------------------------------------------
@@ -65,14 +68,40 @@ foreign import prim "aToWordzh" aToWord# :: Any -> Word#
foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
+#if MIN_VERSION_base(4,17,0)
+foreign import prim "stackSnapshotToWordzh" stackSnapshotToWord# :: StackSnapshot# -> Word#
+
+foreign import prim "eqStackSnapshotszh" eqStackSnapshots# :: StackSnapshot# -> StackSnapshot# -> Word#
+#endif
-- | An arbitrary Haskell value in a safe Box. The point is that even
-- unevaluated thunks can safely be moved around inside the Box, and when
-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
-- to evaluate the argument.
#if MIN_VERSION_base(4,17,0)
-data Box = Box Any | DecodedBox Closure
+data StackFrameIter = StackFrameIter
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset,
+ -- TODO: could be a sum type to prevent boolean-blindness
+ isPrimitive :: !Bool
+ }
+
+instance Show StackFrameIter where
+ showsPrec _ (StackFrameIter s# i p) rs =
+ -- 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#)
+ pad_out ls = '0':'x':ls
+data Box = Box Any | StackFrameBox StackFrameIter
#else
data Box = Box Any
#endif
@@ -89,7 +118,9 @@ instance Show Box where
addr = ptr - tag
pad_out ls = '0':'x':ls
#if MIN_VERSION_base(4,17,0)
- showsPrec _ (DecodedBox a) rs = "(DecodedBox " ++ show a ++ ")" ++ rs
+ showsPrec _ (StackFrameBox sfi) rs =
+ -- TODO: Record syntax could be nicer to read
+ "(StackFrameBox StackFrameIter(" ++ show sfi ++ ")" ++ rs
#endif
-- | Boxes can be compared, but this is not pure, as different heap objects can,
@@ -100,9 +131,13 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
0# -> pure False
_ -> pure True
#if MIN_VERSION_base(4,17,0)
-areBoxesEqual (DecodedBox a) (DecodedBox b) = areBoxesEqual
- (Box (unsafeCoerce a))
- (Box (unsafeCoerce b))
+-- 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
areBoxesEqual _ _ = pure False
#endif
@@ -600,24 +635,3 @@ allClosures (RetBCO {..}) = bco : bcoArgs
#endif
allClosures _ = []
--- | Get the size of the top-level closure in words.
--- Includes header and payload. Does not follow pointers.
---
--- @since 8.10.1
-closureSize :: Box -> Int
-closureSize (Box x) = I# (closureSize# x)
-#if MIN_VERSION_base(4,17,0)
-closureSize (DecodedBox c) = case c of
- UpdateFrame {} -> sizeStgUpdateFrame
- CatchFrame {} -> sizeStgCatchFrame
- CatchStmFrame {} -> sizeStgCatchSTMFrame
- CatchRetryFrame {} -> sizeStgCatchRetryFrame
- AtomicallyFrame {} -> sizeStgAtomicallyFrame
- RetSmall {..} -> sizeStgClosure + length payload
- RetBig {..} -> sizeStgClosure + length payload
- RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
- -- The one additional word is a pointer to the StgBCO in the closure's payload
- RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
- -- TODO: What to do about other closure types?
- _ -> error "Unexpected closure type"
-#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -1,5 +1,6 @@
#include "MachDeps.h"
#include "Rts.h"
+#include "RtsAPI.h"
#include "rts/Messages.h"
#include "rts/Types.h"
#include "rts/storage/ClosureTypes.h"
@@ -199,9 +200,11 @@ static StgArrBytes *largeBitmapToStgArrBytes(Capability *cap, StgLargeBitmap *bi
StgArrBytes *getLargeBitmap(Capability *cap, StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
-
+ debugBelch("getLargeBitmap %p \n", c);
const StgInfoTable *info = get_itbl(c);
+ debugBelch("getLargeBitmap tipe %ul \n", info->type);
StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+ debugBelch("getLargeBitmap size %lu \n", bitmap->size);
return largeBitmapToStgArrBytes(cap, bitmap);
}
@@ -239,3 +242,12 @@ StgWord getRetFunType(StgRetFun *ret_fun) {
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
return fun_info->f.fun_type;
}
+
+RTS_INFO(box_info);
+StgClosure* getBoxedClosure(Capability *cap, StgClosure **c){
+// StgClosure *box = (StgClosure*) allocate(cap, sizeofW(StgClosure) + 1);
+// SET_HDR(box, &box_info, CCS_SYSTEM);
+// box->payload[0] = *c;
+// return box;
+ return *c;
+}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -174,3 +174,33 @@ getInfoTableAddrzh(P_ stack, W_ offsetWords){
return (info);
}
+
+// Just a cast
+stackSnapshotToWordzh(P_ stack) {
+ ccall checkSTACK(stack);
+ return (stack);
+}
+
+eqStackSnapshotszh(P_ stack1, P_ stack2) {
+ ccall checkSTACK(stack1);
+ ccall checkSTACK(stack2);
+ return (stack1 == stack2);
+}
+
+getBoxedClosurezh(P_ stack, W_ offsetWords){
+ ccall checkSTACK(stack);
+ P_ ptr;
+ ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+ P_ box;
+ (box) = ccall getBoxedClosure(MyCapability(), ptr);
+ return (box);
+}
+
+INFO_TABLE_CONSTR(box, 1, 0, 0, CONSTR_1_0, "BOX", "BOX")
+{ foreign "C" barf("BOX object (%p) entered!", R1) never returns; }
+
+checkSanityzh(I64 a, I64 b){
+ ccall checkSanity(a,b);
+ return (42);
+}
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -29,8 +29,8 @@ import Unsafe.Coerce (unsafeCoerce)
getDecodedStack :: IO (StackSnapshot, [Closure])
getDecodedStack = do
- s <- cloneMyStack
- (SimpleStack cs) <- decodeStack s
+ s@(StackSnapshot s#) <- cloneMyStack
+ (SimpleStack cs) <- getClosureData s#
unboxedCs <- mapM getBoxedClosureData cs
pure (s, unboxedCs)
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -24,6 +24,7 @@ import GHC.Stack.CloneStack (StackSnapshot (..))
import System.Mem
import TestUtils
import Unsafe.Coerce (unsafeCoerce)
+import Data.Functor
foreign import prim "any_update_framezh" any_update_frame# :: SetupFunction
@@ -61,6 +62,8 @@ foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
+foreign import prim "checkSanityzh" checkSanity# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
+
{- Test stategy
~~~~~~~~~~~~
@@ -90,6 +93,7 @@ N.B. the test data stack are only meant be de decoded. They are not executable
-}
main :: HasCallStack => IO ()
main = do
+ traceM $ "Test 1"
test any_update_frame# $
\case
UpdateFrame {..} -> do
@@ -97,7 +101,9 @@ main = do
assertEqual knownUpdateFrameType NormalUpdateFrame
assertEqual 1 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 2"
testSize any_update_frame# 2
+ traceM $ "Test 3"
test any_catch_frame# $
\case
CatchFrame {..} -> do
@@ -105,7 +111,9 @@ main = do
assertEqual exceptions_blocked 1
assertConstrClosure 1 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 4"
testSize any_catch_frame# 3
+ traceM $ "Test 5"
test any_catch_stm_frame# $
\case
CatchStmFrame {..} -> do
@@ -113,7 +121,9 @@ main = do
assertConstrClosure 1 =<< getBoxedClosureData catchFrameCode
assertConstrClosure 2 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 6"
testSize any_catch_stm_frame# 3
+ traceM $ "Test 7"
test any_catch_retry_frame# $
\case
CatchRetryFrame {..} -> do
@@ -122,7 +132,9 @@ main = do
assertConstrClosure 1 =<< getBoxedClosureData first_code
assertConstrClosure 2 =<< getBoxedClosureData alt_code
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 8"
testSize any_catch_retry_frame# 4
+ traceM $ "Test 9"
test any_atomically_frame# $
\case
AtomicallyFrame {..} -> do
@@ -130,8 +142,10 @@ main = do
assertConstrClosure 1 =<< getBoxedClosureData atomicallyFrameCode
assertConstrClosure 2 =<< getBoxedClosureData result
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 10"
testSize any_atomically_frame# 3
-- TODO: Test for UnderflowFrame once it points to a Box payload
+ traceM $ "Test 11"
test any_ret_small_prim_frame# $
\case
RetSmall {..} -> do
@@ -141,7 +155,9 @@ main = do
assertEqual (length pCs) 1
assertUnknownTypeWordSizedPrimitive 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 12"
testSize any_ret_small_prim_frame# 2
+ traceM $ "Test 13"
test any_ret_small_closure_frame# $
\case
RetSmall {..} -> do
@@ -151,7 +167,9 @@ main = do
assertEqual (length pCs) 1
assertConstrClosure 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 14"
testSize any_ret_small_closure_frame# 2
+ traceM $ "Test 15"
test any_ret_small_closures_frame# $
\case
RetSmall {..} -> do
@@ -162,7 +180,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 58]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 16"
testSize any_ret_small_closures_frame# (1 + fromIntegral maxSmallBitmapBits_c)
+ traceM $ "Test 17"
test any_ret_small_prims_frame# $
\case
RetSmall {..} -> do
@@ -173,7 +193,9 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1 .. 58]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 18"
testSize any_ret_small_prims_frame# (1 + fromIntegral maxSmallBitmapBits_c)
+ traceM $ "Test 19"
test any_ret_big_prims_min_frame# $
\case
RetBig {..} -> do
@@ -183,7 +205,9 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1 .. 59]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 20"
testSize any_ret_big_prims_min_frame# (minBigBitmapBits + 1)
+ traceM $ "Test 21"
test any_ret_big_closures_min_frame# $
\case
RetBig {..} -> do
@@ -193,7 +217,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 59]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 22"
testSize any_ret_big_closures_min_frame# (minBigBitmapBits + 1)
+ traceM $ "Test 23"
test any_ret_big_closures_two_words_frame# $
\case
RetBig {..} -> do
@@ -204,7 +230,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. (fromIntegral closureCount)]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 24"
testSize any_ret_big_closures_two_words_frame# (64 + 1 + 1)
+ traceM $ "Test 25"
test any_ret_fun_arg_n_prim_framezh# $
\case
RetFun {..} -> do
@@ -217,6 +245,7 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 26"
test any_ret_fun_arg_gen_framezh# $
\case
RetFun {..} -> do
@@ -235,7 +264,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 9]
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 27"
testSize any_ret_fun_arg_gen_framezh# (3 + 9)
+ traceM $ "Test 28"
test any_ret_fun_arg_gen_big_framezh# $
\case
RetFun {..} -> do
@@ -253,7 +284,9 @@ main = do
assertEqual (length pCs) 59
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 59]
+ traceM $ "Test 29"
testSize any_ret_fun_arg_gen_big_framezh# (3 + 59)
+ traceM $ "Test 30"
test any_bco_frame# $
\case
RetBCO {..} -> do
@@ -277,20 +310,30 @@ main = do
bitmap
e -> error $ "Wrong closure type: " ++ show e
e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 31"
testSize any_bco_frame# 3
+ traceM $ "Test 32"
type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
test :: HasCallStack => SetupFunction -> (Closure -> IO ()) -> IO ()
test setup assertion = do
- sn <- getStackSnapshot setup
+ checkSanity 1# 1#
+ sn@(StackSnapshot sn#) <- getStackSnapshot setup
+ traceM $ "test - sn " ++ show sn
+ traceM $ "entertainGC - " ++ (entertainGC 10)
-- Run garbage collection now, to prevent later surprises: It's hard to debug
-- when the GC suddenly does it's work and there were bad closures or pointers.
-- Better fail early, here.
performGC
- (SimpleStack boxedFrames) <- decodeStack sn
+ traceM $ "test - sn' " ++ show sn
+ ss@(SimpleStack boxedFrames) <- getClosureData sn#
+ traceM $ "test - ss" ++ show ss
+ checkSanity 1# 1#
performGC
+ traceM $ "call getBoxedClosureData"
stack <- mapM getBoxedClosureData boxedFrames
+ checkSanity 1# 1#
performGC
assert sn stack
-- The result of HasHeapRep should be similar (wrapped in the closure for
@@ -317,11 +360,17 @@ test setup assertion = do
(last stack)
assertion $ head stack
+entertainGC :: Int -> String
+entertainGC 0 = "0"
+entertainGC x = show x ++ entertainGC (x -1)
+
testSize :: HasCallStack => SetupFunction -> Int -> IO ()
testSize setup expectedSize = do
- sn <- getStackSnapshot setup
- (SimpleStack boxedFrames) <- decodeStack sn
- assertEqual expectedSize (closureSize (head boxedFrames))
+ checkSanity 1# 1#
+ (StackSnapshot sn#) <- getStackSnapshot setup
+ (SimpleStack boxedFrames) <- getClosureData sn#
+ assertEqual expectedSize =<< closureSize (head boxedFrames)
+ void $ checkSanity 1# 1#
-- | Get a `StackSnapshot` from test setup
--
@@ -331,6 +380,10 @@ getStackSnapshot :: SetupFunction -> IO StackSnapshot
getStackSnapshot action# = IO $ \s ->
case action# s of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+checkSanity :: Int# -> Int# -> IO Int
+checkSanity b1# b2# = IO $ \s ->
+ case checkSanity# b1# b2# s of (# s1, r1 #) -> (# s1, I# r1 #)
+
assertConstrClosure :: HasCallStack => Word -> Closure -> IO ()
assertConstrClosure w c = case c of
ConstrClosure {..} -> do
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -247,6 +247,7 @@ extern void checkSTACK(StgStack *stack);
StgStack *setup(Capability *cap, StgWord closureSizeWords,
void (*f)(Capability *, StgStack *, StgWord)) {
+ checkSanity(1, 1);
StgWord totalSizeWords =
sizeofW(StgStack) + closureSizeWords + MIN_STACK_WORDS;
StgStack *stack = (StgStack *)allocate(cap, totalSizeWords);
@@ -270,6 +271,7 @@ StgStack *setup(Capability *cap, StgWord closureSizeWords,
// Make a sanitiy check to find unsound closures before the GC and the decode
// code.
checkSTACK(stack);
+ checkSanity(1, 1);
return stack;
}
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -97,7 +97,7 @@ run m = case m of
mapM (\case
Heap.Box x -> mkRemoteRef (HValue x)
-- TODO: Is this unsafeCoerce really necessary?
- Heap.DecodedBox d -> mkRemoteRef (HValue (unsafeCoerce d))
+ Heap.StackFrameBox d -> mkRemoteRef (HValue (unsafeCoerce d))
) clos
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
=====================================
rts/sm/Sanity.c
=====================================
@@ -62,6 +62,7 @@ checkSmallBitmap( StgPtr payload, StgWord bitmap, uint32_t size )
{
uint32_t i;
+ debugBelch("checkSmallBitmap - payload %p , bitmap %lu, size %u\n", payload, bitmap, size);
for(i = 0; i < size; i++, bitmap >>= 1 ) {
if ((bitmap & 1) == 0) {
checkClosureShallow((StgClosure *)payload[i]);
@@ -1324,5 +1325,9 @@ memInventory (bool show)
}
-
+//TODO: Remove after debugging
+#else
+void
+checkSTACK (StgStack *stack){}
+void checkSanity (bool after_gc, bool major_gc){}
#endif /* DEBUG */
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7c7d4ff30965a2028dfe781eba83d9699b40426
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7c7d4ff30965a2028dfe781eba83d9699b40426
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/20230131/2ee8d113/attachment-0001.html>
More information about the ghc-commits
mailing list