[Git][ghc/ghc][wip/decode_cloned_stack] Use IO in decoding; Fix memory allocation bug in test setup
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Feb 3 10:11:26 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
ea608c2d by Sven Tennie at 2023-02-03T10:10:35+00:00
Use IO in decoding; Fix memory allocation bug in test setup
- - - - -
8 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/all.T
- libraries/ghc-heap/tests/stack_big_ret.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_misc_closures_c.c
- libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -35,6 +35,8 @@ import GHC.Exts.Heap.InfoTable
import GHC.Exts.StackConstants
import GHC.Stack.CloneStack
import Prelude
+import GHC.IO (IO (..))
+import Data.Array.Byte
{- Note [Decoding the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -101,46 +103,50 @@ foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word
derefStackWord :: StackFrameIter -> Word
derefStackWord (StackFrameIter {..}) = W# (derefStackWord# stackSnapshot# (wordOffsetToWord# index))
-foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> Word#
+foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-getUpdateFrameType :: StackFrameIter -> UpdateFrameType
-getUpdateFrameType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) (W# (getUpdateFrameType# stackSnapshot# (wordOffsetToWord# index)))
+getUpdateFrameType :: StackFrameIter -> IO UpdateFrameType
+getUpdateFrameType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getUpdateFrameType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, uft# #) -> (# s1, W# uft# #))
-foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> StackSnapshot#
+foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
-getUnderflowFrameNextChunk :: StackFrameIter -> StackSnapshot
-getUnderflowFrameNextChunk (StackFrameIter {..}) = StackSnapshot s#
- where
- s# = getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)
+getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
+getUnderflowFrameNextChunk (StackFrameIter {..}) = IO $ \s ->
+ case getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, stack# #) -> (# s1, StackSnapshot stack# #)
-foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
foreign import prim "getAddrzh" getAddr# :: StackSnapshot# -> Word# -> Addr#
-getWord :: StackFrameIter -> WordOffset -> Word
-getWord (StackFrameIter {..}) relativeOffset = W# (getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset))
+getWord :: StackFrameIter -> WordOffset -> IO Word
+getWord (StackFrameIter {..}) relativeOffset = IO $ \s ->
+ case getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset) s of
+ (# s1, w# #) -> (# s1, W# w# #)
-foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-getRetFunType :: StackFrameIter -> RetFunType
-getRetFunType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) (W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index)))
+-- TODO: Could use getWord
+getRetFunType :: StackFrameIter -> IO RetFunType
+getRetFunType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getRetFunType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
-foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
-foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
-foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
-foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
-foreign import prim "getRetSmallSpecialTypezh" getRetSmallSpecialType# :: StackSnapshot# -> Word# -> Word#
+foreign import prim "getRetSmallSpecialTypezh" getRetSmallSpecialType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-getRetSmallSpecialType :: StackFrameIter -> SpecialRetSmall
-getRetSmallSpecialType (StackFrameIter {..}) =
- let special# = getRetSmallSpecialType# stackSnapshot# (wordOffsetToWord# index)
- in (toEnum . fromInteger . toInteger) (W# special#)
+getRetSmallSpecialType :: StackFrameIter -> IO SpecialRetSmall
+getRetSmallSpecialType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getRetSmallSpecialType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
-foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
@@ -151,7 +157,7 @@ getInfoTable StackFrameIter {..} =
let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
in peekItbl infoTablePtr
-foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> Any
+foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Addr# #)
-- -- TODO: Remove this instance (debug only)
-- instance Show StackFrameIter where
@@ -203,39 +209,42 @@ toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize =
}
: toBitmapEntries (StackFrameIter stackSnapshot# (index + 1) False) (bitmapWord `shiftR` 1) (bSize - 1)
-toBitmapPayload :: BitmapEntry -> Box
+toBitmapPayload :: BitmapEntry -> IO Box
toBitmapPayload e
- | (isPrimitive . closureFrame) e = trace "PRIM" $ StackFrameBox $ (closureFrame e) {
+ | (isPrimitive . closureFrame) e = trace "PRIM" $ pure . StackFrameBox $ (closureFrame e) {
isPrimitive = True
}
toBitmapPayload e = getClosure (closureFrame e) 0
-getClosure :: StackFrameIter -> WordOffset -> Box
-getClosure StackFrameIter {..} relativeOffset =
- let !c = (getBoxedClosure# stackSnapshot# (wordOffsetToWord# (index + relativeOffset)))
- in
- Box c
-
-decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> [Box]
-decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
- let !(# bitmapArray#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
- bitmapWords :: [Word] = byteArrayToList bitmapArray#
- in decodeBitmaps sfi relativePayloadOffset bitmapWords (W# size#)
-
-decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> [Box]
+getClosure :: StackFrameIter -> WordOffset -> IO Box
+getClosure sfi at StackFrameIter {..} relativeOffset = trace ("getClosure " ++ show sfi ++ " " ++ show relativeOffset) $
+ IO $ \s ->
+ case (getBoxedClosure# stackSnapshot# (wordOffsetToWord# (index + relativeOffset)) s) of (# s1, ptr #) ->
+ (# s1, Box (unsafeCoerce# ptr) #)
+
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+ (bitmapArray, size) <- IO $ \s ->
+ case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, ba#, s# #) -> (# s1, (ByteArray ba#, W# s#) #)
+ let bitmapWords :: [Word] = byteArrayToList bitmapArray
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+
+decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
decodeBitmaps (StackFrameIter {..}) 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]
-decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
- let !(# bitmap#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
- size = W# size#
- bitmapWords = if size > 0 then [(W# bitmap#)] else []
- in decodeBitmaps sfi relativePayloadOffset bitmapWords size
-
-byteArrayToList :: ByteArray# -> [Word]
-byteArrayToList bArray = go 0
+ in mapM toBitmapPayload bes
+
+decodeSmallBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+ (bitmap, size) <- IO $ \s ->
+ case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, b# , s# #) -> (# s1, (W# b# , W# s#) #)
+ let bitmapWords = if size > 0 then [bitmap] else []
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+
+byteArrayToList :: ByteArray -> [Word]
+byteArrayToList (ByteArray bArray) = go 0
where
go i
| i < maxIndex = (W# (indexWordArray# bArray (toInt# i))) : (go (i + 1))
@@ -246,82 +255,104 @@ wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# wo = intToWord# (fromIntegral wo)
unpackStackFrameIter :: StackFrameIter -> IO Closure
-unpackStackFrameIter sfi | isPrimitive sfi = pure $ UnknownTypeWordSizedPrimitive (getWord sfi 0)
+unpackStackFrameIter sfi | isPrimitive sfi = UnknownTypeWordSizedPrimitive <$> (getWord sfi 0)
unpackStackFrameIter sfi = do
- info <- getInfoTable sfi
traceM $ "unpackStackFrameIter - sfi " ++ show sfi
- traceM $ "unpackStackFrameIter - unpacked " ++ show (unpackStackFrameIter' info)
- pure $ unpackStackFrameIter' info
+ info <- getInfoTable sfi
+ res <- unpackStackFrameIter' info
+ traceM $ "unpackStackFrameIter - unpacked " ++ show res
+ pure res
where
- unpackStackFrameIter' :: StgInfoTable -> Closure
+ unpackStackFrameIter' :: StgInfoTable -> IO Closure
unpackStackFrameIter' info =
case tipe info of
- RET_BCO ->
- RetBCO
+ RET_BCO -> do
+ bco' <- getClosure sfi offsetStgClosurePayload
+ -- The arguments begin directly after the payload's one element
+ bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
+ pure $ RetBCO
{ info = info,
- bco = getClosure sfi offsetStgClosurePayload,
- -- The arguments begin directly after the payload's one element
- bcoArgs = decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
+ bco = bco',
+ bcoArgs = bcoArgs'
}
RET_SMALL ->
- trace "RET_SMALL" $
- RetSmall
+ trace "RET_SMALL" $ do
+ payload' <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ knownRetSmallType' <- getRetSmallSpecialType sfi
+ pure $ RetSmall
{ info = info,
- knownRetSmallType = getRetSmallSpecialType sfi,
- payload = decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ knownRetSmallType = knownRetSmallType',
+ payload = payload'
}
- RET_BIG ->
- RetBig
+ RET_BIG -> do
+ payload' <- decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ pure $ RetBig
{ info = info,
- payload = decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ payload = payload'
}
- RET_FUN ->
- RetFun
+ RET_FUN -> do
+ retFunType' <- getRetFunType sfi
+ retFunSize' <- getWord sfi offsetStgRetFunFrameSize
+ retFunFun' <- getClosure sfi offsetStgRetFunFrameFun
+ retFunPayload' <-
+ if retFunType' == ARG_GEN_BIG
+ then decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
+ else decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
+ pure $ RetFun
{ info = info,
- retFunType = getRetFunType sfi,
- retFunSize = getWord sfi offsetStgRetFunFrameSize,
- retFunFun = getClosure sfi offsetStgRetFunFrameFun,
- retFunPayload =
- if getRetFunType sfi == ARG_GEN_BIG
- then decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
- else decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
+ retFunType = retFunType',
+ retFunSize = retFunSize',
+ retFunFun = retFunFun',
+ retFunPayload = retFunPayload'
}
- UPDATE_FRAME ->
- UpdateFrame
+ UPDATE_FRAME -> do
+ updatee' <- getClosure sfi offsetStgUpdateFrameUpdatee
+ knownUpdateFrameType' <- getUpdateFrameType sfi
+ pure $ UpdateFrame
{ info = info,
- knownUpdateFrameType = getUpdateFrameType sfi,
- updatee = getClosure sfi offsetStgUpdateFrameUpdatee
+ knownUpdateFrameType = knownUpdateFrameType',
+ updatee = updatee'
}
- CATCH_FRAME ->
- CatchFrame
+ CATCH_FRAME -> do
+ exceptions_blocked' <- getWord sfi offsetStgCatchFrameExceptionsBlocked
+ handler' <- getClosure sfi offsetStgCatchFrameHandler
+ pure $ CatchFrame
{ info = info,
- exceptions_blocked = getWord sfi offsetStgCatchFrameExceptionsBlocked,
- handler = getClosure sfi offsetStgCatchFrameHandler
+ exceptions_blocked = exceptions_blocked',
+ handler = handler'
}
- UNDERFLOW_FRAME ->
- UnderflowFrame
+ UNDERFLOW_FRAME -> do
+ nextChunk' <- getUnderflowFrameNextChunk sfi
+ pure $ UnderflowFrame
{ info = info,
- nextChunk = getUnderflowFrameNextChunk sfi
+ nextChunk = nextChunk'
}
- STOP_FRAME -> StopFrame {info = info}
- ATOMICALLY_FRAME ->
- AtomicallyFrame
+ STOP_FRAME -> pure $ StopFrame {info = info}
+ ATOMICALLY_FRAME -> do
+ atomicallyFrameCode' <- getClosure sfi offsetStgAtomicallyFrameCode
+ result' <- getClosure sfi offsetStgAtomicallyFrameResult
+ pure $ AtomicallyFrame
{ info = info,
- atomicallyFrameCode = getClosure sfi offsetStgAtomicallyFrameCode,
- result = getClosure sfi offsetStgAtomicallyFrameResult
+ atomicallyFrameCode = atomicallyFrameCode',
+ result = result'
}
- CATCH_RETRY_FRAME ->
- CatchRetryFrame
+ CATCH_RETRY_FRAME -> do
+ running_alt_code' <- getWord sfi offsetStgCatchRetryFrameRunningAltCode
+ first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
+ alt_code' <- getClosure sfi offsetStgCatchRetryFrameAltCode
+ pure $ CatchRetryFrame
{ info = info,
- running_alt_code = getWord sfi offsetStgCatchRetryFrameRunningAltCode,
- first_code = getClosure sfi offsetStgCatchRetryFrameRunningFirstCode,
- alt_code = getClosure sfi offsetStgCatchRetryFrameAltCode
+ running_alt_code = running_alt_code',
+ first_code = first_code',
+ alt_code = alt_code'
}
- CATCH_STM_FRAME ->
- CatchStmFrame
+ CATCH_STM_FRAME -> do
+ catchFrameCode' <- getClosure sfi offsetStgCatchSTMFrameCode
+ handler' <- getClosure sfi offsetStgCatchSTMFrameHandler
+ pure $ CatchStmFrame
{ info = info,
- catchFrameCode = getClosure sfi offsetStgCatchSTMFrameCode,
- handler = getClosure sfi offsetStgCatchSTMFrameHandler
+ catchFrameCode = catchFrameCode',
+ handler = handler'
}
x -> error $ "Unexpected closure type on stack: " ++ show x
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -182,8 +182,8 @@ getClosureDataFromHeapObject x = do
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
-getBoxedClosureData (Box a) = let !a' = a
- in getClosureData a'
+getBoxedClosureData (Box a) = getClosureData a
+
#if MIN_TOOL_VERSION_ghc(9,5,0)
getBoxedClosureData b@(StackFrameBox sfi) = trace ("unpack " ++ show b) $ unpackStackFrameIter sfi
#endif
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -177,7 +177,6 @@ getInfoTableAddrzh(P_ stack, W_ offsetWords){
// Just a cast
stackSnapshotToWordzh(P_ stack) {
- ccall checkSTACK(stack);
return (stack);
}
@@ -188,19 +187,17 @@ eqStackSnapshotszh(P_ stack1, P_ stack2) {
}
getBoxedClosurezh(P_ stack, W_ offsetWords){
+ ccall debugBelch("getBoxedClosurezh - stack %p , offsetWords %lu", stack, offsetWords);
+
ccall checkSTACK(stack);
P_ ptr;
ptr = StgStack_sp(stack) + WDS(offsetWords);
P_ box;
(box) = ccall getBoxedClosure(MyCapability(), ptr);
+ ccall debugBelch("getBoxedClosurezh - box %p", box);
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/all.T
=====================================
@@ -102,5 +102,5 @@ test('stack_misc_closures',
[ ('stack_misc_closures_c.c', '')
,('stack_misc_closures_prim.cmm', '')
]
- , '-debug -optc-g -optc-O0 -g -ddump-to-file -dlint -ddump-cmm'
+ , '-debug -optc-g -optc-O0 -g -ddump-to-file -dlint -ddump-cmm' # -with-rtsopts="-Dg -Ds -Db"'
])
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -36,8 +36,8 @@ main = do
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
mbStackSnapshot <- readIORef stackRef
- let stackSnapshot = fromJust mbStackSnapshot
- (SimpleStack boxedFrames) <- decodeStack stackSnapshot
+ let stackSnapshot@(StackSnapshot s#) = fromJust mbStackSnapshot
+ (SimpleStack boxedFrames) <- getClosureData s#
stackFrames <- mapM getBoxedClosureData boxedFrames
assertStackInvariants stackSnapshot stackFrames
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -62,8 +62,6 @@ 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
~~~~~~~~~~~~
@@ -318,9 +316,10 @@ type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
test :: HasCallStack => SetupFunction -> (Closure -> IO ()) -> IO ()
test setup assertion = do
- checkSanity 1# 1#
+ traceM $ "test - getStackSnapshot"
sn@(StackSnapshot sn#) <- getStackSnapshot setup
traceM $ "test - sn " ++ show sn
+ performGC
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.
@@ -329,11 +328,9 @@ test setup assertion = do
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
@@ -366,11 +363,9 @@ entertainGC x = show x ++ entertainGC (x -1)
testSize :: HasCallStack => SetupFunction -> Int -> IO ()
testSize setup expectedSize = do
- 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
--
@@ -380,10 +375,6 @@ 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
=====================================
@@ -245,15 +245,15 @@ void create_any_bco_frame(Capability *cap, StgStack *stack, StgWord w) {
// Import from Sanity.c
extern void checkSTACK(StgStack *stack);
+// Basically, a stripped down version of createThread() (regarding stack
+// creation)
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);
- StgWord totalSizeBytes = WDS(totalSizeWords);
SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM);
- stack->stack_size = totalSizeBytes;
+ stack->stack_size = totalSizeWords - sizeofW(StgStack);
stack->dirty = 0;
stack->marking = 0;
@@ -271,7 +271,6 @@ 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/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -37,7 +37,7 @@ isUnderflowFrame _ = False
assertStackChunksAreDecodable :: HasCallStack => [Closure] -> IO ()
assertStackChunksAreDecodable s = do
let underflowFrames = filter isUnderflowFrame s
- framesOfChunks <- mapM (decodeStack . nextChunk) underflowFrames
+ let framesOfChunks = map (stackClosures . decodeStack . nextChunk) underflowFrames
assertThat
"No empty stack chunks"
(== True)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea608c2d3df40d7818c71b332fe4aa6b03e587f3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea608c2d3df40d7818c71b332fe4aa6b03e587f3
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/20230203/258a56f9/attachment-0001.html>
More information about the ghc-commits
mailing list