ghc-heap: Add closure_size_noopt testwip/closure-size

This adds a new test, only run in the `normal` way, to verify the size
of FUNs and PAPs.

4 files changed, 77 insertions, 56 deletions

diff --git a/libraries/ghc-heap/tests/ClosureSizeUtils.hs b/libraries/ghc-heap/tests/ClosureSizeUtils.hs
new file mode 100644
index 0000000000..5fafa4f7a5
--- /dev/null
+++ b/libraries/ghc-heap/tests/ClosureSizeUtils.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Utilities for the @closure_size@ tests
+module ClosureSizeUtils (assertSize, assertSizeUnlifted) where
+
+import Control.Monad
+import GHC.Exts
+import GHC.Exts.Heap.Closures
+import GHC.Stack
+import Type.Reflection
+
+profHeaderSize :: Int
+#if PROFILING
+profHeaderSize = 2
+#else
+profHeaderSize = 0
+#endif
+
+assertSize
+  :: forall a. (HasCallStack, Typeable a)
+  => a     -- ^ closure
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSize x =
+  assertSizeBox (asBox x) (typeRep @a)
+
+assertSizeUnlifted
+  :: forall (a :: TYPE 'UnliftedRep). (HasCallStack, Typeable a)
+  => a     -- ^ closure
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSizeUnlifted x =
+  assertSizeBox (Box (unsafeCoerce# x)) (typeRep @a)
+
+assertSizeBox
+  :: forall a. (HasCallStack)
+  => Box   -- ^ closure
+  -> TypeRep a
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSizeBox x ty expected = do
+  let !size = closureSize x
+  when (size /= expected') $ do
+    putStrLn $ "closureSize ("++show ty++") == "++show size++", expected "++show expected'
+    putStrLn $ prettyCallStack callStack
+  where expected' = expected + profHeaderSize
+{-# NOINLINE assertSize #-}
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index 5db21b39db..88520e319d 100644
--- a/libraries/ghc-heap/tests/all.T
+++ b/libraries/ghc-heap/tests/all.T
@@ -5,11 +5,22 @@ test('heap_all',
       omit_ways(['ghci', 'hpc'])
      ],
      compile_and_run, [''])
+
+# Test everything except FUNs and PAPs in all ways.
 test('closure_size',
-     [ when(have_profiling(), extra_ways(['prof'])),
+     [extra_files(['ClosureSizeUtils.hs']),
+      when(have_profiling(), extra_ways(['prof'])),
       # These ways produce slightly different heap representations.
       # Currently we don't test them.
       omit_ways(['hpc'])
      ],
      compile_and_run, [''])
 
+# Test PAPs and FUNs only in normal way (e.g. with -O0)
+# since otherwise the simplifier interferes.
+test('closure_size_noopt',
+     [extra_files(['ClosureSizeUtils.hs']),
+      only_ways(['normal'])
+     ],
+     compile_and_run, [''])
+
diff --git a/libraries/ghc-heap/tests/closure_size.hs b/libraries/ghc-heap/tests/closure_size.hs
index f381a57521..d760f22efa 100644
--- a/libraries/ghc-heap/tests/closure_size.hs
+++ b/libraries/ghc-heap/tests/closure_size.hs
@@ -1,60 +1,12 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
 
-import Control.Monad
-import Type.Reflection
 import GHC.Exts
-import GHC.Stack
 import GHC.IO
-
-import GHC.Exts.Heap.Closures
-
-assertSize
-  :: forall a. (HasCallStack, Typeable a)
-  => a     -- ^ closure
-  -> Int   -- ^ expected size in words
-  -> IO ()
-assertSize x =
-  assertSizeBox (asBox x) (typeRep @a)
-
-assertSizeUnlifted
-  :: forall (a :: TYPE 'UnliftedRep). (HasCallStack, Typeable a)
-  => a     -- ^ closure
-  -> Int   -- ^ expected size in words
-  -> IO ()
-assertSizeUnlifted x =
-  assertSizeBox (Box (unsafeCoerce# x)) (typeRep @a)
-
-assertSizeBox
-  :: forall a. (HasCallStack)
-  => Box   -- ^ closure
-  -> TypeRep a
-  -> Int   -- ^ expected size in words
-  -> IO ()
-assertSizeBox x ty expected = do
-  let !size = closureSize x
-  when (size /= expected') $ do
-    putStrLn $ "closureSize ("++show ty++") == "++show size++", expected "++show expected'
-    putStrLn $ prettyCallStack callStack
-  where expected' = expected + profHeaderSize
-{-# NOINLINE assertSize #-}
-
-pap :: Int -> Char -> Int
-pap x _ = x
-{-# NOINLINE pap #-}
-
-profHeaderSize :: Int
-#if PROFILING
-profHeaderSize = 2
-#else
-profHeaderSize = 0
-#endif
+import ClosureSizeUtils
 
 data A = A (Array# Int)
 data MA = MA (MutableArray# RealWorld Int)
@@ -72,12 +24,6 @@ main = do
   assertSize ((1,2) :: (Int,Int)) 3
   assertSize ((1,2,3) :: (Int,Int,Int)) 4
 
-  -- These depend too much upon the behavior of the simplifier to
-  -- test reliably.
-  --assertSize (id :: Int -> Int) 1
-  --assertSize (fst :: (Int,Int) -> Int) 1
-  --assertSize (pap 1) 2
-
   MA ma <- IO $ \s ->
       case newArray# 0# 0 s of
           (# s1, x #) -> (# s1, MA x #)
diff --git a/libraries/ghc-heap/tests/closure_size_noopt.hs b/libraries/ghc-heap/tests/closure_size_noopt.hs
new file mode 100644
index 0000000000..0ec7ebb062
--- /dev/null
+++ b/libraries/ghc-heap/tests/closure_size_noopt.hs
@@ -0,0 +1,12 @@
+import ClosureSizeUtils
+
+pap :: Int -> Char -> Int
+pap x _ = x
+{-# NOINLINE pap #-}
+
+main :: IO ()
+main = do
+  assertSize (id :: Int -> Int) 1
+  assertSize (fst :: (Int,Int) -> Int) 1
+  assertSize (pap 1) 2
+