Encoding benchmark

VyacheslavHashov · VyacheslavHashov · commit bddf64d07c29 · 2017-07-13T00:06:46.000+03:00
diff --git a/bench/Codecs.hs b/bench/Codecs.hs
@@ -0,0 +1,87 @@
+module Main where
+
+import Data.ByteString.Lazy (toStrict)
+import Data.ByteString.Builder (toLazyByteString)
+import Data.ByteString (ByteString)
+import Data.Monoid
+import System.IO.Unsafe
+import Data.Vector as V(fromList, empty)
+import Criterion.Main
+import Data.Time
+import Data.UUID
+import Data.UUID.V4 (nextRandom)
+import Data.Scientific
+
+import Database.PostgreSQL.Protocol.Types
+import Database.PostgreSQL.Protocol.Encoders
+import Database.PostgreSQL.Protocol.Store.Encode
+import Database.PostgreSQL.Protocol.Store.Decode
+import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as PD
+import qualified Database.PostgreSQL.Protocol.Codecs.Encoders as PE
+import qualified Database.PostgreSQL.Protocol.Codecs.PgTypes  as PGT
+
+main :: IO ()
+main = defaultMain
+    [ bgroup "Encoding"
+        [ bench "Message" $ nf encodeMessage queryParams
+        , bench "Scientific" $ nf (runEncode . PE.numeric) testScientific
+        , bench "UTCTime" $ nf (runEncode . PE.timestamptz) testUTCTime
+        , bench "UUID" $ nf (runEncode . PE.uuid) testUUID
+      ]
+    ]
+
+type QueryParams 
+    = (Bool, ByteString, Double, DiffTime, Scientific, UTCTime, UUID)
+
+{-# NOINLINE queryParams #-}
+queryParams :: QueryParams
+queryParams =
+    ( True
+    , "aaaaaaaaaaaa"
+    , 3.1415926
+    , fromIntegral 20000000
+    , scientific 1111111111111 (-18)
+    , unsafePerformIO getCurrentTime
+    , unsafePerformIO nextRandom
+    )
+
+testScientific :: Scientific
+testScientific = scientific 11111111111111 (-18)
+
+{-# NOINLINE testUTCTime #-}
+testUTCTime :: UTCTime
+testUTCTime = unsafePerformIO getCurrentTime
+
+{-# NOINLINE testUUID #-}
+testUUID :: UUID
+testUUID = unsafePerformIO nextRandom
+
+encodeMessage :: QueryParams -> ByteString
+encodeMessage params = runEncode $ 
+    encodeClientMessage parseMessage <> encodeClientMessage bindMessage 
+  where
+    bindMessage = Bind (PortalName "") stmtName Binary 
+        (encodedParams params) Binary
+    encodedParams (a, b, c, d, e, f, g) = V.fromList
+        [ Just . runEncode $ PE.bool a
+        , Just . runEncode $ PE.bytea b
+        , Just . runEncode $ PE.float8 c
+        , Just . runEncode $ PE.interval d
+        , Just . runEncode $ PE.numeric e
+        , Just . runEncode $ PE.timestamptz f
+        , Just . runEncode $ PE.uuid g
+        ]
+    parseMessage = Parse stmtName stmt oids
+    stmtName = StatementName "_pw_statement_0010"
+    stmt = StatementSQL 
+        "SELECT a, b, c FROM table_name WHERE name LIKE $1 AND a > $2"
+    oids = V.fromList $ map PGT.oidType
+        [ PGT.bool
+        , PGT.bytea
+        , PGT.float8
+        , PGT.interval
+        , PGT.numeric
+        , PGT.timestamptz
+        , PGT.uuid
+        ]
+
diff --git a/bench/Encoders.hs b/bench/Encoders.hs
diff --git a/postgres-wire.cabal b/postgres-wire.cabal
@@ -113,7 +113,24 @@ benchmark postgres-wire-bench
   hs-source-dirs:
       bench
   main-is: Bench.hs
-  other-modules:       Encoders
+  build-depends:       base
+                     , postgres-wire
+                     , bytestring
+                     , vector
+                     , postgresql-libpq
+                     , clock
+                     , optparse-applicative
+  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-s 
+  default-language:    Haskell2010
+  default-extensions:  
+    OverloadedStrings
+    GeneralizedNewtypeDeriving
+
+benchmark postgres-wire-bench-codecs
+  type: exitcode-stdio-1.0
+  hs-source-dirs:
+      bench
+  main-is: Codecs.hs
   build-depends:       base
                      , postgres-wire
                      , bytestring
@@ -123,6 +140,9 @@ benchmark postgres-wire-bench
                      , postgresql-libpq
                      , clock
                      , optparse-applicative
+                     , time
+                     , uuid
+                     , scientific
   ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-s 
   default-language:    Haskell2010
   default-extensions:  
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs b/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs
@@ -76,8 +76,8 @@ bsJsonBytes bs = putWord8 1 <> putByteString bs
 {-# INLINE numeric #-}
 numeric :: Scientific -> Encode
 numeric n = 
-    let (weight, scale, digits) = scientificToNumeric n
-    in    putWord16BE (fromIntegral $ length digits)
+    let (count, weight, scale, digits) = scientificToNumeric n
+    in    putWord16BE count
        <> putInt16BE weight
        <> putWord16BE (toNumericSign n)
        <> putWord16BE scale
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs b/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs
@@ -9,15 +9,16 @@ import Data.Scientific (Scientific, scientific, base10Exponent, coefficient)
 import Data.List       (unfoldr)
 
 {-# INLINE scientificToNumeric #-}
-scientificToNumeric :: Scientific -> (Int16, Word16, [Word16])
+scientificToNumeric :: Scientific -> (Word16, Int16, Word16, [Word16])
 scientificToNumeric number = 
     let a       = base10Exponent number `mod` nBaseDigits
         adjExp  = base10Exponent number - a
         adjCoef = coefficient number * (10 ^ a)
         digits  = integerToDigits $ abs adjCoef
-        weight  = fromIntegral $ length digits + adjExp `div` nBaseDigits - 1
+        count   = length digits
+        weight  = fromIntegral $ count + adjExp `div` nBaseDigits - 1
         scale   = fromIntegral . negate $ min (base10Exponent number) 0
-    in (weight, scale, digits)
+    in (fromIntegral count, weight, scale, digits)
 
 {-# INLINE numericToScientific #-}
 numericToScientific :: Integer -> Int16 -> [Word16] -> Scientific
