[Git][ghc/ghc][wip/decode_cloned_stack] Invariant: Haskell ClosureTypes should be the same as if decoded with C
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Dec 3 16:07:03 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
989cebf1 by Sven Tennie at 2022-12-03T16:06:14+00:00
Invariant: Haskell ClosureTypes should be the same as if decoded with C
- - - - -
7 changed files:
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- libraries/ghc-heap/tests/stack_big_ret.hs
- − libraries/ghc-heap/tests/stack_comparison.hs
- libraries/ghc-heap/tests/stack_lib.c
- libraries/ghc-heap/tests/stack_stm_frames.hs
- libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -1,9 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UnliftedFFITypes #-}
-module TestUtils where
+module TestUtils
+ ( assertEqual,
+ assertThat,
+ assertStackInvariants
+ )
+where
+import Data.Array.Byte
+import GHC.Exts
import GHC.Exts.DecodeStack
+import GHC.Exts.Heap
+import GHC.Records
import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
assertEqual a b
@@ -13,8 +28,8 @@ assertEqual a b
assertThat :: (HasCallStack, Monad m) => String -> (a -> Bool) -> a -> m ()
assertThat s f a = if f a then pure () else error s
-assertStackInvariants :: (HasCallStack, Monad m) => [StackFrame] -> m ()
-assertStackInvariants decodedStack =
+assertStackInvariants :: (HasCallStack, Monad m) => StackSnapshot -> [StackFrame] -> m ()
+assertStackInvariants stack decodedStack = do
assertThat
"Last frame is stop frame"
( \case
@@ -22,3 +37,98 @@ assertStackInvariants decodedStack =
_ -> False
)
(last decodedStack)
+ assertEqual
+ (toClosureTypes decodedStack)
+ (toClosureTypes stack)
+
+class ToClosureTypes a where
+ toClosureTypes :: a -> [ClosureType]
+
+instance ToClosureTypes StackSnapshot where
+ toClosureTypes = stackSnapshotToClosureTypes . foldStackToArrayClosure
+
+instance ToClosureTypes StackFrame where
+ toClosureTypes = stackFrameToClosureTypes
+
+instance ToClosureTypes a => ToClosureTypes [a] where
+ toClosureTypes = concatMap toClosureTypes
+
+foreign import ccall "foldStackToArrayClosure" foldStackToArrayClosure# :: StackSnapshot# -> ByteArray#
+
+foldStackToArrayClosure :: StackSnapshot -> ByteArray
+foldStackToArrayClosure (StackSnapshot s#) = ByteArray (foldStackToArrayClosure# s#)
+
+stackSnapshotToClosureTypes :: ByteArray -> [ClosureType]
+stackSnapshotToClosureTypes = wordsToClosureTypes . toWords
+ where
+ toWords :: ByteArray -> [Word]
+ toWords ba@(ByteArray b#) =
+ let s = I# (sizeofByteArray# b#)
+ in -- TODO: Adjust 8 to machine word size
+ [W# (indexWordArray# b# (toInt# i)) | i <- [0 .. maxWordIndex (ba)]]
+ where
+ maxWordIndex :: ByteArray -> Int
+ maxWordIndex (ByteArray ba#) =
+ let s = I# (sizeofByteArray# ba#)
+ words = s `div` 8
+ in case words of
+ w | w == 0 -> error "ByteArray contains no content!"
+ w -> w - 1
+
+ wordsToClosureTypes :: [Word] -> [ClosureType]
+ wordsToClosureTypes = map (toEnum . fromIntegral)
+
+toInt# :: Int -> Int#
+toInt# (I# i#) = i#
+
+stackFrameToClosureTypes :: StackFrame -> [ClosureType]
+stackFrameToClosureTypes sf =
+ case sf of
+ (UpdateFrame {updatee, ..}) -> UPDATE_FRAME : getClosureTypes updatee
+ (CatchFrame {handler, ..}) -> CATCH_FRAME : getClosureTypes handler
+ (CatchStmFrame {code, handler}) -> CATCH_STM_FRAME : getClosureTypes code ++ getClosureTypes handler
+ (CatchRetryFrame {first_code, alt_code, ..}) -> CATCH_RETRY_FRAME : getClosureTypes first_code ++ getClosureTypes alt_code
+ (AtomicallyFrame {code, result}) -> ATOMICALLY_FRAME : getClosureTypes code ++ getClosureTypes result
+ (UnderflowFrame {..}) -> [UNDERFLOW_FRAME]
+ StopFrame -> [STOP_FRAME]
+ (RetSmall {payload, ..}) -> RET_SMALL : getBitmapClosureTypes payload
+ (RetBig {payload}) -> RET_BIG : getBitmapClosureTypes payload
+ (RetFun {fun, payload, ..}) -> RET_FUN : getClosureTypes fun ++ getBitmapClosureTypes payload
+ (RetBCO {instrs, literals, ptrs, payload, ..}) ->
+ RET_BCO : getClosureTypes instrs ++ getClosureTypes literals ++ getClosureTypes ptrs ++ getBitmapClosureTypes payload
+ where
+ getClosureTypes :: Closure -> [ClosureType]
+ getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
+ getClosureTypes (FunClosure {info, ..}) = [tipe info]
+ getClosureTypes (ThunkClosure {info, ..}) = [tipe info]
+ getClosureTypes (SelectorClosure {info, ..}) = [tipe info]
+ getClosureTypes (PAPClosure {info, ..}) = [tipe info]
+ getClosureTypes (APClosure {info, ..}) = [tipe info]
+ getClosureTypes (APStackClosure {info, ..}) = [tipe info]
+ getClosureTypes (IndClosure {info, ..}) = [tipe info]
+ getClosureTypes (BCOClosure {info, ..}) = [tipe info]
+ getClosureTypes (BlackholeClosure {info, ..}) = [tipe info]
+ getClosureTypes (ArrWordsClosure {info, ..}) = [tipe info]
+ getClosureTypes (MutArrClosure {info, ..}) = [tipe info]
+ getClosureTypes (SmallMutArrClosure {info, ..}) = [tipe info]
+ getClosureTypes (MVarClosure {info, ..}) = [tipe info]
+ getClosureTypes (IOPortClosure {info, ..}) = [tipe info]
+ getClosureTypes (MutVarClosure {info, ..}) = [tipe info]
+ getClosureTypes (BlockingQueueClosure {info, ..}) = [tipe info]
+ getClosureTypes (WeakClosure {info, ..}) = [tipe info]
+ getClosureTypes (TSOClosure {info, ..}) = [tipe info]
+ getClosureTypes (StackClosure {info, ..}) = [tipe info]
+ getClosureTypes (OtherClosure {info, ..}) = [tipe info]
+ getClosureTypes (UnsupportedClosure {info, ..}) = [tipe info]
+ getClosureTypes _ = []
+
+ getBitmapClosureTypes :: [BitmapPayload] -> [ClosureType]
+ getBitmapClosureTypes bps =
+ reverse $
+ foldl
+ ( \acc p -> case p of
+ (Closure c) -> getClosureTypes c ++ acc
+ (Primitive _) -> acc
+ )
+ []
+ bps
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -60,37 +60,35 @@ test('decode_cloned_stack',
[only_ways(['normal'])],
compile_and_run, ['-debug -optc-g -g'])
+# TODO: Remove debug flags
test('stack_big_ret',
[
- extra_files(['TestUtils.hs']),
+ extra_files(['stack_lib.c', 'TestUtils.hs']),
ignore_stdout,
ignore_stderr
],
- compile_and_run,
- ['-debug'])
+ multi_compile_and_run,
+ ['stack_big_ret', [('stack_lib.c','')], '-debug -optc-g -g'])
+# TODO: Remove debug flags
# Options:
# - `-kc512B -kb64B`: Make stack chunk size small to provoke underflow stack frames.
test('stack_underflow',
[
- extra_files(['TestUtils.hs']),
+ extra_files(['stack_lib.c', 'TestUtils.hs']),
extra_run_opts('+RTS -kc512B -kb64B -RTS'),
ignore_stdout,
ignore_stderr
],
- compile_and_run, ['-debug -rtsopts'])
+ multi_compile_and_run,
+ ['stack_underflow', [('stack_lib.c','')], '-debug -optc-g -g'])
+# TODO: Remove debug flags
test('stack_stm_frames',
[
- extra_files(['TestUtils.hs']),
+ extra_files(['stack_lib.c', 'TestUtils.hs']),
ignore_stdout,
ignore_stderr
],
- compile_and_run, ['-debug'])
-
-test('stack_comparison',
- [extra_files(['stack_lib.c','TestUtils.hs']),
-# ignore_stdout,
- ignore_stderr
- ],
- multi_compile_and_run, ['stack_comparison', [('stack_lib.c','')], '-debug -optc-g -g'])
+ multi_compile_and_run,
+ ['stack_stm_frames', [('stack_lib.c','')], '-debug -optc-g -g'])
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -34,11 +34,11 @@ 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
- stackSnapshot <- readIORef stackRef
+ mbStackSnapshot <- readIORef stackRef
+ let stackSnapshot = fromJust mbStackSnapshot
+ !decodedStack <- decodeStack stackSnapshot
- !decodedStack <- decodeStack (fromJust stackSnapshot)
-
- assertStackInvariants decodedStack
+ assertStackInvariants stackSnapshot decodedStack
assertThat
"Stack contains one big return frame"
(== 1)
=====================================
libraries/ghc-heap/tests/stack_comparison.hs deleted
=====================================
@@ -1,103 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE UnliftedFFITypes #-}
-
-module Main where
-
-import Data.Array.Byte
-import GHC.Exts
-import GHC.Exts.DecodeStack
-import GHC.Exts.Heap
-import GHC.Exts.Heap (StgInfoTable (StgInfoTable))
-import GHC.Records
-import GHC.Stack.CloneStack
-import TestUtils
-
-foreign import ccall "foldStackToArrayClosure" foldStackToArrayClosure# :: StackSnapshot# -> ByteArray#
-
-foldStackToArrayClosure :: StackSnapshot -> ByteArray
-foldStackToArrayClosure (StackSnapshot s#) = ByteArray (foldStackToArrayClosure# s#)
-
-main :: IO ()
-main = do
- stack <- cloneMyStack
- let ba = foldStackToArrayClosure stack
- let s = I# (sizeofByteArray# b#)
- (ByteArray b#) = ba
- print . show . wordsToClosureTypes . toWords $ ba
- frames <- decodeStack stack
- print $ show (concatMap stackFrameToClosureTypes frames)
-
-toWords :: ByteArray -> [Word]
-toWords ba@(ByteArray b#) =
- let s = I# (sizeofByteArray# b#)
- in -- TODO: Adjust 8 to machine word size
- [W# (indexWordArray# b# (toInt# i)) | i <- [0 .. maxWordIndex (ba)]]
- where
- maxWordIndex :: ByteArray -> Int
- maxWordIndex (ByteArray ba#) =
- let s = I# (sizeofByteArray# ba#)
- words = s `div` 8
- in case words of
- w | w == 0 -> error "ByteArray contains no content!"
- w -> w - 1
-
-wordsToClosureTypes :: [Word] -> [ClosureType]
-wordsToClosureTypes = map (toEnum . fromIntegral)
-
-toInt# :: Int -> Int#
-toInt# (I# i#) = i#
-
-stackFrameToClosureTypes :: StackFrame -> [ClosureType]
-stackFrameToClosureTypes sf =
- case sf of
- (UpdateFrame {updatee, ..}) -> UPDATE_FRAME : getClosureTypes updatee
- (CatchFrame {handler, ..}) -> CATCH_FRAME : getClosureTypes handler
- (CatchStmFrame {code, handler}) -> CATCH_STM_FRAME : getClosureTypes code ++ getClosureTypes handler
- (CatchRetryFrame {first_code, alt_code, ..}) -> CATCH_RETRY_FRAME : getClosureTypes first_code ++ getClosureTypes alt_code
- (AtomicallyFrame {code, result}) -> ATOMICALLY_FRAME : getClosureTypes code ++ getClosureTypes result
- (UnderflowFrame {..}) -> [UNDERFLOW_FRAME]
- StopFrame -> [STOP_FRAME]
- (RetSmall {payload, ..}) -> RET_SMALL : getBitmapClosureTypes payload
- (RetBig {payload}) -> RET_BIG : getBitmapClosureTypes payload
- (RetFun {fun, payload, ..}) -> RET_FUN : getClosureTypes fun ++ getBitmapClosureTypes payload
- (RetBCO {instrs, literals, ptrs, payload, ..}) ->
- RET_BCO : getClosureTypes instrs ++ getClosureTypes literals ++ getClosureTypes ptrs ++ getBitmapClosureTypes payload
-
-getClosureTypes :: Closure -> [ClosureType]
-getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
-getClosureTypes (FunClosure {info, ..}) = [tipe info]
-getClosureTypes (ThunkClosure {info, ..}) = [tipe info]
-getClosureTypes (SelectorClosure {info, ..}) = [tipe info]
-getClosureTypes (PAPClosure {info, ..}) = [tipe info]
-getClosureTypes (APClosure {info, ..}) = [tipe info]
-getClosureTypes (APStackClosure {info, ..}) = [tipe info]
-getClosureTypes (IndClosure {info, ..}) = [tipe info]
-getClosureTypes (BCOClosure {info, ..}) = [tipe info]
-getClosureTypes (BlackholeClosure {info, ..}) = [tipe info]
-getClosureTypes (ArrWordsClosure {info, ..}) = [tipe info]
-getClosureTypes (MutArrClosure {info, ..}) = [tipe info]
-getClosureTypes (SmallMutArrClosure {info, ..}) = [tipe info]
-getClosureTypes (MVarClosure {info, ..}) = [tipe info]
-getClosureTypes (IOPortClosure {info, ..}) = [tipe info]
-getClosureTypes (MutVarClosure {info, ..}) = [tipe info]
-getClosureTypes (BlockingQueueClosure {info, ..}) = [tipe info]
-getClosureTypes (WeakClosure {info, ..}) = [tipe info]
-getClosureTypes (TSOClosure {info, ..}) = [tipe info]
-getClosureTypes (StackClosure {info, ..}) = [tipe info]
-getClosureTypes (OtherClosure {info, ..}) = [tipe info]
-getClosureTypes (UnsupportedClosure {info, ..}) = [tipe info]
-getClosureTypes _ = []
-
-getBitmapClosureTypes :: [BitmapPayload] -> [ClosureType]
-getBitmapClosureTypes bps =
- reverse $
- foldl
- ( \acc p -> case p of
- (Closure c) -> getClosureTypes c ++ acc
- (Primitive _) -> acc
- )
- []
- bps
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -87,6 +87,7 @@ ClosureTypeList *foldLargeBitmapToList(StgPtr spBottom, StgPtr payload,
for (; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1) {
if ((bitmap & 1) == 0) {
StgClosure *c = (StgClosure *)payload[i];
+ c = UNTAG_CONST_CLOSURE(c);
list = add(list, get_itbl(c)->type);
}
// TODO: Primitives are ignored here.
@@ -114,7 +115,7 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
}
case UPDATE_FRAME: {
StgUpdateFrame *f = (StgUpdateFrame *)sp;
- result = add(result, get_itbl(f->updatee)->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->updatee))->type);
continue;
}
case CATCH_FRAME: {
@@ -127,14 +128,14 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
}
case CATCH_STM_FRAME: {
StgCatchSTMFrame *f = (StgCatchSTMFrame *)sp;
- result = add(result, get_itbl(f->code)->type);
- result = add(result, get_itbl(f->handler)->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->code))->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->handler))->type);
continue;
}
case ATOMICALLY_FRAME: {
StgAtomicallyFrame *f = (StgAtomicallyFrame *)sp;
- result = add(result, get_itbl(f->code)->type);
- result = add(result, get_itbl(f->result)->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->code))->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->result))->type);
continue;
}
case RET_SMALL: {
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -9,18 +9,21 @@ import TestUtils
main :: IO ()
main = do
- decodedStack <-
+ (stackSnapshot, decodedStack) <-
atomically $
catchSTM @SomeException (unsafeIOToSTM getDecodedStack) throwSTM
- assertStackInvariants decodedStack
+ assertStackInvariants stackSnapshot decodedStack
assertThat
"Stack contains one catch stm frame"
(== 1)
(length $ filter isCatchStmFrame decodedStack)
-getDecodedStack :: IO [StackFrame]
-getDecodedStack = cloneMyStack >>= decodeStack
+getDecodedStack :: IO (StackSnapshot, [StackFrame])
+getDecodedStack = do
+ s <-cloneMyStack
+ fs <- decodeStack s
+ pure (s, fs)
isCatchStmFrame :: StackFrame -> Bool
isCatchStmFrame (CatchStmFrame _ _) = True
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -20,7 +20,7 @@ getStack = do
!decodedStack <- decodeStack s
-- Uncomment to see the frames (for debugging purposes)
-- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
- assertStackInvariants decodedStack
+ assertStackInvariants s decodedStack
assertThat
"Stack contains underflow frames"
(== True)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989cebf1929949435251e4c22986e6fb512d7f3a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989cebf1929949435251e4c22986e6fb512d7f3a
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/20221203/db207e42/attachment-0001.html>
More information about the ghc-commits
mailing list