Skip to content

Commit 8430e8e

Browse files
ShimuuarShimuuar
authored
Merge pull request #552 from Shimuuar/inspection-test
Implement fusion test suite
2 parents 8831276 + 241c44e commit 8430e8e

File tree

7 files changed

+517
-44
lines changed

7 files changed

+517
-44
lines changed

‎vector/tests-inspect/Inspect.hs‎

Lines changed: 0 additions & 19 deletions
This file was deleted.

‎vector/tests-inspect/Inspect/Alloc.hs‎

Lines changed: 128 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,50 +1,56 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE ScopedTypeVariables #-}
45
{-# LANGUAGE TypeApplications #-}
56
{- |
67
Here we test that GHC is able to optimize well construction of vector
78
using monadic\/applicative actions. Well is understood as able to
89
generate code which does not allocate except for buffer and some
910
constant overhead.
11+
12+
This is test for GHC optimizer as well and older version fail this
13+
test. Thus we have to disable them. However we expect (or rather
14+
hope) that no regressions will appear in future versions.
1015
-}
1116
module Inspect.Alloc where
1217

1318
import Control.Monad.ST
1419
import Data.Int
20+
import Data.Word
21+
import Data.Char
1522
-- import Data.Monoid
1623
import Data.Functor.Identity
24+
import Foreign.Storable (sizeOf)
1725
import Test.Tasty
1826
import Test.Tasty.HUnit
1927
import System.Mem
2028
import Test.Alloc
29+
import Test.Ignore
2130

2231
import qualified Data.Vector.Unboxed as VU
32+
import Inspect.Fusion
33+
2334

35+
minGHC :: Int -> TestTree -> TestTree
36+
minGHC n test
37+
| ghcVersion >= n = test
38+
| otherwise = ignoreTest test
39+
where
40+
ghcVersion = __GLASGOW_HASKELL__ :: Int
2441

2542
tests :: TestTree
2643
tests = testGroup "allocations"
2744
[ testGroup "traversable"
2845
[ testCase "IO"
2946
$ checkAllocations (linear 8)
3047
$ whnfIO (VU.traverse (\_ -> getAllocationCounter) vector)
31-
32-
#if MIN_VERSION_base(4,17,0)
33-
-- GHC<9.4 doesn't optimize well.
34-
, testCase "ST"
48+
, minGHC 904 $ testCase "ST"
3549
$ checkAllocations (linear 8)
3650
$ (\v -> runST $ VU.traverse (pureST . fromIntegral) v) `whnf` vector
37-
#endif
38-
39-
#if MIN_VERSION_base(4,15,0)
40-
-- GHC<9.0 doesn't optimize this well. And there's no appetite
41-
-- for finding out why. Thus it's disabled for them. We'll still
42-
-- catch regression going forward.
43-
, testCase "Identity"
51+
, minGHC 900 $ testCase "Identity"
4452
$ checkAllocations (linear 8)
4553
$ VU.traverse (\n -> Identity (10*n)) `whnf` vector
46-
#endif
47-
4854
-- NOTE: Naive traversal is lazy and allocated 2 words per element
4955
--
5056
-- , testCase "Const Sum"
@@ -55,20 +61,106 @@ tests = testGroup "allocations"
5561
[ testCase "IO"
5662
$ checkAllocations (linear 8)
5763
$ whnfIO (VU.replicateM size getAllocationCounter)
58-
59-
#if MIN_VERSION_base(4,17,0)
60-
-- GHC<9.4 doesn't optimize well.
61-
, testCase "ST"
64+
, minGHC 904 $ testCase "ST"
6265
$ checkAllocations (linear 8)
6366
$ (\sz -> runST $ VU.generateM sz pureST) `whnf` size
64-
#endif
65-
67+
-- NOTE: No rewrite rule for Identity
68+
--
6669
-- , testCase "Identity"
6770
-- $ checkAllocations (linear 8)
6871
-- $ (\sz -> VU.generateM sz (\n -> Identity (fromIntegral n :: Int64))) `whnf` size
6972
]
73+
, testGroup "Fusion"
74+
[ testGroup "transformers"
75+
[ allocWHNF "test_map" test_map vectorI
76+
, allocWHNF "test_imap" test_imap vectorI
77+
, allocWHNF "test_mapMaybe" test_mapMaybe vectorI
78+
, allocWHNF "test_cons" test_cons vectorI
79+
, allocWHNF "test_snoc" test_snoc vectorI
80+
-- FIXME: GHC does not fuse intermediate vectors in concatMap
81+
--
82+
-- , allocWHNF "test_concatMap_singleton" test_concatMap_singleton vectorI
83+
-- , allocWHNF "test_concatMap_replicate" test_concatMap_replicate vectorI
84+
, allocWHNF "test_appendL" (test_appendL vectorI) vectorI
85+
, allocWHNF "test_appendR" (test_appendR vectorI) vectorI
86+
, allocWHNF "test_indexed" test_indexed vectorI
87+
]
88+
, testGroup "producers"
89+
[ allocWHNF "test_replicate" test_replicate size
90+
, allocWHNF "test_generate" test_generate size
91+
, allocWHNF "test_iterateN" test_iterateN size
92+
, allocWHNF "test_unfoldr" test_unfoldr size
93+
, allocWHNF "test_unfoldrN" test_unfoldrN size
94+
, allocWHNF "test_enumFromN" test_enumFromN size
95+
, allocWHNF "test_enumFromStepN" test_enumFromStepN size
96+
97+
, allocWHNF "test_enumFromTo[Int]" (test_enumFromTo @Int fromIntegral 0) 100000
98+
, allocWHNF "test_enumFromTo[Int64]" (test_enumFromTo @Int64 fromIntegral 0) 100000
99+
, allocWHNF "test_enumFromTo[Int32]" (test_enumFromTo @Int32 fromIntegral 0) 100000
100+
, allocWHNF "test_enumFromTo[Int16]" (test_enumFromTo @Int16 fromIntegral 0) maxBound
101+
, allocWHNF "test_enumFromTo[Word]" (test_enumFromTo @Word fromIntegral 0) 100000
102+
, allocWHNF "test_enumFromTo[Word64]" (test_enumFromTo @Word64 fromIntegral 0) 100000
103+
, allocWHNF "test_enumFromTo[Word32]" (test_enumFromTo @Word32 fromIntegral 0) 100000
104+
, allocWHNF "test_enumFromTo[Word16]" (test_enumFromTo @Word16 fromIntegral 0) maxBound
105+
, allocWHNF "test_enumFromTo[Float]" (test_enumFromTo @Float round 0) 100000
106+
, allocWHNF "test_enumFromTo[Double]" (test_enumFromTo @Double round 0) 100000
107+
, allocWHNF "test_enumFromTo[Char]" (test_enumFromTo @Char ord (chr 32)) (chr 8000)
108+
-- FIXME: We don't have specializations for enumFromThenTo
109+
--
110+
-- , allocWHNF "test_enumFromThenTo" test_enumFromThenTo size
111+
]
112+
, testGroup "consumers"
113+
[ allocWHNF "test_bang" test_bang vectorI
114+
, allocWHNF "test_safeBang" test_safeBang vectorI
115+
, allocWHNF "test_head" test_head vectorI
116+
, allocWHNF "test_last" test_last vectorI
117+
, allocWHNF "test_unsafeHead" test_unsafeHead vectorI
118+
, allocWHNF "test_unsafeLast" test_unsafeLast vectorI
119+
, allocWHNF "test_indexM" test_indexM vectorI
120+
, allocWHNF "test_headM" test_headM vectorI
121+
, allocWHNF "test_lastM" test_lastM vectorI
122+
, allocWHNF "test_unsafeHeadM" test_unsafeHeadM vectorI
123+
, allocWHNF "test_unsafeLastM" test_unsafeLastM vectorI
124+
]
125+
, testGroup "update"
126+
[ allocVecWHNF "test_upd" (test_upd listUpd) vectorI
127+
, allocVecWHNF "test_update_1" (test_update_1 vectorIdx) vectorI
128+
, allocVecWHNF "test_update_2" (test_update_2 vectorI) vectorI
129+
, allocVecWHNF "test_update__1" (test_update__1 vectorI vectorI) vectorI
130+
, minGHC 904 $ allocVecWHNF "test_update__2" (test_update__2 vectorI vectorI) vectorI
131+
, allocVecWHNF "test_update__3" (test_update__3 vectorI vectorI) vectorI
132+
, allocVecWHNF "test_unsafeUpdate_1" (test_unsafeUpdate_1 vectorIdx) vectorI
133+
, allocVecWHNF "test_unsafeUpdate_2" (test_unsafeUpdate_2 vectorI) vectorI
134+
, allocVecWHNF "test_unsafeUpdate__1" (test_unsafeUpdate__1 vectorI vectorI) vectorI
135+
, minGHC 904 $ allocVecWHNF "test_unsafeUpdate__2" (test_unsafeUpdate__2 vectorI vectorI) vectorI
136+
, allocVecWHNF "test_unsafeUpdate__3" (test_unsafeUpdate__3 vectorI vectorI) vectorI
137+
, allocVecWHNF "test_accumulate_1" (test_accumulate_1 vectorIdx) vectorI
138+
, allocVecWHNF "test_accumulate_2" (test_accumulate_2 vectorI) vectorI
139+
, allocVecWHNF "test_accumulate__1" (test_accumulate__1 vectorI vectorI) vectorI
140+
, minGHC 904 $ allocVecWHNF "test_accumulate__2" (test_accumulate__2 vectorI vectorI) vectorI
141+
, allocVecWHNF "test_accumulate__3" (test_accumulate__3 vectorI vectorI) vectorI
142+
, allocVecWHNF "test_unsafeAccumulate_1" (test_unsafeAccumulate_1 vectorIdx) vectorI
143+
, minGHC 904 $ allocVecWHNF "test_unsafeAccumulate_2" (test_unsafeAccumulate_2 vectorI) vectorI
144+
, allocVecWHNF "test_unsafeAccumulate__1" (test_unsafeAccumulate__1 vectorI vectorI) vectorI
145+
, minGHC 904 $ allocVecWHNF "test_unsafeAccumulate__2" (test_unsafeAccumulate__2 vectorI vectorI) vectorI
146+
, allocVecWHNF "test_unsafeAccumulate__3" (test_unsafeAccumulate__3 vectorI vectorI) vectorI
147+
]
148+
, testGroup "other"
149+
[ allocWHNF "test_concat" test_concat listVectorI
150+
]
151+
]
70152
]
71153

154+
allocWHNF :: String -> (a -> b) -> a -> TestTree
155+
{-# INLINE allocWHNF #-}
156+
allocWHNF name f a = testCase name $ checkAllocations constant (f `whnf` a)
157+
158+
allocVecWHNF :: String -> (a -> b) -> a -> TestTree
159+
{-# INLINE allocVecWHNF #-}
160+
allocVecWHNF name f a
161+
= testCase name
162+
$ checkAllocations (linear (sizeOf (undefined::Int))) (f `whnf` a)
163+
72164

73165
pureST :: Int -> ST s Int64
74166
{-# NOINLINE pureST #-}
@@ -87,6 +179,23 @@ vector :: VU.Vector Int64
87179
{-# NOINLINE vector #-}
88180
vector = VU.generate size fromIntegral
89181

182+
vectorI :: VU.Vector Int
183+
{-# NOINLINE vectorI #-}
184+
vectorI = VU.generate size fromIntegral
185+
186+
vectorIdx :: VU.Vector (Int,Int)
187+
{-# NOINLINE vectorIdx #-}
188+
vectorIdx = VU.map (\i -> (i`div`3, i)) vectorI
189+
190+
listVectorI :: [VU.Vector Int]
191+
{-# NOINLINE listVectorI #-}
192+
listVectorI = replicate 8 vectorI
193+
194+
listUpd :: [(Int,Int)]
195+
{-# NOINLINE listUpd #-}
196+
listUpd = [(0,0), (1000,0), (100,0)]
197+
198+
90199
-- | N bytes per element + constant overhead. We also check that bound
91200
-- is tight.
92201
linear :: Int -> Range

0 commit comments

Comments
 (0)