Add profiling

This commit is contained in:
Nikita Volkov 2017-04-14 00:46:59 +03:00
parent 22b5f8bb33
commit 52adc79907
3 changed files with 128 additions and 0 deletions

View File

@ -181,3 +181,24 @@ benchmark benchmarks
-- general:
bug == 1.*,
rerebase < 2
test-suite profiling
type:
exitcode-stdio-1.0
hs-source-dirs:
profiling
main-is:
Main.hs
ghc-options:
-O2
-threaded
-rtsopts
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:
Haskell2010
build-depends:
hasql,
bug == 1.*,
rerebase == 1.*

9
profile-events Executable file
View File

@ -0,0 +1,9 @@
#!/bin/bash
set -eo pipefail
cabal build profiling --ghc-options="-eventlog"
cd dist
build/profiling/profiling simple +RTS -N2 -ls -RTS
ghc-events-analyze --timed --bucket-width 2 --bucket-height 14 --ms --tick-every 10 --buckets 500 --window Session profiling.eventlog
open profiling.0.timed.svg
threadscope profiling.eventlog

98
profiling/Main.hs Normal file
View File

@ -0,0 +1,98 @@
module Main where
import Prelude
import Bug
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
traceEventIO "START Session"
Right result <- B.run sessionWithManySmallResults connection
traceEventIO "STOP Session"
return ()
where
acquireConnection =
A.acquire settings
where
settings =
A.settings host port user password database
where
host = "localhost"
port = 5432
user = "postgres"
password = ""
database = "postgres"
-- * 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