Add reproducer for dealloc instructions in switch table jump expressions (#25733)

testsuite/tests/cmm/should_run/JumpTableNoStackDealloc.hs

+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import Data.Foldable
+import GHC.Exts
+import GHC.Int
+
+foreign import prim "foo" foo :: Int64# -> Int64#
+
+main :: IO ()
+main = for_ [0 .. 9] $ \(I64# x#) -> print $ I64# (foo x#)

testsuite/tests/cmm/should_run/JumpTableNoStackDealloc.stdout

+0
+0
+0
+6
+0
+2
+0
+4
+0
+0
+Before switch
+Inside branch 0 
+Before jump 0 
+End :) 
+Before switch
+Inside branch 1 
+Before jump 1 
+End :) 
+Before switch
+Inside branch 8 
+Before jump 8 
+End :) 
+Before switch
+Inside default branch
+Before jump default
+End :) 
+Before switch
+Inside branch 6 
+Before jump 6 
+End :) 
+Before switch
+Inside branch 7 
+Before jump 7 
+End :) 
+Before switch
+Inside branch 4 
+Before jump 4 
+End :) 
+Before switch
+Inside branch 5 
+Before jump 5 
+End :) 
+Before switch
+Inside branch 2 
+Before jump 2 
+End :) 
+Before switch
+Inside branch 3 
+Before jump 3 
+End :) 

testsuite/tests/cmm/should_run/JumpTableNoStackDeallocGen.hs

+-- | Generates the JumpTableNoStackDealloc test
+--
+-- The test is a reproducer of #25733 where stack spill slots where wrongly
+-- deallocated for switch table jumps. This only happened when the initial
+-- stack (RESERVED_C_STACK_BYTES, 2048 * SIZEOF_LONG, 16k on most 64bit
+-- architectures) was full. I.e. we were breaking the assumptions explained in
+-- Note [extra spill slots].
+--
+-- The strategy of this test is to first fill the C stack by having many local
+-- variables that are used later. This leads to stack spilling. In the broken
+-- implemetation of the CodeGen, the invalid stack pointer led to a
+-- segmentation fault / core dump. Its absence, i.e. a suceessful run of this
+-- test, shows that the stack pointer is intact.
+--
+-- The calculations in this test are pretty randomly choosen: They are only
+-- made to prevent inlining and constant folding.
+--
+-- The real test can be generated by running:
+-- `ghc JumpTableNoStackDeallocGen.hs && ./JumpTableNoStackDeallocGen > JumpTableNoStackDealloc_cmm.cmm`
+module Main where
+
+import Control.Monad
+import Data.List
+
+printVarDecl :: Int -> IO ()
+printVarDecl i = do
+  putStrLn $ "  I64 i" ++ show i ++ ";"
+  putStrLn $ "  i" ++ show i ++ " = (" ++ show i ++ " " ++ op ++ " x) % 10;"
+  where
+    -- Add some variance. Otherwise, GHC inlines the expressions.
+    op = case i of
+      _
+        | even i -> "+"
+        | odd i -> "-"
+
+addVars :: [Int] -> String
+addVars = opVars "+"
+  where
+    opVars :: String -> [Int] -> String
+    opVars op is = concat $ intersperse op $ map ((++) "i" . show) is
+
+printCase :: Int -> IO ()
+printCase i = do
+  putStrLn $ "    case " ++ show i ++ ": {"
+  putStrLn $ "      ccall printf(\"Inside branch %d \\n\", " ++ show i ++ ");"
+  putStrLn $ "      res = i" ++ show i ++ ";"
+  putStrLn $ "      ccall printf(\"Before jump %d \\n\", " ++ show i ++ ");"
+  putStrLn $ "      goto END;"
+  putStrLn $ "    }"
+
+main :: IO ()
+main = do
+  -- This number depends on the amount of available registers. 2048 works for
+  -- AArch64, adding a bit more to be safe in case an architecture has more
+  -- free fregisters.
+  let varNums = [0 .. 2060]
+  putStrLn "// Generated by JumpTableNoStackDeallocGen.hs\n"
+  putStrLn "#include \"Cmm.h\""
+  putStrLn "foo (I64 x) {"
+  forM_ varNums printVarDecl
+  putStrLn "\n  I64 res;"
+  putStrLn "  ccall printf(\"Before switch\\n\");"
+  putStrLn $ "  switch [0 .. 9] ((" ++ addVars varNums ++ ") % 10) {"
+  forM_ [0 .. 8] printCase
+  putStrLn "    default: {"
+  putStrLn "      ccall printf(\"Inside default branch\\n\");"
+  putStrLn "      res = x * (2 :: I64);"
+  putStrLn "      ccall printf(\"Before jump default\\n\");"
+  putStrLn "      goto END;"
+  putStrLn "    }"
+  putStrLn "  }"
+  putStrLn "END:"
+  putStrLn "  ccall printf(\"End :) \\n\");"
+  putStrLn $ "  return (res);"
+  putStrLn "}"

testsuite/tests/cmm/should_run/all.T

@@ -31,6 +31,13 @@ test('T22871',
      multi_compile_and_run,
      ['T22871', [('T22871_cmm.cmm', '')], ''])
 
+test('JumpTableNoStackDealloc',
+     [    extra_run_opts('"' + config.libdir + '"')
+     ,    req_cmm
+     ],
+     multi_compile_and_run,
+     ['JumpTableNoStackDealloc', [('JumpTableNoStackDealloc_cmm.cmm', '')], ''])
+
 test('AtomicFetch',
      [    extra_run_opts('"' + config.libdir + '"')
      ,    req_cmm