store-0.1.0.0: bench/Bench.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveDataTypeable #-}
import Control.Applicative ((<$>), (<*>), (*>))
#endif
import Control.DeepSeq
import Criterion.Main
import qualified Data.ByteString as BS
import Data.Int
import Data.Store
import Data.Typeable
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import Data.Word
import GHC.Generics
-- TODO: add packer
#if COMPARISON_BENCH
import qualified Data.Binary as Binary
import qualified Data.Serialize as Cereal
import qualified Data.ByteString.Lazy as BL
import Data.Vector.Serialize ()
#endif
data SomeData = SomeData !Int64 !Word8 !Double
deriving (Eq, Show, Generic)
instance NFData SomeData where
rnf x = x `seq` ()
instance Store SomeData
#if COMPARISON_BENCH
instance Cereal.Serialize SomeData
instance Binary.Binary SomeData
#endif
main :: IO ()
main = do
#if SMALL_BENCH
let is = 0::Int
sds = SomeData 1 1 1
smallprods = (SmallProduct 0 1 2 3)
smallmanualprods = (SmallProductManual 0 1 2 3)
sss = [SS1 1, SS2 2, SS3 3, SS4 4]
ssms = [SSM1 1, SSM2 2, SSM3 3, SSM4 4]
nestedTuples = ((1,2),(3,4)) :: ((Int,Int),(Int,Int))
#else
let is = V.enumFromTo 1 100 :: V.Vector Int
sds = (\i -> SomeData i (fromIntegral i) (fromIntegral i))
<$> V.enumFromTo 1 100
smallprods = (\ i -> SmallProduct i (i+1) (i+2) (i+3))
<$> V.enumFromTo 1 100
smallmanualprods = (\ i -> SmallProductManual i (i+1) (i+2) (i+3))
<$> V.enumFromTo 1 100
sss = (\i -> case i `mod` 4 of
0 -> SS1 (fromIntegral i)
1 -> SS2 (fromIntegral i)
2 -> SS3 (fromIntegral i)
3 -> SS4 (fromIntegral i)
_ -> error "This does not compute."
) <$> V.enumFromTo 1 (100 :: Int)
ssms = (\i -> case i `mod` 4 of
0 -> SSM1 (fromIntegral i)
1 -> SSM2 (fromIntegral i)
2 -> SSM3 (fromIntegral i)
3 -> SSM4 (fromIntegral i)
_ -> error "This does not compute."
) <$> V.enumFromTo 1 (100 :: Int)
nestedTuples = (\i -> ((i,i+1),(i+2,i+3))) <$> V.enumFromTo (1::Int) 100
#endif
defaultMain
[ bgroup "encode"
[ benchEncode is
#if !SMALL_BENCH
, benchEncode' "1kb storable" (SV.fromList ([1..256] :: [Int32]))
, benchEncode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32]))
, benchEncode' "1kb normal" (V.fromList ([1..256] :: [Int32]))
, benchEncode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32]))
#endif
, benchEncode smallprods
, benchEncode smallmanualprods
, benchEncode sss
, benchEncode ssms
, benchEncode nestedTuples
, benchEncode sds
]
, bgroup "decode"
[ benchDecode is
#if !SMALL_BENCH
, benchDecode' "1kb storable" (SV.fromList ([1..256] :: [Int32]))
, benchDecode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32]))
, benchDecode' "1kb normal" (V.fromList ([1..256] :: [Int32]))
, benchDecode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32]))
#endif
, benchDecode smallprods
, benchDecode smallmanualprods
, benchDecode sss
, benchDecode ssms
, benchDecode nestedTuples
, benchDecode sds
]
]
type Ctx a =
( Store a, Typeable a, NFData a
#if COMPARISON_BENCH
, Binary.Binary a
, Cereal.Serialize a
#endif
)
benchEncode :: Ctx a => a -> Benchmark
benchEncode = benchEncode' ""
benchEncode' :: Ctx a => String -> a -> Benchmark
benchEncode' msg x0 =
env (return x0) $ \x ->
let label = msg ++ " (" ++ show (typeOf x0) ++ ")"
benchStore name = bench name (nf encode x) in
#if COMPARISON_BENCH
bgroup label
[ benchStore "store"
, bench "cereal" (nf Cereal.encode x)
, bench "binary" (nf Binary.encode x)
]
#else
benchStore label
#endif
benchDecode :: Ctx a => a -> Benchmark
benchDecode = benchDecode' ""
-- TODO: comparison bench for decode
benchDecode' :: forall a. Ctx a => String -> a -> Benchmark
#if COMPARISON_BENCH
benchDecode' prefix x0 =
bgroup label
[ env (return (encode x0)) $ \x -> bench "store" (nf (decodeEx :: BS.ByteString -> a) x)
, env (return (Cereal.encode x0)) $ \x -> bench "cereal" (nf ((ensureRight . Cereal.decode) :: BS.ByteString -> a) x)
, env (return (Binary.encode x0)) $ \x -> bench "binary" (nf (Binary.decode :: BL.ByteString -> a) x)
]
where
label = prefix ++ " (" ++ show (typeOf x0) ++ ")"
ensureRight (Left x) = error "left!"
ensureRight (Right x) = x
#else
benchDecode' prefix x0 =
env (return (encode x0)) $ \x ->
bench (prefix ++ " (" ++ show (typeOf x0) ++ ")") (nf (decodeEx :: BS.ByteString -> a) x)
#endif
------------------------------------------------------------------------
-- Serialized datatypes
data SmallProduct = SmallProduct Int32 Int32 Int32 Int32
deriving (Generic, Show, Typeable)
instance NFData SmallProduct
instance Store SmallProduct
data SmallProductManual = SmallProductManual Int32 Int32 Int32 Int32
deriving (Generic, Show, Typeable)
instance NFData SmallProductManual
instance Store SmallProductManual where
size = ConstSize 16
peek = SmallProductManual <$> peek <*> peek <*> peek <*> peek
poke (SmallProductManual a b c d) = poke a *> poke b *> poke c *> poke d
data SmallSum
= SS1 Int8
| SS2 Int32
| SS3 Int64
| SS4 Word32
deriving (Generic, Show, Typeable)
instance NFData SmallSum
instance Store SmallSum
data SmallSumManual
= SSM1 Int8
| SSM2 Int32
| SSM3 Int64
| SSM4 Word32
deriving (Generic, Show, Typeable)
instance NFData SmallSumManual
instance Store SmallSumManual where
size = VarSize $ \x -> 1 + case x of
SSM1{} -> 1
SSM2{} -> 4
SSM3{} -> 8
SSM4{} -> 4
peek = do
tag <- peek
case tag :: Word8 of
0 -> SSM1 <$> peek
1 -> SSM2 <$> peek
2 -> SSM3 <$> peek
3 -> SSM4 <$> peek
_ -> fail "Invalid tag"
poke (SSM1 x) = poke (0 :: Word8) >> poke x
poke (SSM2 x) = poke (1 :: Word8) >> poke x
poke (SSM3 x) = poke (2 :: Word8) >> poke x
poke (SSM4 x) = poke (3 :: Word8) >> poke x
-- TODO: add TH generation of the above, and add LargeSum / LargeProduct cases
#if COMPARISON_BENCH
instance Binary.Binary SmallProduct
instance Binary.Binary SmallSum
instance Cereal.Serialize SmallProduct
instance Cereal.Serialize SmallSum
instance Binary.Binary SmallProductManual where
get = SmallProductManual <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get
put (SmallProductManual a b c d) = Binary.put a *> Binary.put b *> Binary.put c *> Binary.put d
instance Binary.Binary SmallSumManual where
get = do
tag <- Binary.get
case tag :: Word8 of
0 -> SSM1 <$> Binary.get
1 -> SSM2 <$> Binary.get
2 -> SSM3 <$> Binary.get
3 -> SSM4 <$> Binary.get
_ -> fail "Invalid tag"
put (SSM1 x) = Binary.put (0 :: Word8) *> Binary.put x
put (SSM2 x) = Binary.put (1 :: Word8) *> Binary.put x
put (SSM3 x) = Binary.put (2 :: Word8) *> Binary.put x
put (SSM4 x) = Binary.put (3 :: Word8) *> Binary.put x
instance Cereal.Serialize SmallProductManual where
get = SmallProductManual <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get
put (SmallProductManual a b c d) = Cereal.put a *> Cereal.put b *> Cereal.put c *> Cereal.put d
instance Cereal.Serialize SmallSumManual where
get = do
tag <- Cereal.get
case tag :: Word8 of
0 -> SSM1 <$> Cereal.get
1 -> SSM2 <$> Cereal.get
2 -> SSM3 <$> Cereal.get
3 -> SSM4 <$> Cereal.get
_ -> fail "Invalid tag"
put (SSM1 x) = Cereal.put (0 :: Word8) *> Cereal.put x
put (SSM2 x) = Cereal.put (1 :: Word8) *> Cereal.put x
put (SSM3 x) = Cereal.put (2 :: Word8) *> Cereal.put x
put (SSM4 x) = Cereal.put (3 :: Word8) *> Cereal.put x
#endif