diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -26,7 +26,7 @@ addSchemaModules pd0 lbi = do let outPath = autogenModulesDir lbi let schemaFlag = outPath "schemagen.flg" - modules <- fmap lines $ readFile schemaFlag + modules <- lines <$> readFile schemaFlag let hbi = (Just $ emptyBuildInfo{ otherModules = map fromString modules }, []) return $ updatePackageDescription hbi pd0 @@ -73,7 +73,7 @@ return (flagTS < bondTS || flagTS < bondConstTS) else return True when needSchemaRegen $ do - extras <- getProgramOutput verbosity hbc ["-h", "-o", buildDir lbi, "--hsboot", "-n", "bond=Data.Bond.Schema", schemaPath "bond.bond", schemaPath "bond_const.bond"] + extras <- getProgramOutput verbosity hbc ["-h", "-o", buildDir lbi, "--hsboot", "--nfdata", "-n", "bond=Data.Bond.Schema", schemaPath "bond.bond", schemaPath "bond_const.bond"] createDirectoryIfMissing True (takeDirectory schemaFlag) writeFile schemaFlag extras @@ -82,15 +82,20 @@ let dataPathFile = outPath "DataPath.hs" dataPathFileExists <- doesFileExist dataPathFile - when (not dataPathFileExists) $ + unless dataPathFileExists $ writeFile dataPathFile $ "module DataPath where\n\ \autogenPath :: String\n\ \autogenPath = " ++ show outPath -- generate code for unittests - when (fromFlagOrDefault False $ configTests conf) $ do + when ((fromFlagOrDefault False $ configTests conf) || (fromFlagOrDefault False $ configBenchmarks conf)) $ do regenSchemas verbosity hbc ("test" "compat" "schemas") outPath (outPath "compatgen.flg") + + when (fromFlagOrDefault False $ configBenchmarks conf) $ do + regenSchemas verbosity hbc ("bench" "schemas") outPath (outPath "benchgen.flg") + + when (fromFlagOrDefault False $ configTests conf) $ do regenSchemas verbosity hbc ("test" "simple_schemas") outPath (outPath "simplegen.flg") -- run default hook @@ -109,6 +114,6 @@ info verbosity $ "flag file " ++ flagFile ++ " missing" return True when needSchemaRegen $ do - extras <- getProgramOutput verbosity hbc $ ["-o", outDir] ++ schemaFiles + extras <- getProgramOutput verbosity hbc $ ["--nfdata", "-o", outDir] ++ schemaFiles createDirectoryIfMissing True (takeDirectory flagFile) writeFile flagFile extras diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,148 @@ +{-# Language GADTs, ScopedTypeVariables #-} +module Main where + +import Data.Bond +import Benchmark.Intvec +import Unittest.Compat.Compat + +import Control.Applicative +import Criterion.Main +import Data.Proxy +import Data.Word +import System.FilePath +import Prelude -- workaround for Control.Applicative in ghc 7.10 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Vector as V + +compatDataPath :: String +compatDataPath = "test" "compat" "data" + +data ProtoWrapper = forall t. BondProto t => ProtoWrapper String t FilePath + | forall t. BondTaggedProto t => TaggedProtoWrapper String t FilePath + +fromTagged :: ProtoWrapper -> ProtoWrapper +fromTagged (TaggedProtoWrapper n t dat) = ProtoWrapper n t dat +fromTagged w = w + +taggedProtocols :: [ProtoWrapper] +taggedProtocols = + [ TaggedProtoWrapper "CompactBinary" CompactBinaryProto "compat.compact2.dat" + , TaggedProtoWrapper "CompactBinary v1" CompactBinaryV1Proto "compat.compact.dat" + , TaggedProtoWrapper "FastBinary" FastBinaryProto "compat.fast.dat" + ] + +simpleProtocols :: [ProtoWrapper] +simpleProtocols = + [ ProtoWrapper "SimpleBinary" SimpleBinaryProto "compat.simple2.dat" + , ProtoWrapper "SimpleBinary v1" SimpleBinaryV1Proto "compat.simple.dat" + ] + +main :: IO () +main = defaultMain + [ bgroup "bondRead" $ map benchRead (simpleProtocols ++ taggedProtocols) + , bgroup "bondReadTagged" $ map benchReadTagged taggedProtocols + , bgroup "bondReadWithSchema" $ map benchReadSchema (simpleProtocols ++ taggedProtocols) + , bgroup "bondWrite" $ map benchWrite (simpleProtocols ++ taggedProtocols) + , bgroup "bondWriteTagged" $ map benchWriteTagged taggedProtocols + , bgroup "bondWriteWithSchema" $ map benchWriteSchema (simpleProtocols ++ taggedProtocols) + , bgroup "VarInt" + [ bgroup "Read" + [ intRead "1" $ take 10000 $ cycle [0 .. 127] + , intRead "2" $ take 10000 $ cycle [128 .. 16383] + , intRead "3" $ take 10000 $ cycle [16384 .. 2097151] + , intRead "4" $ take 10000 $ cycle [2097152 .. 268435455] + , intRead "5" $ take 10000 $ cycle [268435456 .. 34359738367] + , intRead "6" $ take 10000 $ cycle [34359738368 .. 4398046511103] + , intRead "7" $ take 10000 $ cycle [4398046511104 .. 562949953421311] + , intRead "8" $ take 10000 $ cycle [562949953421312 .. 72057594037927935] + , intRead "9" $ take 10000 $ cycle [72057594037927936 .. 9223372036854775807] + , intRead "10" $ take 10000 $ cycle [9223372036854775808 .. maxBound] + ] + , bgroup "Write" + [ intWrite "1" $ take 10000 $ cycle [0 .. 127] + , intWrite "2" $ take 10000 $ cycle [128 .. 16383] + , intWrite "3" $ take 10000 $ cycle [16384 .. 2097151] + , intWrite "4" $ take 10000 $ cycle [2097152 .. 268435455] + , intWrite "5" $ take 10000 $ cycle [268435456 .. 34359738367] + , intWrite "6" $ take 10000 $ cycle [34359738368 .. 4398046511103] + , intWrite "7" $ take 10000 $ cycle [4398046511104 .. 562949953421311] + , intWrite "8" $ take 10000 $ cycle [562949953421312 .. 72057594037927935] + , intWrite "9" $ take 10000 $ cycle [72057594037927936 .. 9223372036854775807] + , intWrite "10" $ take 10000 $ cycle [9223372036854775808 .. maxBound] + ] + ] + ] + +intRead :: String -> [Word64] -> Benchmark +intRead name xs = env + makeStream + (bench name . nf (bondRead CompactBinaryProto :: BL.ByteString -> Either String Intvec)) + where + makeStream = do + let v = defaultValue { ints = V.fromList xs } + let Right stream = bondWrite CompactBinaryProto v + return stream + +intWrite :: String -> [Word64] -> Benchmark +intWrite name xs = env + (return defaultValue { ints = V.fromList xs }) + (bench name . nf (bondWrite CompactBinaryProto)) + +benchRead :: ProtoWrapper -> Benchmark +benchRead (ProtoWrapper n t dat) = + env (BL.fromStrict <$> BS.readFile (compatDataPath dat)) + (bench n . nf (bondRead t :: BL.ByteString -> Either String Compat)) +benchRead p = benchRead (fromTagged p) + +benchReadTagged :: ProtoWrapper -> Benchmark +benchReadTagged (TaggedProtoWrapper n t dat) = + env (BL.fromStrict <$> BS.readFile (compatDataPath dat)) + (bench n . nf (bondReadTagged t)) +benchReadTagged _ = error "wrong type" + +benchReadSchema :: ProtoWrapper -> Benchmark +benchReadSchema (ProtoWrapper n t dat) = + let schema = getSchema (Proxy :: Proxy Compat) + in env (do + stream <- BL.fromStrict <$> BS.readFile (compatDataPath dat) + -- run decoding once to expand schema + return (bondReadWithSchema t schema stream `seq` stream) + ) + (bench n . nf (bondReadWithSchema t schema)) +benchReadSchema p = benchReadSchema (fromTagged p) + +benchWrite :: ProtoWrapper -> Benchmark +benchWrite (ProtoWrapper n t dat) = + env getCompat + (bench n . nf (bondWrite t)) + where + getCompat :: IO Compat + getCompat = do + stream <- BL.readFile (compatDataPath dat) + let Right val = bondRead t stream + return val +benchWrite p = benchWrite (fromTagged p) + +benchWriteTagged :: ProtoWrapper -> Benchmark +benchWriteTagged (TaggedProtoWrapper n t dat) = + env getStruct + (bench n . nf (bondWriteTagged t)) + where + getStruct = do + stream <- BL.readFile (compatDataPath dat) + let Right val = bondReadTagged t stream + return val +benchWriteTagged _ = error "wrong type" + +benchWriteSchema :: ProtoWrapper -> Benchmark +benchWriteSchema (ProtoWrapper n t dat) = + env getStruct + (bench n . nf (bondWriteWithSchema t schema)) + where + schema = getSchema (Proxy :: Proxy Compat) + getStruct = do + stream <- BL.readFile (compatDataPath dat) + let Right val = bondReadWithSchema t schema stream + return val +benchWriteSchema p = benchWriteSchema (fromTagged p) diff --git a/bench/schemas/bench.bond b/bench/schemas/bench.bond new file mode 100644 --- /dev/null +++ b/bench/schemas/bench.bond @@ -0,0 +1,5 @@ +namespace benchmark + +struct intvec { + 10: vector ints; +} diff --git a/bond-haskell.cabal b/bond-haskell.cabal --- a/bond-haskell.cabal +++ b/bond-haskell.cabal @@ -1,5 +1,5 @@ name: bond-haskell -version: 0.1.2.0 +version: 0.1.3.0 synopsis: Runtime support for BOND serialization description: Bond is a cross-platform framework for handling schematized data. It supports cross-language de/serialization and @@ -20,6 +20,7 @@ extra-source-files: schema/*.bond test/compat/schemas/*.bond test/simple_schemas/*.bond + bench/schemas/*.bond data-files: test/broken_schemas/*.json test/compat/data/compat.compact2.dat test/compat/data/compat.compact.dat @@ -61,12 +62,13 @@ Data.Bond.Internal.Utils Data.Bond.Internal.Utils build-depends: base >= 4.7 && < 5 - , bond-haskell-compiler >= 0.1.2.0 && < 0.1.3 + , bond-haskell-compiler >= 0.1.3.0 && < 0.1.4 , aeson , array , binary >= 0.7.0.0 , bytestring >= 0.10 , containers >= 0.4 + , deepseq , extra >= 1.0 , hashable >= 1.0 , mtl >= 2.1 @@ -86,6 +88,7 @@ , bond-haskell , bytestring >= 0.10 , containers >= 0.4 + , deepseq , either , filepath >= 1.0 , mtl >= 2.1 @@ -94,6 +97,20 @@ , tasty-hunit , tasty-quickcheck , unordered-containers >= 0.2 + , vector + ghc-options: -threaded -W -Wall -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark bond-haskell-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: base + , bond-haskell + , bytestring + , criterion + , filepath + , vector ghc-options: -threaded -W -Wall -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/Bond/Internal/BinaryUtils.hs b/src/Data/Bond/Internal/BinaryUtils.hs --- a/src/Data/Bond/Internal/BinaryUtils.hs +++ b/src/Data/Bond/Internal/BinaryUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, BangPatterns, MultiWayIf #-} module Data.Bond.Internal.BinaryUtils where import Data.Bond.Types @@ -7,7 +7,9 @@ import Control.Applicative import Control.Monad.Error import Data.Bits +import Data.Monoid import Prelude -- workaround for Control.Applicative in ghc 7.10 +import qualified Data.Binary.Builder as BLD import qualified Data.Binary.Get as B import qualified Data.Binary.Put as B import qualified Data.ByteString as BS @@ -46,12 +48,27 @@ getLazyByteString = BondGet . B.getLazyByteString getVarInt :: forall a t. (FiniteBits a, Num a, ReaderM t ~ B.Get) => BondGet t a -getVarInt = step 0 +getVarInt = BondGet $ fastGet <|> slowGet 0 where - step n | n > finiteBitSize (0 :: a) `div` 7 = fail "VarInt: sequence too long" - step n = do - b <- fromIntegral <$> getWord8 - rest <- if b `testBit` 7 then step (n + 1) else return 0 + maxSize = 1 + finiteBitSize (0 :: a) `div` 7 + fastGet = do + binstr <- B.lookAhead $ B.getByteString maxSize + let loop i !v = + let b = fromIntegral $ BS.index binstr i + v' = v .|. ((b `clearBit` 7) `shiftL` (i * 7)) + in if | i >= maxSize -> Nothing + | b `testBit` 7 -> loop (i + 1) v' + | otherwise -> Just (i + 1, v') + case loop 0 0 of + Nothing -> fail "VarInt: sequence too long" + Just (consumed, value) -> do + B.skip consumed + return value + -- fallback in case there is not enough bytes in stream for max sequence + slowGet i | i >= maxSize = fail "VarInt: sequence too long" + slowGet i = do + b <- fromIntegral <$> B.getWord8 + rest <- if b `testBit` 7 then slowGet (i + 1) else return 0 return $ (b `clearBit` 7) .|. (rest `shiftL` 7) tryPut :: ErrorT String B.PutM () -> Either String BL.ByteString @@ -78,9 +95,29 @@ putLazyByteString = BondPut . lift . B.putLazyByteString putVarInt :: (FiniteBits a, Integral a, WriterM t ~ ErrorT String B.PutM) => a -> BondPut t -putVarInt i | i < 0 = error "VarInt with negative value" -putVarInt i | i < 128 = putWord8 $ fromIntegral i -putVarInt i = let iLow = fromIntegral $ i .&. 0x7F - in do - putWord8 $ iLow `setBit` 7 - putVarInt (i `shiftR` 7) +putVarInt n | n < 0 = error "VarInt with negative value" +putVarInt n = BondPut $ lift $ B.putBuilder $ makeBuilder n + where + makeBuilder i | i < 128 = BLD.singleton $ fromIntegral i + makeBuilder i | i < 16384 = let (b1, b0) = fromIntegral i `divMod` 128 + in BLD.putWord16be $ 0x8000 .|. (b0 `shiftL` 8) .|. b1 + makeBuilder i | i < 2097152 = let (temp, b0) = i `divMod` 128 + (b2, b1) = temp `divMod` 128 + in BLD.putWord16be (0x8080 .|. fromIntegral ((b0 `shiftL` 8) .|. b1)) <> + BLD.singleton (fromIntegral b2) + makeBuilder i | i < 268435456 = let (temp1, b0) = i `divMod` 128 + (temp2, b1) = temp1 `divMod` 128 + (b3, b2) = temp2 `divMod` 128 + in BLD.putWord32be $ 0x80808000 .|. + fromIntegral ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3) + makeBuilder i | i < 9223372036854775808 = let (temp1, b0) = i `divMod` 128 + (temp2, b1) = temp1 `divMod` 128 + (temp3, b2) = temp2 `divMod` 128 + (rest, b3) = temp3 `divMod` 128 + in BLD.putWord32be (0x80808080 .|. + fromIntegral ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3)) <> + makeBuilder rest + makeBuilder i = let (temp1, b0) = i `divMod` 128 + (temp2, b1) = temp1 `divMod` 128 + in BLD.putWord16be (0x8080 .|. fromIntegral ((b0 `shiftL` 8) .|. b1)) <> + makeBuilder temp2 diff --git a/src/Data/Bond/Internal/Bonded.hs b/src/Data/Bond/Internal/Bonded.hs --- a/src/Data/Bond/Internal/Bonded.hs +++ b/src/Data/Bond/Internal/Bonded.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} module Data.Bond.Internal.Bonded where import Data.Bond.Marshal @@ -6,6 +6,8 @@ import Data.Bond.Internal.MarshalUtils import {-# SOURCE #-} Data.Bond.Internal.Protocol +import GHC.Generics (Generic) +import Control.DeepSeq import Control.Exception import Data.Typeable import qualified Data.ByteString.Lazy as Lazy @@ -21,7 +23,7 @@ data Bonded a = BondedStream Lazy.ByteString -- ^ Marshalled stream | BondedObject a -- ^ Deserialized value - deriving Typeable + deriving (Generic, Typeable) instance Show a => Show (Bonded a) where show BondedStream{} = "BondedStream" @@ -35,6 +37,8 @@ Left msg -> throw (BondedException msg) Right v -> v in aobj == bobj + +instance NFData a => NFData (Bonded a) -- | Extract value from 'Bonded' using compile-type schema getValue :: BondStruct a => Bonded a -> Either String a diff --git a/src/Data/Bond/Internal/Bonded.hs-boot b/src/Data/Bond/Internal/Bonded.hs-boot --- a/src/Data/Bond/Internal/Bonded.hs-boot +++ b/src/Data/Bond/Internal/Bonded.hs-boot @@ -1,5 +1,6 @@ module Data.Bond.Internal.Bonded where +import Control.DeepSeq import Data.Typeable import qualified Data.ByteString.Lazy as BL @@ -7,3 +8,4 @@ instance Typeable Bonded instance Show a => Show (Bonded a) +instance NFData a => NFData (Bonded a) diff --git a/src/Data/Bond/Internal/Imports.hs b/src/Data/Bond/Internal/Imports.hs --- a/src/Data/Bond/Internal/Imports.hs +++ b/src/Data/Bond/Internal/Imports.hs @@ -5,6 +5,7 @@ , BondType(..) , Hashable , IsString + , NFData , Protocol(..) , ap , asProxyTypeOf @@ -19,6 +20,7 @@ import Data.Bond.Internal.Protocol import Data.Bond.Internal.Utils as X +import Control.DeepSeq (NFData) import Control.Monad (ap) import Data.Hashable (Hashable) import Data.Proxy (asProxyTypeOf) diff --git a/src/Data/Bond/Struct.hs b/src/Data/Bond/Struct.hs --- a/src/Data/Bond/Struct.hs +++ b/src/Data/Bond/Struct.hs @@ -1,8 +1,11 @@ +{-# Language DeriveGeneric #-} module Data.Bond.Struct where import {-# SOURCE #-} Data.Bond.Schema.BondDataType import Data.Bond.Types +import Control.DeepSeq +import GHC.Generics (Generic) import qualified Data.Map.Strict as M -- |Representation of bond serializable type used in runtime-schema operations. @@ -25,8 +28,10 @@ | SET BondDataType [Value] | MAP BondDataType BondDataType [(Value, Value)] | BONDED (Bonded Struct) - deriving Show + deriving (Show, Generic) +instance NFData Value + instance Eq Value where (BOOL a) == (BOOL b) = a == b (INT8 a) == (INT8 b) = a == b @@ -51,7 +56,9 @@ -- |Representation of bond structure used in runtime-schema operations. data Struct = Struct { base :: Maybe Struct, fields :: M.Map Ordinal Value } - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance NFData Struct valueName :: Value -> String valueName (BOOL _) = "bool" diff --git a/src/Data/Bond/Types.hs b/src/Data/Bond/Types.hs --- a/src/Data/Bond/Types.hs +++ b/src/Data/Bond/Types.hs @@ -28,6 +28,7 @@ import {-# SOURCE #-} Data.Bond.Internal.Bonded +import Control.DeepSeq import Data.Data import Data.Int import Data.String @@ -43,15 +44,15 @@ -- |Bond "string" type newtype Utf8 = Utf8 BS.ByteString - deriving (Eq, Ord, Hashable, Typeable) + deriving (Eq, Ord, Hashable, Typeable, NFData) -- |Bond "wstring" type newtype Utf16 = Utf16 BS.ByteString - deriving (Eq, Ord, Hashable, Typeable) + deriving (Eq, Ord, Hashable, Typeable, NFData) -- |Bond "blob" type newtype Blob = Blob BS.ByteString - deriving (Show, Eq, Ord, Hashable, Typeable) + deriving (Show, Eq, Ord, Hashable, Typeable, NFData) -- |Bond string\/wstring transformations from/to 'String' and 'T.Text'. class IsString a => EncodedString a where @@ -83,4 +84,4 @@ -- |Bond structure field ordinal. newtype Ordinal = Ordinal Word16 - deriving (Eq, Ord, Show, Hashable) + deriving (Eq, Ord, Show, Hashable, NFData) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,6 +8,7 @@ import Unittest.Simple.Inner as Inner import Unittest.Simple.Outer as Outer import Unittest.Simple.Reqopt as ReqOpt +import Unittest.Simple.Intvec import Control.Monad import Control.Monad.Trans @@ -23,6 +24,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Map as M +import qualified Data.Vector as V import DataPath @@ -152,6 +154,7 @@ , testProperty "Int64" zigzagInt64 , testProperty "Word64" zigzagWord64 ] + , testProperty "VarInt" varIntTest ] where testTagged (TaggedProtoWrapper name proto dat) = testGroup name @@ -470,6 +473,13 @@ zigzagWord64 :: Word64 -> Bool zigzagWord64 x = x == toZigZag (fromZigZag x :: Int64) + +varIntTest :: [Word64] -> Bool +varIntTest xs = let srcStruct = defaultValue { ints = V.fromList xs } + Right stream = bondWrite CompactBinaryProto srcStruct + Right dstStruct = bondRead CompactBinaryProto stream + ys = V.toList $ ints dstStruct + in xs == ys assertEither :: EitherT String IO () -> Assertion assertEither = eitherT assertFailure (const $ return ()) diff --git a/test/simple_schemas/test.bond b/test/simple_schemas/test.bond --- a/test/simple_schemas/test.bond +++ b/test/simple_schemas/test.bond @@ -24,3 +24,7 @@ 20: required_optional string m_reqopt_string; 30: required int16 m_req_nothing_int16 = nothing; } + +struct intvec { + 10: vector ints; +}