diff options
author | Sven Tennie <sven.tennie@gmail.com> | 2021-04-03 19:35:34 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-09-23 15:59:38 -0400 |
commit | 29717ecb0711cd03796510fbe9b4bff58c7da870 (patch) | |
tree | 850a449ef01caeedf8fd8e9156e7eedcd5a028ce /testsuite/tests | |
parent | 6f7f59901c047882ba8c9ae8812264f86b12483a (diff) | |
download | haskell-29717ecb0711cd03796510fbe9b4bff58c7da870.tar.gz |
Use Info Table Provenances to decode cloned stack (#18163)
Emit an Info Table Provenance Entry (IPE) for every stack represeted info table
if -finfo-table-map is turned on.
To decode a cloned stack, lookupIPE() is used. It provides a mapping between
info tables and their source location.
Please see these notes for details:
- [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
- [Mapping Info Tables to Source Positions]
Metric Increase:
T12545
Diffstat (limited to 'testsuite/tests')
-rw-r--r-- | testsuite/tests/profiling/should_run/T7275.stdout | 32 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/all.T | 6 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack001.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack001.stdout | 6 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack002.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack002.stdout | 8 | ||||
-rw-r--r-- | testsuite/tests/rts/all.T | 8 | ||||
-rw-r--r-- | testsuite/tests/rts/cloneMyStack.hs | 18 | ||||
-rw-r--r-- | testsuite/tests/rts/cloneMyStack2.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/rts/cloneStackLib.c | 2 | ||||
-rw-r--r-- | testsuite/tests/rts/cloneThreadStack.hs | 39 | ||||
-rw-r--r-- | testsuite/tests/rts/decodeMyStack.hs | 23 | ||||
-rw-r--r-- | testsuite/tests/rts/decodeMyStack.stdout | 12 | ||||
-rw-r--r-- | testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs | 24 | ||||
-rw-r--r-- | testsuite/tests/rts/decodeMyStack_underflowFrames.hs | 67 |
15 files changed, 199 insertions, 63 deletions
diff --git a/testsuite/tests/profiling/should_run/T7275.stdout b/testsuite/tests/profiling/should_run/T7275.stdout index d0146366a7..4dbeabc5c6 100644 --- a/testsuite/tests/profiling/should_run/T7275.stdout +++ b/testsuite/tests/profiling/should_run/T7275.stdout @@ -3,19 +3,19 @@ 2 3 4 -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T index b793bce24f..399ec3da71 100644 --- a/testsuite/tests/profiling/should_run/all.T +++ b/testsuite/tests/profiling/should_run/all.T @@ -14,13 +14,19 @@ test('dynamic-prof2', [only_ways(['normal']), extra_run_opts('+RTS -hT --no-auto test('dynamic-prof3', [only_ways(['normal']), extra_run_opts('+RTS -hT --no-automatic-heap-samples')], compile_and_run, ['']) +# Remove the ipName field as it's volatile (depends on e.g. architecture and may change with every new GHC version) +def normalise_InfoProv_ipName(str): + return re.sub('ipName = "\\w*"', '', str) + test('staticcallstack001', [ omit_ways(['ghci-ext-prof']), # produces a different stack + normalise_fun(normalise_InfoProv_ipName) ], compile_and_run, ['-O0 -g3 -fdistinct-constructor-tables -finfo-table-map']) test('staticcallstack002', [ omit_ways(['ghci-ext-prof']), # produces a different stack + normalise_fun(normalise_InfoProv_ipName) ], compile_and_run, ['-O0 -g3 -fdistinct-constructor-tables -finfo-table-map']) diff --git a/testsuite/tests/profiling/should_run/staticcallstack001.hs b/testsuite/tests/profiling/should_run/staticcallstack001.hs index 78849d0ef1..e3e1407492 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack001.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack001.hs @@ -13,7 +13,6 @@ qq x = D x caf = D 5 main = do - print . tail =<< whereFrom (D 5) - print . tail =<< whereFrom caf - print . tail =<< whereFrom (id (D 5)) - + print =<< whereFrom (D 5) + print =<< whereFrom caf + print =<< whereFrom (id (D 5)) diff --git a/testsuite/tests/profiling/should_run/staticcallstack001.stdout b/testsuite/tests/profiling/should_run/staticcallstack001.stdout index 7da74c81d9..6a701358e3 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack001.stdout +++ b/testsuite/tests/profiling/should_run/staticcallstack001.stdout @@ -1,3 +1,3 @@ -["2","D","main","Main","staticcallstack001.hs:16:20-34"] -["2","D","caf","Main","staticcallstack001.hs:13:1-9"] -["15","D","main","Main","staticcallstack001.hs:18:30-39"] +Just (InfoProv {ipName = "D_Main_4_con_info", ipDesc = "2", ipTyDesc = "D", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack001.hs:16:13-27"}) +Just (InfoProv {ipName = "D_Main_2_con_info", ipDesc = "2", ipTyDesc = "D", ipLabel = "caf", ipMod = "Main", ipLoc = "staticcallstack001.hs:13:1-9"}) +Just (InfoProv {ipName = "sat_s11g_info", ipDesc = "15", ipTyDesc = "D", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack001.hs:18:23-32"}) diff --git a/testsuite/tests/profiling/should_run/staticcallstack002.hs b/testsuite/tests/profiling/should_run/staticcallstack002.hs index 87df13bee0..da3d66efb2 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack002.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack002.hs @@ -7,8 +7,7 @@ import GHC.Stack.CCS -- a special case to not generate distinct info tables for unboxed -- constructors. main = do - print . tail =<< whereFrom (undefined (# #)) - print . tail =<< whereFrom (undefined (# () #)) - print . tail =<< whereFrom (undefined (# (), () #)) - print . tail =<< whereFrom (undefined (# | () #)) - + print =<< whereFrom (undefined (# #)) + print =<< whereFrom (undefined (# () #)) + print =<< whereFrom (undefined (# (), () #)) + print =<< whereFrom (undefined (# | () #)) diff --git a/testsuite/tests/profiling/should_run/staticcallstack002.stdout b/testsuite/tests/profiling/should_run/staticcallstack002.stdout index c96b6fa7f3..d3b62d47d2 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack002.stdout +++ b/testsuite/tests/profiling/should_run/staticcallstack002.stdout @@ -1,4 +1,4 @@ -["15","Any","main","Main","staticcallstack002.hs:10:30-46"] -["15","Any","main","Main","staticcallstack002.hs:11:30-49"] -["15","Any","main","Main","staticcallstack002.hs:12:30-53"] -["15","Any","main","Main","staticcallstack002.hs:13:30-51"] +Just (InfoProv {ipName = "sat_s10U_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:10:23-39"}) +Just (InfoProv {ipName = "sat_s11a_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:11:23-42"}) +Just (InfoProv {ipName = "sat_s11q_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:12:23-46"}) +Just (InfoProv {ipName = "sat_s11G_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:13:23-44"}) diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 2c73973680..c12e8d14ca 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -487,8 +487,14 @@ test('T19381', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['']) test('T20199', normal, makefile_test, []) test('ipeMap', [c_src], compile_and_run, ['']) + test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c']) test('cloneMyStack2', ignore_stdout, compile_and_run, ['']) test('cloneMyStack_retBigStackFrame', [extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c']) - test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded']) +test('decodeMyStack', normal, compile_and_run, ['-finfo-table-map']) +# Options: +# - `-kc8K`: Set stack chunk size to it's minimum to provoke underflow stack frames. +test('decodeMyStack_underflowFrames', [extra_run_opts('+RTS -kc8K -RTS')], compile_and_run, ['-finfo-table-map -rtsopts']) +# -finfo-table-map intentionally missing +test('decodeMyStack_emptyListForMissingFlag', [ignore_stdout, ignore_stderr], compile_and_run, ['']) diff --git a/testsuite/tests/rts/cloneMyStack.hs b/testsuite/tests/rts/cloneMyStack.hs index cdc93e6004..11a69201e0 100644 --- a/testsuite/tests/rts/cloneMyStack.hs +++ b/testsuite/tests/rts/cloneMyStack.hs @@ -16,14 +16,14 @@ foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> -- snapshot is still valid afterwards (is not gc'ed while in use). main :: IO () main = do - stackSnapshot <- cloneMyStack + stackSnapshot <- cloneMyStack - performMajorGC + performMajorGC - let (StackSnapshot stack) = stackSnapshot - let expectedClosureTypes = [ 30 -- RET_SMALL - , 30 -- RET_SMALL - , 34 -- CATCH_FRAME - , 36 -- STOP_FRAME - ] - withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes)) + let (StackSnapshot stack) = stackSnapshot + let expectedClosureTypes = [ 30 -- RET_SMALL + , 30 -- RET_SMALL + , 34 -- CATCH_FRAME + , 36 -- STOP_FRAME + ] + withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes)) diff --git a/testsuite/tests/rts/cloneMyStack2.hs b/testsuite/tests/rts/cloneMyStack2.hs index 068c816ce5..e00a263d80 100644 --- a/testsuite/tests/rts/cloneMyStack2.hs +++ b/testsuite/tests/rts/cloneMyStack2.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} + module Main where import GHC.Stack.CloneStack diff --git a/testsuite/tests/rts/cloneStackLib.c b/testsuite/tests/rts/cloneStackLib.c index a89a069886..c4050c45aa 100644 --- a/testsuite/tests/rts/cloneStackLib.c +++ b/testsuite/tests/rts/cloneStackLib.c @@ -75,7 +75,7 @@ static int countOnes(StgPtr spBottom, StgPtr payload, case CONSTR_0_1: { const StgConInfoTable *con_info = get_con_itbl(closure); if (strcmp(GET_CON_DESC(con_info), "ghc-prim:GHC.Types.I#") == 0 && - closure->payload[0] == 1) { + closure->payload[0] == (StgClosure*) 1) { ones++; } break; diff --git a/testsuite/tests/rts/cloneThreadStack.hs b/testsuite/tests/rts/cloneThreadStack.hs index 11b37d3577..fa2bc66795 100644 --- a/testsuite/tests/rts/cloneThreadStack.hs +++ b/testsuite/tests/rts/cloneThreadStack.hs @@ -19,36 +19,35 @@ foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSn -- snapshot is still valid afterwards (is not gc'ed while in use). main :: IO () main = do - mVarToBeBlockedOn <- newEmptyMVar - threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn + mVarToBeBlockedOn <- newEmptyMVar + threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn - waitUntilBlocked threadId + waitUntilBlocked threadId - stackSnapshot <- cloneThreadStack threadId + stackSnapshot <- cloneThreadStack threadId - performMajorGC + performMajorGC - let (StackSnapshot stack) = stackSnapshot - let (ThreadId tid#) = threadId - expectStacksToBeEqual stack tid# - expectStackToBeNotDirty stack + let (StackSnapshot stack) = stackSnapshot + let (ThreadId tid#) = threadId + expectStacksToBeEqual stack tid# + expectStackToBeNotDirty stack immediatelyBlocking :: MVar Int -> IO () immediatelyBlocking mVarToBeBlockedOn = do - takeMVar mVarToBeBlockedOn - return () + takeMVar mVarToBeBlockedOn + return () waitUntilBlocked :: ThreadId -> IO () waitUntilBlocked tid = do - blocked <- isBlocked tid - if blocked then - return () - else - do - threadDelay 100000 - waitUntilBlocked tid - -isBlocked:: ThreadId -> IO Bool + blocked <- isBlocked tid + if blocked + then return () + else do + threadDelay 100000 + waitUntilBlocked tid + +isBlocked :: ThreadId -> IO Bool isBlocked = fmap isThreadStatusBlocked . threadStatus isThreadStatusBlocked :: ThreadStatus -> Bool diff --git a/testsuite/tests/rts/decodeMyStack.hs b/testsuite/tests/rts/decodeMyStack.hs new file mode 100644 index 0000000000..b0c330ee34 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack.hs @@ -0,0 +1,23 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe + +getDeepStack :: Int -> (Int, [StackEntry]) +getDeepStack deepness = case getDeepStackCase deepness of + [] -> (0, []) + s -> (deepness, s) + where + getDeepStackCase :: Int -> [StackEntry] + getDeepStackCase 0 = + unsafePerformIO $ + ( do + stack <- cloneMyStack + GHC.Stack.CloneStack.decode stack + ) + getDeepStackCase n = snd $ getDeepStack $ n - 1 + +main :: IO () +main = do + let (_, stackEntries) = getDeepStack 10 + mapM_ (putStrLn . show) stackEntries diff --git a/testsuite/tests/rts/decodeMyStack.stdout b/testsuite/tests/rts/decodeMyStack.stdout new file mode 100644 index 0000000000..62d635d0fc --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack.stdout @@ -0,0 +1,12 @@ +StackEntry {functionName = "main.(...)", moduleName = "Main", srcLoc = "decodeMyStack.hs:22:27-41", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:13:7-21", closureType = 53} diff --git a/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs b/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs new file mode 100644 index 0000000000..d30102ed27 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs @@ -0,0 +1,24 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe + +returnFrame :: Int -> [StackEntry] +returnFrame i = case ( unsafePerformIO $ do + stack <- cloneMyStack + stackEntries <- decode stack + pure (i, stackEntries) + ) of + (1, stackEntries) -> stackEntries + _ -> [] + +main :: IO () +main = do + assertEqual (returnFrame 1) [] + return () + +assertEqual :: (Eq a, Show a) => a -> a -> IO () +assertEqual x y = + if x == y + then return () + else error $ "assertEqual: " ++ show x ++ " /= " ++ show y diff --git a/testsuite/tests/rts/decodeMyStack_underflowFrames.hs b/testsuite/tests/rts/decodeMyStack_underflowFrames.hs new file mode 100644 index 0000000000..aca05150d4 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack_underflowFrames.hs @@ -0,0 +1,67 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe +import Control.Monad + +getDeepStack :: Int -> (Int, [StackEntry]) +getDeepStack deepness = case getDeepStackCase deepness of + [] -> (0, []) + s -> (deepness, s) + where + getDeepStackCase :: Int -> [StackEntry] + getDeepStackCase 0 = + unsafePerformIO $ + ( do + stack <- cloneMyStack + GHC.Stack.CloneStack.decode stack + ) + getDeepStackCase n = snd $ getDeepStack $ n - 1 + +assertEqual :: (Eq a, Show a) => a -> a -> IO () +assertEqual x y = + if x == y + then return () + else error $ "assertEqual: " ++ show x ++ " /= " ++ show y + +main :: IO () +main = do + let (_, stack) = getDeepStack 1000 + + assertEqual (length stack) 1003 + assertEqual + (stack !! 0) + StackEntry + { functionName = "assertEqual", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:23:11", + closureType = 53 + } + assertEqual + (stack !! 1) + StackEntry + { functionName = "main.(...)", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:29:20-36", + closureType = 53 + } + forM_ + [2 .. 1001] + ( \i -> + assertEqual + (stack !! i) + StackEntry + { functionName = "getDeepStack.getDeepStackCase", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:19:26-28", + closureType = 53 + } + ) + assertEqual + (stack !! 1002) + StackEntry + { functionName = "getDeepStack.getDeepStackCase", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:14:7-21", + closureType = 53 + } |