{-# 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, Typeable) 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