[Git][ghc/ghc][wip/closure-size] testsuite: fix and extend closure_size test

[Ben Gamari]

Ben Gamari pushed to branch wip/closure-size at Glasgow Haskell Compiler / GHC


Commits:
99639cee by Ben Gamari at 2019-06-08T03:17:17Z
testsuite: fix and extend closure_size test

this was previously broken in several ways. this is fixed and it also
now tests arrays. unfortunately i was unable to find a way to continue
testing pap and fun sizes; these simply depend too much upon the
behavior of the simplifier.

i tried to extend it to test non-empty arrays as well but unfortunately
this was non-trivial as the array card size constant isn't readily
available from haskell.

fixes #16531.

- - - - -


2 changed files:

- libraries/ghc-heap/tests/all.T
- libraries/ghc-heap/tests/closure_size.hs


Changes:

=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -1,11 +1,15 @@
 test('heap_all',
-     [when(have_profiling(),
-      extra_ways(['prof'])),
+     [when(have_profiling(), extra_ways(['prof'])),
       # These ways produce slightly different heap representations.
       # Currently we don't test them.
       omit_ways(['ghci', 'hpc'])
      ],
      compile_and_run, [''])
 test('closure_size',
-     omit_ways(['ghci', 'hpc', 'prof']),
+     [ 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, [''])
+


=====================================
libraries/ghc-heap/tests/closure_size.hs
=====================================
@@ -1,26 +1,69 @@
 {-# 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 -> Int -> IO ()
-assertSize !x expected = do
-  let !size = closureSize (asBox x)
-  when (size /= expected) $ do
-    putStrLn $ "closureSize ("++show (typeRep @a)++") == "++show size++", expected "++show expected
+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
+
+data A = A (Array# Int)
+data MA = MA (MutableArray# RealWorld Int)
+data BA = BA ByteArray#
+data MBA = MBA (MutableByteArray# RealWorld)
+data B = B BCO#
+data APC a = APC a
+
+
 main :: IO ()
 main = do
   assertSize 'a' 2
@@ -28,7 +71,32 @@ main = do
   assertSize (Nothing :: Maybe ()) 2
   assertSize ((1,2) :: (Int,Int)) 3
   assertSize ((1,2,3) :: (Int,Int,Int)) 4
-  assertSize (id :: Int -> Int) 1
-  assertSize (fst :: (Int,Int) -> Int) 1
-  assertSize (pap 1) 2
 
+  -- 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 #)
+
+  A a <- IO $ \s ->
+      case freezeArray# ma 0# 0# s of
+          (# s1, x #) -> (# s1, A x #)
+
+  MBA mba <- IO $ \s ->
+      case newByteArray# 0# s of
+          (# s1, x #) -> (# s1, MBA x #)
+
+  BA ba <- IO $ \s ->
+      case newByteArray# 0# s of
+          (# s1, x #) ->
+              case unsafeFreezeByteArray# x s1 of
+                  (# s2, y #) -> (# s2, BA y #)
+
+  assertSizeUnlifted ma 3
+  assertSizeUnlifted a 3
+  assertSizeUnlifted mba 2
+  assertSizeUnlifted ba 2



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99639cee73f9c4ab6019c8dd7e293d4fd27148c5

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99639cee73f9c4ab6019c8dd7e293d4fd27148c5
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/20190607/3ca49480/attachment-0001.html>