Skip to content

Commit

Permalink
write buffer micro bench: run different inputs
Browse files Browse the repository at this point in the history
  • Loading branch information
@mheinzel
mheinzel committed Apr 23, 2024
1 parent 0704add commit 4f6840f
Showing 1 changed file with 110 additions and 52 deletions.
162 changes: 110 additions & 52 deletions bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,21 +16,21 @@ module Bench.Database.LSMTree.Internal.WriteBuffer (benchmarks) where
import Control.DeepSeq (NFData (..))
import Criterion.Main (Benchmark, bench, bgroup)
import qualified Criterion.Main as Cr
import Data.Bifunctor (bimap)
import Data.Bifunctor (first)
import qualified Data.ByteString as BS
import qualified Data.List as List
import qualified Data.Primitive as P
import Data.WideWord.Word256
import Data.Word (Word64)
import Database.LSMTree.Extras.Orphans ()
import Database.LSMTree.Extras.Random (uniformWithoutReplacement)
import Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
import qualified Database.LSMTree.Internal.WriteBuffer as WB
import qualified Database.LSMTree.Internal.RawBytes as RB
import Database.LSMTree.Internal.Run (Run)
import qualified Database.LSMTree.Internal.Run as Run
import Database.LSMTree.Internal.Serialise
import qualified Database.LSMTree.Internal.Serialise.Class as Class
import Database.LSMTree.Internal.Vector (mkPrimVector)
import Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
import qualified Database.LSMTree.Internal.WriteBuffer as WB
import qualified Database.LSMTree.Normal as Normal
import GHC.Generics (Generic)
import Prelude hiding (getContents)
Expand All @@ -39,25 +39,55 @@ import qualified System.FS.API as FS
import qualified System.FS.IO as FS
import qualified System.FS.IO.Internal.Handle as FS (HandleOS (..))
import System.IO.Temp
import System.Random as R
import qualified System.Random as R
import System.Random (StdGen, Uniform, mkStdGen, uniform, uniformR)

