New benchmarks

benchmark/Main.hs

@@ -1,53 +0,0 @@
-module Main where
-
-import Main.Prelude
-import Criterion.Main
-import qualified Hasql.Connection as HC
-import qualified Hasql.Query as HQ
-import qualified Hasql.Encoders as HE
-import qualified Hasql.Decoders as HD
-import qualified Hasql.Session
-import qualified Main.Queries as Q
-
-
-main =
-  HC.acquire settings >>= either (fail . show) use
-  where
-    settings =
-      HC.settings host port user password database
-      where
-        host = "localhost"
-        port = 5432
-        user = "postgres"
-        password = ""
-        database = "postgres"
-    use connection =
-      defaultMain
-      [
-        bgroup "decoding"
-        [
-          bgroup "1 column"
-          [
-            bench "1 row" $ nfIO $! query () $! Q.select1 1
-            ,
-            bench "100 rows" $ nfIO $! query () $! Q.select1 100
-            ,
-            bench "10000 rows" $ nfIO $! query () $! Q.select1 10000
-          ]
-          ,
-          bgroup "4 columns"
-          [
-            bench "1 row" $ nfIO $! query () $! Q.select4 1
-            ,
-            bench "100 rows" $ nfIO $! query () $! Q.select4 100
-            ,
-            bench "10000 rows" $ nfIO $! query () $! Q.select4 10000
-          ]
-        ]
-      ]
-      where
-        query :: a -> HQ.Query a b -> IO b
-        query params query =
-          {-# SCC "query" #-} 
-          (=<<) (either (fail . show) pure) $
-          flip Hasql.Session.run connection $ Hasql.Session.query params query

benchmark/Main/Prelude.hs

@@ -1,65 +0,0 @@
-module Main.Prelude
-(
-  module Exports,
-)
-where
-
-
--- base-prelude
--------------------------
-import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)
-
--- transformers
--------------------------
-import Control.Monad.IO.Class as Exports
-import Control.Monad.Trans.Class as Exports
-import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass)
-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)
-import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
-import Data.Functor.Identity as Exports
-
--- data-default-class
--------------------------
-import Data.Default.Class as Exports
-
--- profunctors
--------------------------
-import Data.Profunctor.Unsafe as Exports
-
--- contravariant
--------------------------
-import Data.Functor.Contravariant as Exports
-import Data.Functor.Contravariant.Divisible as Exports
-
--- contravariant-extras
--------------------------
-import Contravariant.Extras as Exports
-
--- either
--------------------------
-import Control.Monad.Trans.Either as Exports
-import Data.Either.Combinators as Exports
-
--- hashable
--------------------------
-import Data.Hashable as Exports (Hashable(..))
-
--- text
--------------------------
-import Data.Text as Exports (Text)
-
--- bytestring
--------------------------
-import Data.ByteString as Exports (ByteString)
-
--- vector
--------------------------
-import Data.Vector as Exports (Vector)
-
--- dlist
--------------------------
-import Data.DList as Exports (DList)
-
--- deepseq
--------------------------
-import Control.DeepSeq as Exports (NFData(..), force, deepseq, ($!!))

benchmark/Main/Queries.hs

