diff --git a/vector-stream/src/Data/Stream/Monadic.hs b/vector-stream/src/Data/Stream/Monadic.hs index 33867919..0d08a76e 100644 --- a/vector-stream/src/Data/Stream/Monadic.hs +++ b/vector-stream/src/Data/Stream/Monadic.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Stream.Monadic -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -95,22 +96,16 @@ import Prelude , RealFrac, return, pure, otherwise, seq, error, not, id, show, const, fmap , (==), (<), (<=), (>), (+), (-), (/), ($), (.), (=<<), (>>=) ) -import Data.Int ( Int8, Int16, Int32 ) +import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Word ( Word8, Word16, Word32, Word64 ) import GHC.Stack (HasCallStack) import GHC.Types ( SPEC(..) ) -#include "MachDeps.h" - #define INLINE_FUSED INLINE [1] #define INLINE_INNER INLINE [0] -#if WORD_SIZE_IN_BITS > 32 -import Data.Int ( Int64 ) -#endif - -- | Box monad data Box a = Box { unBox :: a } @@ -1371,165 +1366,22 @@ enumFromTo :: (Enum a, Monad m) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo #-} enumFromTo x y = fromList [x .. y] --- NOTE: We use (x+1) instead of (succ x) below because the latter checks for --- overflow which can't happen here. - --- FIXME: add "too large" test for Int -enumFromTo_small :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_small #-} -enumFromTo_small x y = x `seq` y `seq` Stream step (Just x) - where - {-# INLINE_INNER step #-} - step Nothing = return $ Done - step (Just z) | z == y = return $ Yield z Nothing - | z < y = return $ Yield z (Just (z+1)) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int8 -> Int8 -> Stream m Int8 - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int16 -> Int16 -> Stream m Int16 - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word8 -> Word8 -> Stream m Word8 - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word16 -> Word16 -> Stream m Word16 #-} - - -#if WORD_SIZE_IN_BITS > 32 - -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int32 -> Int32 -> Stream m Int32 - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word32 -> Word32 -> Stream m Word32 #-} - - -#endif - --- NOTE: We could implement a generic "too large" test: --- --- len x y | x > y = 0 --- | n > 0 && n <= fromIntegral (maxBound :: Int) = fromIntegral n --- | otherwise = error --- where --- n = y-x+1 --- --- Alas, GHC won't eliminate unnecessary comparisons (such as n >= 0 for --- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744 --- - -enumFromTo_int :: forall m. Monad m => Int -> Int -> Stream m Int -{-# INLINE_FUSED enumFromTo_int #-} -enumFromTo_int x y = x `seq` y `seq` Stream step (Just x) - where - -- {-# INLINE [0] len #-} - -- len :: Int -> Int -> Int - -- len u v | u > v = 0 - -- | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - -- (n > 0) - -- $ n - -- where - -- n = v-u+1 - - {-# INLINE_INNER step #-} - step Nothing = return $ Done - step (Just z) | z == y = return $ Yield z Nothing - | z < y = return $ Yield z (Just (z+1)) - | otherwise = return $ Done - - -enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_intlike #-} -enumFromTo_intlike x y = x `seq` y `seq` Stream step (Just x) - where - {-# INLINE_INNER step #-} - step Nothing = return $ Done - step (Just z) | z == y = return $ Yield z Nothing - | z < y = return $ Yield z (Just (z+1)) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_int :: Monad m => Int -> Int -> Stream m Int - -#if WORD_SIZE_IN_BITS > 32 - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_intlike :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} - -#else - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_intlike :: Monad m => Int32 -> Int32 -> Stream m Int32 #-} - -#endif - -enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_big_word #-} -enumFromTo_big_word x y = x `seq` y `seq` Stream step (Just x) - where - {-# INLINE_INNER step #-} - step Nothing = return $ Done - step (Just z) | z == y = return $ Yield z Nothing - | z < y = return $ Yield z (Just (z+1)) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_big_word :: Monad m => Word -> Word -> Stream m Word - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word64 -> Word64 -> Stream m Word64 - -#if WORD_SIZE_IN_BITS == 32 -"enumFromTo [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word32 -> Word32 -> Stream m Word32 - -#endif - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Integer -> Integer -> Stream m Integer #-} - - - -#if WORD_SIZE_IN_BITS > 32 - --- FIXME: the "too large" test is totally wrong -enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_big_int #-} -enumFromTo_big_int x y = x `seq` y `seq` Stream step (Just x) +enumFromTo_integral :: (Integral a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_integral #-} +enumFromTo_integral !x !y = Stream step (Just x) where + -- NOTE: We use (x+1) instead of (succ x) below because the latter + -- checks for overflow which can't happen here. {-# INLINE_INNER step #-} step Nothing = return $ Done step (Just z) | z == y = return $ Yield z Nothing | z < y = return $ Yield z (Just (z+1)) | otherwise = return $ Done -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_big_int :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} - - - -#endif - enumFromTo_char :: Monad m => Char -> Char -> Stream m Char {-# INLINE_FUSED enumFromTo_char #-} -enumFromTo_char x y = x `seq` y `seq` Stream step xn +enumFromTo_char !x !y = Stream step xn where xn = ord x yn = ord y @@ -1538,21 +1390,10 @@ enumFromTo_char x y = x `seq` y `seq` Stream step xn step zn | zn <= yn = return $ Yield (unsafeChr zn) (zn+1) | otherwise = return $ Done -{-# RULES - -"enumFromTo [Stream]" - enumFromTo = enumFromTo_char #-} - - - ------------------------------------------------------------------------- - --- Specialise enumFromTo for Float and Double. --- Also, try to do something about pairs? enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_double #-} -enumFromTo_double n m = n `seq` m `seq` Stream step ini +enumFromTo_double !n !m = Stream step ini where lim = m + 1/2 -- important to float out ini = 0 @@ -1561,13 +1402,26 @@ enumFromTo_double n m = n `seq` m `seq` Stream step ini where x' = x + n -{-# RULES -"enumFromTo [Stream]" - enumFromTo = enumFromTo_double :: Monad m => Double -> Double -> Stream m Double +{-# RULES -"enumFromTo [Stream]" - enumFromTo = enumFromTo_double :: Monad m => Float -> Float -> Stream m Float #-} +"Stream.enumFromTo[Int]" enumFromTo @Int = enumFromTo_integral +"Stream.enumFromTo[Int8]" enumFromTo @Int8 = enumFromTo_integral +"Stream.enumFromTo[Int16]" enumFromTo @Int16 = enumFromTo_integral +"Stream.enumFromTo[Int32]" enumFromTo @Int32 = enumFromTo_integral +"Stream.enumFromTo[Int64]" enumFromTo @Int64 = enumFromTo_integral +"Stream.enumFromTo[Word]" enumFromTo @Word = enumFromTo_integral +"Stream.enumFromTo[Word8]" enumFromTo @Word8 = enumFromTo_integral +"Stream.enumFromTo[Word16]" enumFromTo @Word16 = enumFromTo_integral +"Stream.enumFromTo[Word32]" enumFromTo @Word32 = enumFromTo_integral +"Stream.enumFromTo[Word64]" enumFromTo @Word64 = enumFromTo_integral +"Stream.enumFromTo[Integer]" enumFromTo @Integer = enumFromTo_integral + +"Stream.enumFromTo[Float]" enumFromTo @Float = enumFromTo_double +"Stream.enumFromTo[Double]" enumFromTo @Double = enumFromTo_double + +"Stream.enumFromTo[Char]" enumFromTo @Char = enumFromTo_char + #-} diff --git a/vector/tests-inspect/Inspect/Alloc.hs b/vector/tests-inspect/Inspect/Alloc.hs index 5627874b..f3bcb1ee 100644 --- a/vector/tests-inspect/Inspect/Alloc.hs +++ b/vector/tests-inspect/Inspect/Alloc.hs @@ -105,6 +105,17 @@ tests = testGroup "allocations" , 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_enumFromToStream[Int]" (test_enumFromToStream @Int fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Int64]" (test_enumFromToStream @Int64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Int32]" (test_enumFromToStream @Int32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Int16]" (test_enumFromToStream @Int16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromToStream[Word]" (test_enumFromToStream @Word fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Word64]" (test_enumFromToStream @Word64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Word32]" (test_enumFromToStream @Word32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromToStream[Word16]" (test_enumFromToStream @Word16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromToStream[Float]" (test_enumFromToStream @Float round 0) 100000 + , allocWHNF "test_enumFromToStream[Double]" (test_enumFromToStream @Double round 0) 100000 + , allocWHNF "test_enumFromToStream[Char]" (test_enumFromToStream @Char ord (chr 32)) (chr 8000) -- FIXME: We don't have specializations for enumFromThenTo -- -- , allocWHNF "test_enumFromThenTo" test_enumFromThenTo size diff --git a/vector/tests-inspect/Inspect/Fusion.hs b/vector/tests-inspect/Inspect/Fusion.hs index 2dd32428..7c860739 100644 --- a/vector/tests-inspect/Inspect/Fusion.hs +++ b/vector/tests-inspect/Inspect/Fusion.hs @@ -6,6 +6,9 @@ module Inspect.Fusion where import Test.Tasty -- import Test.Tasty.Inspection +import qualified Data.Vector.Fusion.Bundle.Monadic as B +import Data.Vector.Fusion.Bundle.Size (Size(..)) +import qualified Data.Stream.Monadic as S import qualified Data.Vector.Unboxed as VU import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Generic as VG @@ -13,6 +16,14 @@ import Data.Vector.Fusion.Util (Box) import Test.InspectExtra + +-- We need to define this function to test rewrite rules in vector-stream.Hv +-- Rewrite rules in Bundle do not reuse rules in vector-stream +enumFromToStream :: (Enum a, VG.Vector v a) => a -> a -> v a +{-# INLINE enumFromToStream #-} +enumFromToStream x y = VG.unstream $ B.fromStream (S.enumFromTo x y) Unknown + + -- NOTE: [Fusion tests] -- ~~~~~~~~~~~~~~~~~~~~ -- @@ -198,7 +209,10 @@ 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) - +test_enumFromToStream :: (Enum a, VU.Unbox a) => (a -> Int) -> a -> a -> Int +{-# INLINE test_enumFromToStream #-} +test_enumFromToStream fun a + = goodProducer (VU.map fun . enumFromToStream a) ---------------------------------------------------------------- -- Function consuming vectors @@ -286,6 +300,7 @@ tests = testGroup "Fusion" , $(inspectFusion 'test_enumFromStepN) , $(inspectClassyFusion 'test_enumFromTo) , $(inspectClassyFusion 'test_enumFromThenTo) + , $(inspectClassyFusion 'test_enumFromToStream) ] , testGroup "consumers" [ $(inspectFusion 'test_bang) diff --git a/vector/tests/Main.hs b/vector/tests/Main.hs index e30c1501..246b3179 100644 --- a/vector/tests/Main.hs +++ b/vector/tests/Main.hs @@ -8,6 +8,7 @@ import qualified Tests.Vector.Strict import qualified Tests.Vector.Unboxed import qualified Tests.Bundle import qualified Tests.Move +import qualified Tests.Specialization import qualified Tests.Deriving () import Test.Tasty (defaultMain,testGroup) @@ -23,4 +24,5 @@ main = defaultMain $ testGroup "toplevel" $ concat ] , Tests.Vector.UnitTests.tests , Tests.Move.tests + , Tests.Specialization.tests ] diff --git a/vector/tests/Tests/Specialization.hs b/vector/tests/Tests/Specialization.hs new file mode 100644 index 00000000..776073af --- /dev/null +++ b/vector/tests/Tests/Specialization.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- We provide custom specialized versions for some functions so we +-- need that specializations perform same as nonspecialized versions +module Tests.Specialization (tests) where + +import Data.Char +import Data.Int +import Data.Word +import Data.Typeable +import qualified Data.Vector as Boxed +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Fusion.Bundle.Monadic as B +import Data.Vector.Fusion.Bundle.Size (Size(..)) +import qualified Data.Stream.Monadic as S + +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: [TestTree] +tests = + [ testGroup "specializations" + [ testGroup "enumFromTo" + [ specEnumFromTo (Boxed.enumFromTo @Word8) + , specEnumFromTo (Boxed.enumFromTo @Word16) + , specEnumFromTo (Boxed.enumFromTo @Word32) + , specEnumFromTo (Boxed.enumFromTo @Word64) + , specEnumFromTo (Boxed.enumFromTo @Word) + , specEnumFromTo (Boxed.enumFromTo @Int8) + , specEnumFromTo (Boxed.enumFromTo @Int16) + , specEnumFromTo (Boxed.enumFromTo @Int32) + , specEnumFromTo (Boxed.enumFromTo @Int64) + , specEnumFromTo (Boxed.enumFromTo @Int) + , specEnumFromTo (Boxed.enumFromTo @Integer) + , specEnumFromToFloat (Boxed.enumFromTo @Float) + , specEnumFromToFloat (Boxed.enumFromTo @Double) + , specEnumFromToChar Boxed.enumFromTo + ] + , testGroup "enumFromTo streaming" + [ specEnumFromTo (enumFromToStream @Word8) + , specEnumFromTo (enumFromToStream @Word16) + , specEnumFromTo (enumFromToStream @Word32) + , specEnumFromTo (enumFromToStream @Word64) + , specEnumFromTo (enumFromToStream @Word) + , specEnumFromTo (enumFromToStream @Int8) + , specEnumFromTo (enumFromToStream @Int16) + , specEnumFromTo (enumFromToStream @Int32) + , specEnumFromTo (enumFromToStream @Int64) + , specEnumFromTo (enumFromToStream @Int) + , specEnumFromTo (enumFromToStream @Integer) + , specEnumFromToFloat (enumFromToStream @Float) + , specEnumFromToFloat (enumFromToStream @Double) + , specEnumFromToChar enumFromToStream + ] + ] + ] + +-- We need to define this function to test rewrite rules in vector-stream. +-- Rewrite rules in Bundle do not reuse rules in vector-stream +enumFromToStream :: (Enum a) => a -> a -> Boxed.Vector a +{-# INLINE enumFromToStream #-} +enumFromToStream x y = VG.unstream $ B.fromStream (S.enumFromTo x y) Unknown + +-- For integral data type we need to make sure we never generate slice +-- too big. +specEnumFromTo + :: forall a. (Enum a, Eq a, Show a, Arbitrary a, Typeable a, Integral a) + => (a -> a -> Boxed.Vector a) -> TestTree +{-# INLINE specEnumFromTo #-} +specEnumFromTo enumFromTo' = testProperty (show (typeOf (undefined :: a))) + $ \(a::a) (d::Int16) -> + let b = fromInteger $ fromIntegral a + fromIntegral d + diff = abs $ fromIntegral a - fromIntegral b :: Integer + in diff < 65000 ==> + ( counterexample ("[" ++ show a ++ " .. " ++ show b ++ "]") + $ [a .. b] == Boxed.toList (enumFromTo' a b) + ) + +specEnumFromToFloat + :: forall a. (Enum a, Eq a, Show a, Arbitrary a, Typeable a, Fractional a, Real a) + => (a -> a -> Boxed.Vector a) -> TestTree +{-# INLINE specEnumFromToFloat #-} +specEnumFromToFloat enumFromTo' = testProperty (show (typeOf (undefined :: a))) + $ \(a::a) (d::Int16) -> + let b = a + realToFrac d / 3 + diff = abs $ a - b + in diff < 65000 ==> + ( counterexample ("[" ++ show a ++ " .. " ++ show b ++ "]") + $ [a .. b] == Boxed.toList (enumFromTo' a b) + ) + +specEnumFromToChar :: (Char -> Char -> Boxed.Vector Char) -> TestTree +specEnumFromToChar enumFromTo' = testProperty "Char" + $ \(i1::Word8) (i2::Word8) -> + let c1 = chr $ 256 + fromIntegral i1 + c2 = chr $ 256 + fromIntegral i2 + in ( counterexample (show (c1,c2)) + $ [c1 .. c2] == Boxed.toList (enumFromTo' c1 c2) + ) diff --git a/vector/vector.cabal b/vector/vector.cabal index e868e95f..f9e6839e 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -185,6 +185,7 @@ common tests-common , template-haskell , base-orphans >= 0.6 , vector + , vector-stream , deepseq , primitive , random @@ -205,6 +206,7 @@ common tests-common Tests.Vector.Unboxed Tests.Vector.UnitTests Tests.Deriving + Tests.Specialization Utilities default-extensions: