more wip

bench/macro/lsm-tree-bench-wp8.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE NoFieldSelectors    #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors      #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 {- Benchmark requirements:
 
@@ -38,16 +39,22 @@ module Main (main) where
 
 import           Control.Applicative ((<**>))
 import           Control.Exception (bracket)
-import           Control.Monad (forM_)
+import           Control.Monad (forM_, void, when)
 import qualified Crypto.Hash.SHA256 as SHA256
 import qualified Data.Binary as B
 import qualified Data.ByteString as BS
+import qualified Data.IntSet as IS
+import           Data.IORef (newIORef, readIORef, writeIORef)
+import           Data.Traversable (mapAccumL)
+import           Data.Tuple (swap)
 import           Data.Void (Void)
 import           Data.Word (Word64)
 import qualified Options.Applicative as O
 import qualified System.Clock as Clock
 import qualified System.FS.API as FS
 import qualified System.FS.IO as FsIO
+import qualified System.Random.SplitMix as SM
+import           Text.Printf (printf)
 
 -- We should be able to write this benchmark
 -- using only use public lsm-tree interface
@@ -80,12 +87,18 @@ theValue = BS.replicate 60 120 -- 'x'
 -------------------------------------------------------------------------------
 
 data GlobalOpts = GlobalOpts
-    { rootDir :: FilePath  -- ^ session directory.
+    { rootDir     :: FilePath  -- ^ session directory.
+    , initialSize :: Int
     }
   deriving Show
 
 data SetupOpts = SetupOpts
-    { size :: Int
+    { size :: Int -- TODO remove
+    }
+  deriving Show
+
+data RunOpts = RunOpts
+    { batches :: Int
     }
   deriving Show
 
@@ -94,10 +107,10 @@ data Cmd
     = CmdSetup SetupOpts
 
     -- | Make a dry run, measure the overhead.
-    | CmdDryRun
+    | CmdDryRun RunOpts
 
     -- | Run the actual benchmark
-    | CmdRun
+    | CmdRun RunOpts
   deriving Show
 
 -------------------------------------------------------------------------------
@@ -107,20 +120,25 @@ data Cmd
 globalOptsP :: O.Parser GlobalOpts
 globalOptsP = pure GlobalOpts
     <*> pure "_bench_session"
+    <*> pure 100_000 -- _000
 
 cmdP :: O.Parser Cmd
 cmdP = O.subparser $ mconcat
     [ O.command "setup" $ O.info
         (CmdSetup <$> setupOptsP <**> O.helper)
         (O.progDesc "Setup benchmark")
     , O.command "dry-run" $ O.info
-        (pure CmdDryRun <**> O.helper)
+        (CmdDryRun <$> runOptsP <**> O.helper)
         (O.progDesc "Dry run, measure overhead")
     ]
 
 setupOptsP :: O.Parser SetupOpts
 setupOptsP = pure SetupOpts
-    <*> pure 1000 -- TODO: change to 100e6
+    <*> pure 10000 -- TODO: change to 100e6
+
+runOptsP :: O.Parser RunOpts
+runOptsP = pure RunOpts
+    <*> pure 100
 
 -------------------------------------------------------------------------------
 -- clock
@@ -147,7 +165,7 @@ timed_ action = do
 
 -- https://input-output-hk.github.io/fs-sim
 doSetup :: GlobalOpts -> SetupOpts -> IO ()
-doSetup gopts opts = do
+doSetup gopts _opts = do
     let mountPoint :: FS.MountPoint
         mountPoint = FS.MountPoint gopts.rootDir
 
@@ -160,7 +178,7 @@ doSetup gopts opts = do
     withSession someFs (FS.mkFsPath []) $ \session -> do
         tbh <- LSM.new @IO @K @V @B session defaultTableConfig
 
-        forM_ [ 1 .. opts.size ] $ \ (fromIntegral -> i) -> do
+        forM_ [ 0 .. gopts.initialSize ] $ \ (fromIntegral -> i) -> do
             -- TODO: this procedure simply inserts all the keys into initial lsm tree
             -- We might want to do deletes, so there would be delete-insert pairs
             -- Let's do that when we can actually test that benchmark works.
@@ -179,9 +197,41 @@ doSetup gopts opts = do
 -- dry-run
 -------------------------------------------------------------------------------
 
-doDryRun :: GlobalOpts -> IO ()
-doDryRun _gopts = return ()
-    -- TODO: open session
+batchSize :: Int
+batchSize = 16
+
+check :: Bool
+check = True
+
+doDryRun :: GlobalOpts -> RunOpts -> IO ()
+doDryRun gopts opts = do
+    -- TODO: open session to measure that as well.
+    let initGen = SM.mkSMGen 42 -- TODO: configurable seed?
+
+    keysRef <- newIORef $ if check then IS.fromList [ 0 .. gopts.initialSize - 1 ] else IS.empty
+
+    void $ forFoldM_ initGen [ 0 .. opts.batches - 1 ] $ \b g -> do
+        -- how many keys there are
+        let maxK :: Word64
+            maxK = fromIntegral $ gopts.initialSize + batchSize * b
+
+        let lookups :: [Word64]
+            (!nextG, lookups) = mapAccumL (\g' _ -> swap (SM.bitmaskWithRejection64 maxK g')) g [1 .. batchSize]
+
+            inserts :: [Word64]
+            inserts = [ maxK .. maxK + fromIntegral batchSize - 1 ]
+
+        print lookups
+        print inserts
+        when check $ do
+            keys <- readIORef keysRef
+            let new = IS.fromList $ map fromIntegral lookups
+            printf "missing in batch %d %s\n" b (show (IS.difference new keys))
+            writeIORef keysRef $! IS.union
+                (IS.difference keys new)
+                (IS.fromList $ map fromIntegral inserts)
+
+        return nextG
 
 {-
 implement generation of unbounded sequence of insert/delete operations
@@ -191,6 +241,14 @@ configurable batch sizes
 1 insert, 1 delete, 1 lookup per key.
 -}
 
+-------------------------------------------------------------------------------
+-- run
+-------------------------------------------------------------------------------
+
+doRun :: GlobalOpts -> RunOpts -> IO ()
+doRun _gopts _opts = return ()
+    -- TODO: open session
+
 -------------------------------------------------------------------------------
 -- main
 -------------------------------------------------------------------------------
@@ -201,9 +259,9 @@ main = do
     print gopts
     print cmd
     case cmd of
-        CmdSetup opts -> doSetup gopts opts
-        CmdDryRun     -> doDryRun gopts
-        CmdRun        -> return () -- TODO
+        CmdSetup opts  -> doSetup gopts opts
+        CmdDryRun opts -> doDryRun gopts opts
+        CmdRun opts    -> doRun gopts opts
   where
     cliP = O.info ((,) <$> globalOptsP <*> cmdP <**> O.helper) O.fullDesc
     prefs = O.prefs O.showHelpOnEmpty
@@ -233,3 +291,9 @@ _unused = const ()
     , timed
     , timed_
     )