@@ -1,29 +0,0 @@
-module Main.Queries where
-
-import Main.Prelude
-import qualified Hasql.Query as HQ
-import qualified Hasql.Encoders as HE
-import qualified Hasql.Decoders as HD
-
-
-select1 :: Int -> HQ.Query () (Vector Int64)
-select1 amount =
-  {-# SCC "select1" #-} 
-  HQ.statement sql mempty decoder True
-  where
-    !sql =
-      "values " <>
-      mconcat (intersperse ", " (replicate amount "(1)"))
-    decoder =
-      HD.rowsVector (HD.value HD.int8)
-
-select4 :: Int -> HQ.Query () (Vector (Int64, Int64, Int64, Int64))
-select4 amount =
-  {-# SCC "select4" #-} 
-  HQ.statement sql mempty decoder True
-  where
-    !sql =
-      "values " <>
-      mconcat (intersperse ", " (replicate amount "(1, 2, 3, 4)"))
-    decoder =
-      HD.rowsVector ((,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8)

benchmarks/Main.hs

@@ -0,0 +1,110 @@
+module Main where
+
+import Prelude
+import Bug
+import Criterion
+import Criterion.Main
+import qualified Hasql.Connection as A
+import qualified Hasql.Session as B
+import qualified Hasql.Query as C
+import qualified Hasql.Decoders as D
+import qualified Hasql.Encoders as E
+import qualified Data.Vector as F
+
+
+main =
+  do
+    Right connection <- acquireConnection
+    useConnection connection
+  where
+    acquireConnection =
+      A.acquire settings
+      where
+        settings =
+          A.settings host port user password database
+          where
+            host = "localhost"
+            port = 5432
+            user = "postgres"
+            password = ""
+            database = "postgres"
+    useConnection connection =
+      defaultMain
+      [
+        sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector
+        ,
+        sessionBench "largeResultInList" sessionWithSingleLargeResultInList
+        ,
+        sessionBench "manySmallResults" sessionWithManySmallResults
+      ]
+      where
+        sessionBench :: NFData a => String -> B.Session a -> Benchmark
+        sessionBench name session =
+          bench name (nfIO (fmap (either ($bug "") id) (B.run session connection)))
+
+
+-- * Sessions
+-------------------------
+
+sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
+sessionWithManySmallParameters =
+  $(todo "sessionWithManySmallParameters")
+
+sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64))
+sessionWithSingleLargeResultInVector =
+  B.query () queryWithManyRowsInVector
+
+sessionWithSingleLargeResultInList :: B.Session (List (Int64, Int64))
+sessionWithSingleLargeResultInList =
+  B.query () queryWithManyRowsInList
+
+sessionWithManySmallResults :: B.Session (Vector (Int64, Int64))
+sessionWithManySmallResults =
+  F.replicateM 1000 (B.query () queryWithSingleRow)
+
+
+-- * Statements
+-------------------------
+
+queryWithManyParameters :: C.Query (Vector (Int64, Int64)) ()
+queryWithManyParameters =
+  $(todo "statementWithManyParameters")
+
+queryWithSingleRow :: C.Query () (Int64, Int64)
+queryWithSingleRow =
+  C.statement template encoder decoder True
+  where
+    template =
+      "SELECT 1, 2"
+    encoder =
+      conquer
+    decoder =
+      D.singleRow row
+      where
+        row =
+          tuple <$> D.value D.int8 <*> D.value D.int8
+          where
+            tuple !a !b =
+              (a, b)
+
+queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
+queryWithManyRows decoder =
+  C.statement template encoder (decoder rowDecoder) True
+  where
+    template =
+      "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"
+    encoder =
+      conquer
+    rowDecoder =
+      tuple <$> D.value D.int8 <*> D.value D.int8
+      where
+        tuple !a !b =
+          (a, b)
+
+queryWithManyRowsInVector :: C.Query () (Vector (Int64, Int64))
+queryWithManyRowsInVector =
+  queryWithManyRows D.rowsVector
+
+queryWithManyRowsInList :: C.Query () (List (Int64, Int64))
+queryWithManyRowsInList =
+  queryWithManyRows D.rowsList

hasql.cabal

@@ -158,25 +158,18 @@ test-suite threads-test
     rebase
 
 
-benchmark benchmark
+benchmark benchmarks
   type: 
     exitcode-stdio-1.0
   hs-source-dirs:
-    benchmark
+    benchmarks
   main-is:
     Main.hs
-  other-modules:
-    Main.Queries
-    Main.Prelude
   ghc-options:
     -O2
     -threaded
     "-with-rtsopts=-N"
-  ghc-prof-options:
-    -O2
-    -threaded
-    -fprof-auto
-    "-with-rtsopts=-N -p -s -h -i0.1"
+    -funbox-strict-fields
   default-extensions:
     Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
   default-language:
@@ -184,24 +177,7 @@ benchmark benchmark
   build-depends:
     hasql,
     -- benchmarking:
-    criterion == 1.1.*,
-    -- data:
-    uuid,
-    time,
-    scientific,
-    bytestring,
-    text,
-    vector,
-    hashable,
-    dlist,
+    criterion >= 1.1 && < 2,
     -- general:
-    deepseq >= 1 && < 2,
-    data-default-class,
-    profunctors,
-    contravariant,
-    contravariant-extras,
-    either,
-    transformers,
-    base-prelude,
-    base
-
+    bug == 1.*,
+    rerebase < 2