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

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
+      }