+
+forFoldM_ :: Monad m => s -> [a] -> (a -> s -> m s) -> m s
+forFoldM_ !s []     _ = return s
+forFoldM_ !s (x:xs) f = do
+    !s' <- f x s
+    forFoldM_ s' xs f

lsm-tree.cabal

@@ -339,25 +339,27 @@ benchmark lsm-tree-macro-bench
   ghc-options:    -rtsopts -with-rtsopts=-T -threaded
 
 benchmark lsm-tree-bench-wp8
-  import:           language, warnings, wno-x-partial
-  type:             exitcode-stdio-1.0
-  hs-source-dirs:   bench/macro src-extras
-  main-is:          lsm-tree-bench-wp8.hs
-  other-modules:    Database.LSMTree.Extras.Orphans
+  import:         language, warnings, wno-x-partial
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: bench/macro src-extras
+  main-is:        lsm-tree-bench-wp8.hs
+  other-modules:  Database.LSMTree.Extras.Orphans
   build-depends:
     , base
     , binary
     , bytestring
     , clock
+    , containers
     , cryptohash-sha256
     , fs-api
     , lsm-tree
     , optparse-applicative
     , primitive
     , random
+    , splitmix
     , wide-word
 
-  ghc-options:      -rtsopts -with-rtsopts=-T -threaded
+  ghc-options:    -rtsopts -with-rtsopts=-T -threaded
 
 library kmerge
   import:          language, warnings, wno-x-partial