[Git][ghc/ghc][wip/decode_cloned_stack] Test big return frames

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC


Commits:
98f7acc0 by Sven Tennie at 2022-10-11T20:30:59+00:00
Test big return frames

- - - - -


3 changed files:

- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+#if MIN_VERSION_base(4,17,0)
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GHCForeignImportPrim #-}
 {-# LANGUAGE MagicHash #-}
@@ -12,9 +13,12 @@
 {-# LANGUAGE BangPatterns #-}
 
 -- TODO: Find better place than top level. Re-export from top-level?
-module GHC.Exts.DecodeStack where
+module GHC.Exts.DecodeStack (
+  StackFrame(..),
+  BitmapPayload(..),
+  decodeStack
+                            ) where
 
-#if MIN_VERSION_base(4,17,0)
 import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
 import Data.Maybe
 import Data.Bits
@@ -233,7 +237,7 @@ data StackFrame =
   UnderflowFrame { nextChunk:: StackSnapshot } |
   StopFrame |
   RetSmall SpecialRetSmall [BitmapPayload] |
-  RetBig [BitmapPayload] |
+  RetBig { payload :: [BitmapPayload] } |
   RetFun |
   RetBCO
   deriving (Show)
@@ -259,4 +263,6 @@ decodeStack' s = unpackStackFrameIter (stackHead s) : go (advanceStackFrameIter
     go Nothing = []
     go (Just sfi) = unpackStackFrameIter sfi : go (advanceStackFrameIter sfi)
 
+#else
+module GHC.Exts.DecodeStack where
 #endif


=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -1,7 +1,24 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE LambdaCase #-}
+
 module TestUtils where
 
-assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+import GHC.Exts.DecodeStack
+import GHC.Stack (HasCallStack)
+
+assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
 assertEqual a b
   | a /= b = error (show a ++ " /= " ++ show b)
-  | otherwise = return ()
+  | otherwise = pure ()
+
+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 =
+  assertThat
+    "Last frame is stop frame"
+    ( \case
+        StopFrame -> True
+        _ -> False
+    )
+    (last decodedStack)


=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -60,15 +60,20 @@ test('decode_cloned_stack',
      [only_ways(['normal'])],
      compile_and_run, ['-debug -optc-g -g'])
 
-# TODO: Are debug flags needed here?
-test('decode_cloned_stack_big_ret',
-     [only_ways(['normal'])],
-     compile_and_run, ['-debug -optc-g -g -DDEBUG'])
+test('stack_big_ret',
+     [
+        extra_files(['TestUtils.hs']),
+        ignore_stdout,
+        ignore_stderr
+     ],
+     compile_and_run,
+     [''])
 
 # Options:
 #   - `-kc512B -kb64B`: Make stack chunk size small to provoke underflow stack frames.
 test('stack_underflow',
      [
+        extra_files(['TestUtils.hs']),
          extra_run_opts('+RTS -kc512B -kb64B -RTS'),
          ignore_stdout,
          ignore_stderr



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98f7acc048ca29d49719f9537565aae43cc28c6c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98f7acc048ca29d49719f9537565aae43cc28c6c
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/20221011/74ba971f/attachment-0001.html>