From 4a8b36be13d70e0d415fdfe09e53eb5474e982e4 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 18 Sep 2025 17:26:49 +0300 Subject: [PATCH 1/2] Implement fusion test suite This reimplements most of test as proposed by @nomeata except for slices. There're some questions on how slices should work. Test suite uses memory allocation in order to check that no intemediate vectors are constructed. It requires that GHC compiles code down to nonallocating loops and it could only reliably happen with -O2 Fixes #229 --- vector/tests-inspect/Inspect.hs | 19 -- vector/tests-inspect/Inspect/Alloc.hs | 111 +++++++- vector/tests-inspect/Inspect/Fusion.hs | 306 ++++++++++++++++++++++ vector/tests-inspect/Test/InspectExtra.hs | 26 ++ vector/tests-inspect/main.hs | 6 +- vector/vector.cabal | 10 +- 6 files changed, 453 insertions(+), 25 deletions(-) delete mode 100644 vector/tests-inspect/Inspect.hs create mode 100644 vector/tests-inspect/Inspect/Fusion.hs create mode 100644 vector/tests-inspect/Test/InspectExtra.hs diff --git a/vector/tests-inspect/Inspect.hs b/vector/tests-inspect/Inspect.hs deleted file mode 100644 index 32cd8cfa..00000000 --- a/vector/tests-inspect/Inspect.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin=Test.Tasty.Inspection.Plugin #-} -{-# OPTIONS_GHC -dsuppress-all #-} -{-# OPTIONS_GHC -dno-suppress-type-signatures #-} --- | Most basic inspection tests -module Inspect where - -import Test.Tasty -import Test.Tasty.Inspection -import qualified Data.Vector as V - -simple_fusion :: Int -> Int -simple_fusion n = V.sum $ V.generate n id - - -tests :: TestTree -tests = testGroup "inspection" - [ $(inspectObligations [(`hasNoType` ''V.Vector), hasNoTypeClasses] 'simple_fusion) - ] diff --git a/vector/tests-inspect/Inspect/Alloc.hs b/vector/tests-inspect/Inspect/Alloc.hs index be399e5f..cc3842c4 100644 --- a/vector/tests-inspect/Inspect/Alloc.hs +++ b/vector/tests-inspect/Inspect/Alloc.hs @@ -12,15 +12,18 @@ module Inspect.Alloc where import Control.Monad.ST import Data.Int +import Data.Word +import Data.Char -- import Data.Monoid import Data.Functor.Identity +import Foreign.Storable (sizeOf) import Test.Tasty import Test.Tasty.HUnit import System.Mem import Test.Alloc import qualified Data.Vector.Unboxed as VU - +import Inspect.Fusion tests :: TestTree tests = testGroup "allocations" @@ -67,8 +70,97 @@ tests = testGroup "allocations" -- $ checkAllocations (linear 8) -- $ (\sz -> VU.generateM sz (\n -> Identity (fromIntegral n :: Int64))) `whnf` size ] + , testGroup "Fusion" + [ testGroup "transformers" + [ allocWHNF "test_map" test_map vectorI + , allocWHNF "test_imap" test_imap vectorI + , allocWHNF "test_mapMaybe" test_mapMaybe vectorI + , allocWHNF "test_cons" test_cons vectorI + , allocWHNF "test_snoc" test_snoc vectorI + -- FIXME: GHC does not fuse intermediate vectors in concatMap + -- + -- , allocWHNF "test_concatMap_singleton" test_concatMap_singleton vectorI + -- , allocWHNF "test_concatMap_replicate" test_concatMap_replicate vectorI + , allocWHNF "test_appendL" (test_appendL vectorI) vectorI + , allocWHNF "test_appendR" (test_appendR vectorI) vectorI + , allocWHNF "test_indexed" test_indexed vectorI + ] + , testGroup "producers" + [ allocWHNF "test_replicate" test_replicate size + , allocWHNF "test_generate" test_generate size + , allocWHNF "test_iterateN" test_iterateN size + , allocWHNF "test_unfoldr" test_unfoldr size + , allocWHNF "test_unfoldrN" test_unfoldrN size + , allocWHNF "test_enumFromN" test_enumFromN size + , allocWHNF "test_enumFromStepN" test_enumFromStepN size + + , allocWHNF "test_enumFromTo[Int]" (test_enumFromTo @Int fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int64]" (test_enumFromTo @Int64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int32]" (test_enumFromTo @Int32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int16]" (test_enumFromTo @Int16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Word]" (test_enumFromTo @Word fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word64]" (test_enumFromTo @Word64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word32]" (test_enumFromTo @Word32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word16]" (test_enumFromTo @Word16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Float]" (test_enumFromTo @Float round 0) 100000 + , allocWHNF "test_enumFromTo[Double]" (test_enumFromTo @Double round 0) 100000 + , allocWHNF "test_enumFromTo[Char]" (test_enumFromTo @Char ord (chr 32)) (chr 8000) + -- FIXME: We don't have specializations for enumFromThenTo + -- + -- , allocWHNF "test_enumFromThenTo" test_enumFromThenTo size + ] + , testGroup "consumers" + [ allocWHNF "test_bang" test_bang vectorI + , allocWHNF "test_safeBang" test_safeBang vectorI + , allocWHNF "test_head" test_head vectorI + , allocWHNF "test_last" test_last vectorI + , allocWHNF "test_unsafeHead" test_unsafeHead vectorI + , allocWHNF "test_unsafeLast" test_unsafeLast vectorI + , allocWHNF "test_indexM" test_indexM vectorI + , allocWHNF "test_headM" test_headM vectorI + , allocWHNF "test_lastM" test_lastM vectorI + , allocWHNF "test_unsafeHeadM" test_unsafeHeadM vectorI + , allocWHNF "test_unsafeLastM" test_unsafeLastM vectorI + ] + , testGroup "update" + [ allocVecWHNF "test_upd" (test_upd listUpd) vectorI + , allocVecWHNF "test_update_1" (test_update_1 vectorIdx) vectorI + , allocVecWHNF "test_update_2" (test_update_2 vectorI) vectorI + , allocVecWHNF "test_update__1" (test_update__1 vectorI vectorI) vectorI + , allocVecWHNF "test_update__2" (test_update__2 vectorI vectorI) vectorI + , allocVecWHNF "test_update__3" (test_update__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate_1" (test_unsafeUpdate_1 vectorIdx) vectorI + , allocVecWHNF "test_unsafeUpdate_2" (test_unsafeUpdate_2 vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__1" (test_unsafeUpdate__1 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__2" (test_unsafeUpdate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__3" (test_unsafeUpdate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate_1" (test_accumulate_1 vectorIdx) vectorI + , allocVecWHNF "test_accumulate_2" (test_accumulate_2 vectorI) vectorI + , allocVecWHNF "test_accumulate__1" (test_accumulate__1 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate__2" (test_accumulate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate__3" (test_accumulate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate_1" (test_unsafeAccumulate_1 vectorIdx) vectorI + , allocVecWHNF "test_unsafeAccumulate_2" (test_unsafeAccumulate_2 vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate__1" (test_unsafeAccumulate__1 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate__2" (test_unsafeAccumulate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate__3" (test_unsafeAccumulate__3 vectorI vectorI) vectorI + ] + , testGroup "other" + [ allocWHNF "test_concat" test_concat listVectorI + ] + ] ] +allocWHNF :: String -> (a -> b) -> a -> TestTree +{-# INLINE allocWHNF #-} +allocWHNF name f a = testCase name $ checkAllocations constant (f `whnf` a) + +allocVecWHNF :: String -> (a -> b) -> a -> TestTree +{-# INLINE allocVecWHNF #-} +allocVecWHNF name f a + = testCase name + $ checkAllocations (linear (sizeOf (undefined::Int))) (f `whnf` a) + pureST :: Int -> ST s Int64 {-# NOINLINE pureST #-} @@ -87,6 +179,23 @@ vector :: VU.Vector Int64 {-# NOINLINE vector #-} vector = VU.generate size fromIntegral +vectorI :: VU.Vector Int +{-# NOINLINE vectorI #-} +vectorI = VU.generate size fromIntegral + +vectorIdx :: VU.Vector (Int,Int) +{-# NOINLINE vectorIdx #-} +vectorIdx = VU.map (\i -> (i`div`3, i)) vectorI + +listVectorI :: [VU.Vector Int] +{-# NOINLINE listVectorI #-} +listVectorI = replicate 8 vectorI + +listUpd :: [(Int,Int)] +{-# NOINLINE listUpd #-} +listUpd = [(0,0), (1000,0), (100,0)] + + -- | N bytes per element + constant overhead. We also check that bound -- is tight. linear :: Int -> Range diff --git a/vector/tests-inspect/Inspect/Fusion.hs b/vector/tests-inspect/Inspect/Fusion.hs new file mode 100644 index 00000000..2dd32428 --- /dev/null +++ b/vector/tests-inspect/Inspect/Fusion.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -dsuppress-all #-} +{-# OPTIONS_GHC -dno-suppress-type-signatures #-} +-- | +module Inspect.Fusion where + +import Test.Tasty +-- import Test.Tasty.Inspection +import qualified Data.Vector.Unboxed as VU +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Generic as VG +import Data.Vector.Fusion.Util (Box) + +import Test.InspectExtra + +-- NOTE: [Fusion tests] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- In this module we define functions to be tested. All test functions +-- are constructed in the that there should be no vector allocations +-- if fusion happens. There are two tests for each function: +-- +-- 1. Inspection tests which tests that GHC successfully eliminate +-- stream data types. They also allow to inspect core of offending +-- function easily using coreOf property. +-- +-- 2. Allocation tests which measure memory allocation during +-- function execution. It's difficult to check that fusion happens +-- by inspecting core so we fall back to checking function +-- behavior. This methods also requires that GHC is able to +-- compile function to nonallocating loops, but that's desirable +-- property as well. + +goodConsumer + :: (VG.Vector v a, Num a) + => (v a -> b) -> (v a -> b) +{-# INLINE goodConsumer #-} +goodConsumer f = f . VG.map (+1) + +goodTransformer + :: (VG.Vector v a, VG.Vector v b, Num a, Num b) + => (v a -> v b) -> (v a -> b) +{-# INLINE goodTransformer #-} +goodTransformer f = VG.sum . f . VG.map (+1) + +goodProducer + :: (VG.Vector v a, Num a) + => (b -> v a) -> (b -> a) +{-# INLINE goodProducer #-} +goodProducer f = VG.sum . f + + + +---------------------------------------------------------------- +-- Functions transforming vectors +---------------------------------------------------------------- + +test_map :: Vector Int -> Int +test_map = goodTransformer (VU.map (*2)) + +test_imap :: Vector Int -> Int +test_imap = goodTransformer (VU.imap (+)) + +test_mapMaybe :: Vector Int -> Int +test_mapMaybe = goodTransformer (VU.mapMaybe (\x -> if odd x then Just x else Nothing)) + +test_cons :: Vector Int -> Int +test_cons = goodTransformer (VU.cons 123) + +test_snoc :: Vector Int -> Int +test_snoc = goodTransformer (`VU.snoc` 123) + +test_concatMap_singleton :: Vector Int -> Int +test_concatMap_singleton = goodTransformer (VU.concatMap VU.singleton) + +test_concatMap_replicate :: Vector Int -> Int +test_concatMap_replicate = goodTransformer (VU.concatMap (VU.replicate 10)) + +test_appendR, test_appendL :: Vector Int -> Vector Int -> Int +test_appendR v = goodTransformer (v VU.++) +test_appendL v = goodTransformer (VU.++ v) + +test_indexed :: Vector Int -> Int +test_indexed = goodTransformer (VU.map (\(i,j) -> i+j) . VU.indexed) + + +---------------------------------------------------------------- +-- Update/accumulate +---------------------------------------------------------------- + +test_upd :: [(Int,Int)] -> Vector Int -> Int +test_upd xs = goodTransformer (VU.// xs) + +test_update_1 :: Vector (Int,Int) -> Vector Int -> Int +test_update_1 xs + = goodTransformer (\vec -> VU.update vec xs) + +test_update_2 :: Vector Int -> Vector Int -> Int +test_update_2 vec + = goodTransformer (VU.update vec . VU.map (\i -> (i`div`3, i))) + +test_update__1, test_update__2, test_update__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_update__1 y z = goodTransformer (\x -> VU.update_ x y z) +test_update__2 x z = goodTransformer (\y -> VU.update_ x (VU.map (`div` 3) y) z) +test_update__3 x y = goodTransformer (\z -> VU.update_ x y z) + + +test_unsafeUpdate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_unsafeUpdate_1 xs + = goodTransformer (\vec -> VU.unsafeUpdate vec xs) + +test_unsafeUpdate_2 :: Vector Int -> Vector Int -> Int +test_unsafeUpdate_2 vec + = goodTransformer (VU.unsafeUpdate vec . VU.map (\i -> (i`div`3, i))) + +test_unsafeUpdate__1, test_unsafeUpdate__2, test_unsafeUpdate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_unsafeUpdate__1 y z = goodTransformer (\x -> VU.unsafeUpdate_ x y z) +test_unsafeUpdate__2 x z = goodTransformer (\y -> VU.unsafeUpdate_ x (VU.map (`div` 3) y) z) +test_unsafeUpdate__3 x y = goodTransformer (\z -> VU.unsafeUpdate_ x y z) + + +test_accumulate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_accumulate_1 xs + = goodTransformer (\vec -> VU.accumulate (+) vec xs) + +test_accumulate_2 :: Vector Int -> Vector Int -> Int +test_accumulate_2 vec + = goodTransformer (VU.accumulate (+) vec . VU.map (\i -> (i`div`3, i))) + +test_accumulate__1, test_accumulate__2, test_accumulate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_accumulate__1 y z = goodTransformer (\x -> VU.accumulate_ (+) x y z) +test_accumulate__2 x z = goodTransformer (\y -> VU.accumulate_ (+) x (VU.map (`div` 3) y) z) +test_accumulate__3 x y = goodTransformer (\z -> VU.accumulate_ (+) x y z) + + +test_unsafeAccumulate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_unsafeAccumulate_1 xs + = goodTransformer (\vec -> VU.unsafeAccumulate (+) vec xs) + +test_unsafeAccumulate_2 :: Vector Int -> Vector Int -> Int +test_unsafeAccumulate_2 vec + = goodTransformer (VU.unsafeAccumulate (+) vec . VU.map (\i -> (i`div`3, i))) + +test_unsafeAccumulate__1, test_unsafeAccumulate__2, test_unsafeAccumulate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_unsafeAccumulate__1 y z = goodTransformer (\x -> VU.unsafeAccumulate_ (+) x y z) +test_unsafeAccumulate__2 x z = goodTransformer (\y -> VU.unsafeAccumulate_ (+) x (VU.map (`div` 3) y) z) +test_unsafeAccumulate__3 x y = goodTransformer (\z -> VU.unsafeAccumulate_ (+) x y z) + + +---------------------------------------------------------------- +-- Function creating vectors +---------------------------------------------------------------- + +test_replicate :: Int -> Double +test_replicate = goodProducer (\n -> VU.replicate n 12.0) + +test_generate :: Int -> Int +test_generate = goodProducer (\n -> VU.generate n id) + +test_iterateN :: Int -> Int +test_iterateN = goodProducer (\n -> VU.iterateN n (+1) 0) + +test_unfoldr :: Int -> Int +test_unfoldr = goodProducer (\n -> VU.unfoldr (\i -> if i > n then Nothing else Just (i,i+1)) 0) + +test_unfoldrN :: Int -> Int +test_unfoldrN = goodProducer (\n -> VU.unfoldrN n (\i -> Just (i,i+1)) 0) + +test_enumFromN, test_enumFromStepN :: Int -> Double +test_enumFromN = goodProducer (\n -> VU.enumFromN 123 n) +test_enumFromStepN = goodProducer (\n -> VU.enumFromStepN 123 2 n) + + +-- NOTE: [enumFromTo] +-- ~~~~~~~~~~~~~~~~~ +-- +-- both enumFromTo and enumFromThenTo are wrapping methods of Enum +-- type class and thus has to create list and allocate. However we +-- have extensive set of rewrite rules which produce specializations +-- for base types. +-- +-- For this reason we need to write test for all specializations + +test_enumFromTo :: (Enum a, VU.Unbox a) => (a -> Int) -> a -> a -> Int +{-# INLINE test_enumFromTo #-} +test_enumFromTo fun a + = goodProducer (VU.map fun . VU.enumFromTo a) + +test_enumFromThenTo :: (Enum a, VU.Unbox a) => (a -> Int) -> a -> a -> a -> Int +test_enumFromThenTo fun a b + = goodProducer (VU.map fun . VU.enumFromThenTo a b) + + + +---------------------------------------------------------------- +-- Function consuming vectors +---------------------------------------------------------------- + +test_bang,test_unsafeIndex :: Vector Int -> Int +test_bang = goodConsumer (VU.! 42000) +test_unsafeIndex = goodConsumer (`VU.unsafeIndex` 42) + +test_safeBang :: Vector Int -> Maybe Int +test_safeBang = goodConsumer (VU.!? 42000) + +test_head, test_last, test_unsafeHead, test_unsafeLast :: Vector Int -> Int +test_head = goodConsumer VU.head +test_last = goodConsumer VU.last +test_unsafeHead = goodConsumer VU.unsafeHead +test_unsafeLast = goodConsumer VU.unsafeLast + +test_headM, test_lastM, test_unsafeHeadM, test_unsafeLastM, test_indexM :: Vector Int -> Box Int +test_indexM = goodConsumer (`VU.indexM` 43) +test_headM = goodConsumer VU.headM +test_lastM = goodConsumer VU.lastM +test_unsafeHeadM = goodConsumer VU.unsafeHeadM +test_unsafeLastM = goodConsumer VU.unsafeLastM + +---------------------------------------------------------------- +-- Functions involving lists +---------------------------------------------------------------- + +test_concat :: [Vector Int] -> Int +test_concat = VU.sum . VU.map (+1) . VU.concat + + + +---------------------------------------------------------------- +-- Inspection tests +-- +-- They have to be defined in this module +---------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "Fusion" + [ testGroup "transformers" + [ $(inspectFusion 'test_map) + , $(inspectFusion 'test_imap) + , $(inspectFusion 'test_mapMaybe) + , $(inspectFusion 'test_cons) + , $(inspectFusion 'test_snoc) + , $(inspectFusion 'test_concatMap_singleton) + , $(inspectFusion 'test_concatMap_replicate) + , $(inspectFusion 'test_appendL) + , $(inspectFusion 'test_appendR) + , $(inspectFusion 'test_indexed) + ] + , testGroup "updates" + [ $(inspectFusion 'test_upd) + , $(inspectFusion 'test_update_1) + , $(inspectFusion 'test_update_2) + , $(inspectFusion 'test_update__1) + , $(inspectFusion 'test_update__2) + , $(inspectFusion 'test_update__3) + , $(inspectFusion 'test_unsafeUpdate_1) + , $(inspectFusion 'test_unsafeUpdate_2) + , $(inspectFusion 'test_unsafeUpdate__1) + , $(inspectFusion 'test_unsafeUpdate__2) + , $(inspectFusion 'test_unsafeUpdate__3) + , $(inspectFusion 'test_accumulate_1) + , $(inspectFusion 'test_accumulate_2) + , $(inspectFusion 'test_accumulate__1) + , $(inspectFusion 'test_accumulate__2) + , $(inspectFusion 'test_accumulate__3) + , $(inspectFusion 'test_unsafeAccumulate_1) + , $(inspectFusion 'test_unsafeAccumulate_2) + , $(inspectFusion 'test_unsafeAccumulate__1) + , $(inspectFusion 'test_unsafeAccumulate__2) + , $(inspectFusion 'test_unsafeAccumulate__3) + ] + , testGroup "producers" + [ $(inspectFusion 'test_replicate) + , $(inspectFusion 'test_generate) + , $(inspectFusion 'test_iterateN) + , $(inspectFusion 'test_unfoldr) + , $(inspectFusion 'test_unfoldrN) + , $(inspectFusion 'test_enumFromN) + , $(inspectFusion 'test_enumFromStepN) + , $(inspectClassyFusion 'test_enumFromTo) + , $(inspectClassyFusion 'test_enumFromThenTo) + ] + , testGroup "consumers" + [ $(inspectFusion 'test_bang) + , $(inspectFusion 'test_safeBang) + , $(inspectFusion 'test_head) + , $(inspectFusion 'test_last) + , $(inspectFusion 'test_unsafeHead) + , $(inspectFusion 'test_unsafeLast) + , $(inspectFusion 'test_indexM) + , $(inspectFusion 'test_headM) + , $(inspectFusion 'test_lastM) + , $(inspectFusion 'test_unsafeHeadM) + , $(inspectFusion 'test_unsafeLastM) + ] + , testGroup "other" + [ $(inspectFusion 'test_concat) + ] + ] diff --git a/vector/tests-inspect/Test/InspectExtra.hs b/vector/tests-inspect/Test/InspectExtra.hs new file mode 100644 index 00000000..ce73e9a1 --- /dev/null +++ b/vector/tests-inspect/Test/InspectExtra.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Helpers for fusion tests +module Test.InspectExtra + ( noStream + , inspectFusion + , inspectClassyFusion + , module Test.Tasty.Inspection + ) where + +import Language.Haskell.TH (Name,Q,Exp) +import Test.Tasty.Inspection + +import qualified Data.Stream.Monadic as S + + +noStream :: Name -> Obligation +noStream = (`doesNotUseAnyOf` ['S.Yield, 'S.Skip, 'S.Done]) + +inspectFusion :: Name -> Q Exp +inspectFusion = inspectObligations [ noStream + , hasNoTypeClasses + ] + +inspectClassyFusion :: Name -> Q Exp +inspectClassyFusion = inspectObligations [ noStream ] diff --git a/vector/tests-inspect/main.hs b/vector/tests-inspect/main.hs index 0a67eb9f..12d554af 100644 --- a/vector/tests-inspect/main.hs +++ b/vector/tests-inspect/main.hs @@ -1,13 +1,13 @@ module Main (main) where -import qualified Inspect import qualified Inspect.Alloc import qualified Inspect.DerivingVia +import qualified Inspect.Fusion import Test.Tasty (defaultMain,testGroup) main :: IO () main = defaultMain $ testGroup "tests" - [ Inspect.tests - , Inspect.DerivingVia.tests + [ Inspect.DerivingVia.tests , Inspect.Alloc.tests + , Inspect.Fusion.tests ] diff --git a/vector/vector.cabal b/vector/vector.cabal index 479b35fe..479c2e2e 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -247,19 +247,25 @@ test-suite vector-doctest test-suite vector-inspection import: flag-Wall + -- We need to compile with -O2 since we're checking that function on vectors are + -- compiled down to nonallocating loops. GHC is not good at this with only -O1 + Ghc-Options: -O2 type: exitcode-stdio-1.0 hs-source-dirs: tests-inspect main-is: main.hs default-language: Haskell2010 - Other-modules: Inspect - Inspect.Alloc + Other-modules: Inspect.Alloc + Inspect.Fusion Inspect.DerivingVia Inspect.DerivingVia.OtherFoo Test.Alloc + Test.InspectExtra build-depends: base -any + , template-haskell , primitive >= 0.6.4.0 && < 0.10 , vector -any + , vector-stream -any , tasty , tasty-hunit , tasty-inspection-testing >= 0.1 From 241c44e6308a70f571896c7906a77b1851e319f2 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 25 Sep 2025 17:10:39 +0300 Subject: [PATCH 2/2] Rework conditional compilation Let keep test for older GHC but ignore their failures --- vector/tests-inspect/Inspect/Alloc.hs | 136 +++++++++++++------------- vector/tests-inspect/Test/Ignore.hs | 44 +++++++++ vector/vector.cabal | 3 +- 3 files changed, 114 insertions(+), 69 deletions(-) create mode 100644 vector/tests-inspect/Test/Ignore.hs diff --git a/vector/tests-inspect/Inspect/Alloc.hs b/vector/tests-inspect/Inspect/Alloc.hs index cc3842c4..5627874b 100644 --- a/vector/tests-inspect/Inspect/Alloc.hs +++ b/vector/tests-inspect/Inspect/Alloc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {- | @@ -7,6 +8,10 @@ Here we test that GHC is able to optimize well construction of vector using monadic\/applicative actions. Well is understood as able to generate code which does not allocate except for buffer and some constant overhead. + +This is test for GHC optimizer as well and older version fail this +test. Thus we have to disable them. However we expect (or rather +hope) that no regressions will appear in future versions. -} module Inspect.Alloc where @@ -21,33 +26,31 @@ import Test.Tasty import Test.Tasty.HUnit import System.Mem import Test.Alloc +import Test.Ignore import qualified Data.Vector.Unboxed as VU import Inspect.Fusion + +minGHC :: Int -> TestTree -> TestTree +minGHC n test + | ghcVersion >= n = test + | otherwise = ignoreTest test + where + ghcVersion = __GLASGOW_HASKELL__ :: Int + tests :: TestTree tests = testGroup "allocations" [ testGroup "traversable" [ testCase "IO" $ checkAllocations (linear 8) $ whnfIO (VU.traverse (\_ -> getAllocationCounter) vector) - -#if MIN_VERSION_base(4,17,0) - -- GHC<9.4 doesn't optimize well. - , testCase "ST" + , minGHC 904 $ testCase "ST" $ checkAllocations (linear 8) $ (\v -> runST $ VU.traverse (pureST . fromIntegral) v) `whnf` vector -#endif - -#if MIN_VERSION_base(4,15,0) - -- GHC<9.0 doesn't optimize this well. And there's no appetite - -- for finding out why. Thus it's disabled for them. We'll still - -- catch regression going forward. - , testCase "Identity" + , minGHC 900 $ testCase "Identity" $ checkAllocations (linear 8) $ VU.traverse (\n -> Identity (10*n)) `whnf` vector -#endif - -- NOTE: Naive traversal is lazy and allocated 2 words per element -- -- , testCase "Const Sum" @@ -58,14 +61,11 @@ tests = testGroup "allocations" [ testCase "IO" $ checkAllocations (linear 8) $ whnfIO (VU.replicateM size getAllocationCounter) - -#if MIN_VERSION_base(4,17,0) - -- GHC<9.4 doesn't optimize well. - , testCase "ST" + , minGHC 904 $ testCase "ST" $ checkAllocations (linear 8) $ (\sz -> runST $ VU.generateM sz pureST) `whnf` size -#endif - + -- NOTE: No rewrite rule for Identity + -- -- , testCase "Identity" -- $ checkAllocations (linear 8) -- $ (\sz -> VU.generateM sz (\n -> Identity (fromIntegral n :: Int64))) `whnf` size @@ -86,63 +86,63 @@ tests = testGroup "allocations" , allocWHNF "test_indexed" test_indexed vectorI ] , testGroup "producers" - [ allocWHNF "test_replicate" test_replicate size - , allocWHNF "test_generate" test_generate size - , allocWHNF "test_iterateN" test_iterateN size - , allocWHNF "test_unfoldr" test_unfoldr size - , allocWHNF "test_unfoldrN" test_unfoldrN size - , allocWHNF "test_enumFromN" test_enumFromN size - , allocWHNF "test_enumFromStepN" test_enumFromStepN size - - , allocWHNF "test_enumFromTo[Int]" (test_enumFromTo @Int fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Int64]" (test_enumFromTo @Int64 fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Int32]" (test_enumFromTo @Int32 fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Int16]" (test_enumFromTo @Int16 fromIntegral 0) maxBound - , allocWHNF "test_enumFromTo[Word]" (test_enumFromTo @Word fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Word64]" (test_enumFromTo @Word64 fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Word32]" (test_enumFromTo @Word32 fromIntegral 0) 100000 - , allocWHNF "test_enumFromTo[Word16]" (test_enumFromTo @Word16 fromIntegral 0) maxBound - , allocWHNF "test_enumFromTo[Float]" (test_enumFromTo @Float round 0) 100000 - , allocWHNF "test_enumFromTo[Double]" (test_enumFromTo @Double round 0) 100000 - , allocWHNF "test_enumFromTo[Char]" (test_enumFromTo @Char ord (chr 32)) (chr 8000) + [ allocWHNF "test_replicate" test_replicate size + , allocWHNF "test_generate" test_generate size + , allocWHNF "test_iterateN" test_iterateN size + , allocWHNF "test_unfoldr" test_unfoldr size + , allocWHNF "test_unfoldrN" test_unfoldrN size + , allocWHNF "test_enumFromN" test_enumFromN size + , allocWHNF "test_enumFromStepN" test_enumFromStepN size + + , allocWHNF "test_enumFromTo[Int]" (test_enumFromTo @Int fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int64]" (test_enumFromTo @Int64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int32]" (test_enumFromTo @Int32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int16]" (test_enumFromTo @Int16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Word]" (test_enumFromTo @Word fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word64]" (test_enumFromTo @Word64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word32]" (test_enumFromTo @Word32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word16]" (test_enumFromTo @Word16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Float]" (test_enumFromTo @Float round 0) 100000 + , allocWHNF "test_enumFromTo[Double]" (test_enumFromTo @Double round 0) 100000 + , allocWHNF "test_enumFromTo[Char]" (test_enumFromTo @Char ord (chr 32)) (chr 8000) -- FIXME: We don't have specializations for enumFromThenTo -- -- , allocWHNF "test_enumFromThenTo" test_enumFromThenTo size ] , testGroup "consumers" - [ allocWHNF "test_bang" test_bang vectorI - , allocWHNF "test_safeBang" test_safeBang vectorI - , allocWHNF "test_head" test_head vectorI - , allocWHNF "test_last" test_last vectorI - , allocWHNF "test_unsafeHead" test_unsafeHead vectorI - , allocWHNF "test_unsafeLast" test_unsafeLast vectorI - , allocWHNF "test_indexM" test_indexM vectorI - , allocWHNF "test_headM" test_headM vectorI - , allocWHNF "test_lastM" test_lastM vectorI - , allocWHNF "test_unsafeHeadM" test_unsafeHeadM vectorI - , allocWHNF "test_unsafeLastM" test_unsafeLastM vectorI + [ allocWHNF "test_bang" test_bang vectorI + , allocWHNF "test_safeBang" test_safeBang vectorI + , allocWHNF "test_head" test_head vectorI + , allocWHNF "test_last" test_last vectorI + , allocWHNF "test_unsafeHead" test_unsafeHead vectorI + , allocWHNF "test_unsafeLast" test_unsafeLast vectorI + , allocWHNF "test_indexM" test_indexM vectorI + , allocWHNF "test_headM" test_headM vectorI + , allocWHNF "test_lastM" test_lastM vectorI + , allocWHNF "test_unsafeHeadM" test_unsafeHeadM vectorI + , allocWHNF "test_unsafeLastM" test_unsafeLastM vectorI ] , testGroup "update" - [ allocVecWHNF "test_upd" (test_upd listUpd) vectorI - , allocVecWHNF "test_update_1" (test_update_1 vectorIdx) vectorI - , allocVecWHNF "test_update_2" (test_update_2 vectorI) vectorI - , allocVecWHNF "test_update__1" (test_update__1 vectorI vectorI) vectorI - , allocVecWHNF "test_update__2" (test_update__2 vectorI vectorI) vectorI - , allocVecWHNF "test_update__3" (test_update__3 vectorI vectorI) vectorI - , allocVecWHNF "test_unsafeUpdate_1" (test_unsafeUpdate_1 vectorIdx) vectorI - , allocVecWHNF "test_unsafeUpdate_2" (test_unsafeUpdate_2 vectorI) vectorI - , allocVecWHNF "test_unsafeUpdate__1" (test_unsafeUpdate__1 vectorI vectorI) vectorI - , allocVecWHNF "test_unsafeUpdate__2" (test_unsafeUpdate__2 vectorI vectorI) vectorI - , allocVecWHNF "test_unsafeUpdate__3" (test_unsafeUpdate__3 vectorI vectorI) vectorI - , allocVecWHNF "test_accumulate_1" (test_accumulate_1 vectorIdx) vectorI - , allocVecWHNF "test_accumulate_2" (test_accumulate_2 vectorI) vectorI - , allocVecWHNF "test_accumulate__1" (test_accumulate__1 vectorI vectorI) vectorI - , allocVecWHNF "test_accumulate__2" (test_accumulate__2 vectorI vectorI) vectorI - , allocVecWHNF "test_accumulate__3" (test_accumulate__3 vectorI vectorI) vectorI - , allocVecWHNF "test_unsafeAccumulate_1" (test_unsafeAccumulate_1 vectorIdx) vectorI - , allocVecWHNF "test_unsafeAccumulate_2" (test_unsafeAccumulate_2 vectorI) vectorI + [ allocVecWHNF "test_upd" (test_upd listUpd) vectorI + , allocVecWHNF "test_update_1" (test_update_1 vectorIdx) vectorI + , allocVecWHNF "test_update_2" (test_update_2 vectorI) vectorI + , allocVecWHNF "test_update__1" (test_update__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_update__2" (test_update__2 vectorI vectorI) vectorI + , allocVecWHNF "test_update__3" (test_update__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate_1" (test_unsafeUpdate_1 vectorIdx) vectorI + , allocVecWHNF "test_unsafeUpdate_2" (test_unsafeUpdate_2 vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__1" (test_unsafeUpdate__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeUpdate__2" (test_unsafeUpdate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__3" (test_unsafeUpdate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate_1" (test_accumulate_1 vectorIdx) vectorI + , allocVecWHNF "test_accumulate_2" (test_accumulate_2 vectorI) vectorI + , allocVecWHNF "test_accumulate__1" (test_accumulate__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_accumulate__2" (test_accumulate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate__3" (test_accumulate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate_1" (test_unsafeAccumulate_1 vectorIdx) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeAccumulate_2" (test_unsafeAccumulate_2 vectorI) vectorI , allocVecWHNF "test_unsafeAccumulate__1" (test_unsafeAccumulate__1 vectorI vectorI) vectorI - , allocVecWHNF "test_unsafeAccumulate__2" (test_unsafeAccumulate__2 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeAccumulate__2" (test_unsafeAccumulate__2 vectorI vectorI) vectorI , allocVecWHNF "test_unsafeAccumulate__3" (test_unsafeAccumulate__3 vectorI vectorI) vectorI ] , testGroup "other" diff --git a/vector/tests-inspect/Test/Ignore.hs b/vector/tests-inspect/Test/Ignore.hs new file mode 100644 index 00000000..936711f5 --- /dev/null +++ b/vector/tests-inspect/Test/Ignore.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +module Test.Ignore + ( modifyTests + , ignoreTest + ) where + +import Data.Coerce +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.Providers + + +data WithTest where + WithTest :: IsTest t => t -> WithTest + +modifyTests + :: (forall a. (IsTest a) => a -> WithTest) + -> TestTree -> TestTree +modifyTests fun = go where + go = \case + SingleTest nm t -> case fun t of + WithTest t' -> SingleTest nm t' + TestGroup nm ts -> TestGroup nm (go <$> ts) + PlusTestOptions plus tree -> PlusTestOptions plus (go tree) + WithResource spec f -> WithResource spec (go . f) + AskOptions f -> AskOptions (go . f) + After d p t -> After d p (go t) + + +ignoreTest :: TestTree -> TestTree +ignoreTest = modifyTests (\t -> WithTest $ Ignored t) + +newtype Ignored t = Ignored t + +instance IsTest t => IsTest (Ignored t) where + run ops (Ignored t) f = do + _ <- run ops t f + pure $ (testPassed ""){ resultShortDescription = "IGNORED" } + testOptions = coerce (testOptions @t) diff --git a/vector/vector.cabal b/vector/vector.cabal index 479c2e2e..e32230cc 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -260,13 +260,14 @@ test-suite vector-inspection Inspect.DerivingVia.OtherFoo Test.Alloc Test.InspectExtra + Test.Ignore build-depends: base -any , template-haskell , primitive >= 0.6.4.0 && < 0.10 , vector -any , vector-stream -any - , tasty + , tasty >=1.2 , tasty-hunit , tasty-inspection-testing >= 0.1