benchmarks :: Benchmark
benchmarks = bgroup "Bench.Database.LSMTree.Internal.WriteBuffer" [
benchWriteBuffer defaultConfig
{ name = "2k"
, nentries = 2_000
benchWriteBuffer configWord64
{ name = "word64-2k"
, ninserts = 2_000
}
, benchWriteBuffer configWord64
{ name = "word64-10k"
, ninserts = 10_000
}
, benchWriteBuffer defaultConfig
{ name = "10k"
, nentries = 10_000
, benchWriteBuffer configWord64
{ name = "word64-50k"
, ninserts = 50_000
}
, benchWriteBuffer defaultConfig
{ name = "50k"
, nentries = 50_000
, benchWriteBuffer configUTxO
{ name = "utxo-2k"
, ninserts = 1_000
, ndeletes = 1_000
}
, benchWriteBuffer defaultConfig
{ name = "250k"
, nentries = 250_000
, benchWriteBuffer configUTxO
{ name = "utxo-10k"
, ninserts = 5_000
, ndeletes = 5_000
}
, benchWriteBuffer configUTxO
{ name = "utxo-50k"
, ninserts = 25_000
, ndeletes = 25_000
}
, benchWriteBuffer configUTxO
{ name = "utxo-2k-blob"
, ninserts = 500
, nblobinserts = 500
, ndeletes = 1_000
}
, benchWriteBuffer configUTxO
{ name = "utxo-10k-blob"
, ninserts = 2_500
, nblobinserts = 2_500
, ndeletes = 5_000
}
, benchWriteBuffer configUTxO
{ name = "utxo-50k-blob"
, ninserts = 12_500
, nblobinserts = 12_500
, ndeletes = 25_000
}
]

Expand Down Expand Up @@ -103,8 +133,6 @@ benchWriteBuffer conf@Config{name} =
cleanupPaths :: FS.HasFS IO FS.HandleIO -> IO ()
cleanupPaths hasFS = FS.removeDirectoryRecursive hasFS Run.activeRunsDir

-- TODO: allow multiple entry types/sizes
-- TODO: allow multiple distributions (blob or not, mupdate)
insert :: [SerialisedKOp] -> WriteBuffer SerialisedKey SerialisedValue SerialisedBlob
insert = List.foldl' (\wb (k, e) -> WB.addEntryNormal k e wb) WB.empty

Expand Down Expand Up @@ -140,13 +168,36 @@ data Config = Config {
-- | Name for the benchmark scenario described by this config.
name :: !String
-- | Number of key\/operation pairs in the run
, nentries :: !Int
, ninserts :: !Int
, nblobinserts :: !Int
, ndeletes :: !Int
, randomKey :: !(Rnd SerialisedKey)
, randomValue :: !(Rnd SerialisedValue)
, randomBlob :: !(Rnd SerialisedBlob)
}

defaultConfig :: Config
defaultConfig = Config {
name = "100k"
, nentries = 100_000
type Rnd a = StdGen -> (a, StdGen)

configWord64 :: Config
configWord64 = Config {
name = "utxo"
, ninserts = 0
, nblobinserts = 0
, ndeletes = 0
, randomKey = first serialiseKey . uniform @_ @Word64
, randomValue = first serialiseValue . uniform @_ @Word64
, randomBlob = (,) (SerialisedBlob mempty)
}

configUTxO :: Config
configUTxO = Config {
name = "utxo"
, ninserts = 0
, nblobinserts = 0
, ndeletes = 0
, randomKey = first serialiseKey . uniform @_ @UTxOKey
, randomValue = first serialiseValue . uniform @_ @UTxOValue
, randomBlob = first serialiseBlob . randomUTxOBlob
}

writeBufferEnv ::
Expand All @@ -155,10 +206,10 @@ writeBufferEnv ::
, FS.HasFS IO FS.HandleIO
, [SerialisedKOp]
)
writeBufferEnv Config {..} = do
writeBufferEnv config = do
sysTmpDir <- getCanonicalTemporaryDirectory
benchTmpDir <- createTempDirectory sysTmpDir "writeBufferEnv"
kops <- lookupsEnv (mkStdGen 17) nentries
let kops = lookupsEnv config (mkStdGen 17)
let hasFS = FS.ioHasFS (FS.MountPoint benchTmpDir)
pure (benchTmpDir, hasFS, kops)

Expand All @@ -174,18 +225,35 @@ writeBufferEnvCleanup (tmpDir, _, _) = do
-- | Generate keys and entries to insert into the write buffer.
-- They are already serialised to exclude the cost from the benchmark.
lookupsEnv ::
StdGen -- ^ RNG
-> Int -- ^ Number of stored key\/operation pairs
-> IO [SerialisedKOp]
lookupsEnv g nentries = do
let (g1, g2) = R.split g
let keys = uniformWithoutReplacement @UTxOKey g1 nentries
let ops = List.unfoldr (Just . randomEntry) g2
return $ zip
(map serialiseKey keys)
(map (bimap serialiseValue serialiseBlob) ops)

frequency :: [(Int, StdGen -> (a, StdGen))] -> StdGen -> (a, StdGen)
Config
-> StdGen -- ^ RNG
-> [SerialisedKOp]
lookupsEnv Config {..} = take nentries . List.unfoldr (Just . randomKOp)
where
nentries = ninserts + nblobinserts + ndeletes

randomKOp :: Rnd SerialisedKOp
randomKOp g = let (!k, !g') = randomKey g
(!e, !g'') = randomEntry g'
in ((k, e), g'')

randomEntry :: Rnd SerialisedEntry
randomEntry = frequency
[ ( ninserts
, \g -> let (!v, !g') = randomValue g
in (Normal.Insert v Nothing, g')
)
, ( nblobinserts
, \g -> let (!v, !g') = randomValue g
(!b, !g'') = randomBlob g'
in (Normal.Insert v (Just b), g'')
)
, ( ndeletes
, \g -> (Normal.Delete, g)
)
]

frequency :: [(Int, Rnd a)] -> Rnd a
frequency xs0 g
| any ((< 0) . fst) xs0 = error "frequency: frequencies must be non-negative"
| tot == 0 = error "frequency: at least one frequency should be non-zero"
Expand All @@ -198,17 +266,7 @@ frequency xs0 g
pick n ((k,x):xs)
| n <= k = x g'
| otherwise = pick (n-k) xs
pick _ _ = error "QuickCheck.pick used with empty list"

-- TODO: tweak distribution
randomEntry :: StdGen -> (Normal.Update UTxOValue UTxOBlob, StdGen)
randomEntry = frequency [
(20, \g' -> let (!v, !g'') = uniform g' in (Normal.Insert v Nothing, g''))
, (1, \g' -> let (!v, !g'') = uniform g'
(!b, !g''') = genBlob g''
in (Normal.Insert v (Just b), g'''))
, (2, \g' -> (Normal.Delete, g'))
]
pick _ _ = error "frequency: pick used with empty list"

{-------------------------------------------------------------------------------
UTxO keys, values and blobs
Expand Down Expand Up @@ -258,8 +316,8 @@ instance SerialiseValue UTxOBlob where
deserialiseValue = error "deserialiseValue: unused"
deserialiseValueN = error "deserialiseValueN: unused"

genBlob :: RandomGen g => g -> (UTxOBlob, g)
genBlob !g =
randomUTxOBlob :: Rnd UTxOBlob
randomUTxOBlob !g =
let (!len, !g') = uniformR (0, 0x2000) g
(!bs, !g'') = genByteString len g'
(!bs, !g'') = R.genByteString len g'
in (UTxOBlob bs, g'')

0 comments on commit 4f6840f

Please sign in to comment.