diff options
-rw-r--r-- | libraries/ghc-heap/tests/ClosureSizeUtils.hs | 52 | ||||
-rw-r--r-- | libraries/ghc-heap/tests/all.T | 13 | ||||
-rw-r--r-- | libraries/ghc-heap/tests/closure_size.hs | 56 | ||||
-rw-r--r-- | libraries/ghc-heap/tests/closure_size_noopt.hs | 12 |
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 + |