diff --git a/.hlint.yaml b/.hlint.yaml index 18700427f..f760be4f9 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -40,6 +40,7 @@ - ignore: {name: "Use notElem"} - ignore: {name: "Use elem"} - ignore: {name: "Use infix"} +- ignore: {name: "Redundant pure"} # Specify additional command line arguments # diff --git a/app/Database/LSMTree/Demo.hs b/app/Database/LSMTree/Demo.hs new file mode 100644 index 000000000..5aa5f3c2b --- /dev/null +++ b/app/Database/LSMTree/Demo.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} + +{- HLINT ignore "Redundant pure" -} + +module Database.LSMTree.Demo (demo) where + +import Control.Exception (SomeException, try) +import Control.Monad (when) +import Control.Monad.Class.MonadST (MonadST (..)) +import qualified Control.Monad.IOSim as IOSim +import Control.Monad.Primitive (RealWorld) +import Control.Monad.ST.Unsafe (unsafeIOToST) +import Control.Tracer (nullTracer) +import Data.Functor (void) +import Data.Primitive.PrimVar (PrimVar, newPrimVar, readPrimVar, + writePrimVar) +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Data.Word (Word64) +import Database.LSMTree as LSMT +import qualified System.Directory as IO (createDirectoryIfMissing, + doesDirectoryExist, removeDirectoryRecursive) +import qualified System.FS.API as FS +import qualified System.FS.BlockIO.API as FS +import qualified System.FS.BlockIO.IO as FS +import qualified System.FS.BlockIO.Sim as FSSim +import qualified System.FS.IO as FS +import qualified System.FS.Sim.MockFS as FSSim +import System.IO.Unsafe (unsafePerformIO) + +-- | Interactive demo showing functional requiremens for the @lsm-tree@ library +-- are met. +-- +-- The functional requirements are discussed in this document: "Storing the +-- Cardano ledger state on disk: final report for high-performance backend" +-- +-- Sections of the demo code are headed by the number of the corresponding +-- functional requirement. +demo :: IO () +demo = do + freshDirectory "_demo" + withOpenSessionIO tracer "_demo" $ \session -> do + withTableWith config session $ \(table :: Table IO K V B) -> do + pause -- [0] + + -- 2. basic key-value store operations + + inserts table $ V.fromList [ (K i, V i, Just (B i)) | i <- [1 .. 10_000] ] + as <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ] + print (fmap getValue as) + pause -- [1] + + deletes table $ V.fromList [ K i | i <- [1 .. 10_000], even i ] + bs <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ] + print (fmap getValue bs) + pause -- [2] + + -- 2. Intermezzo: blob retrieval + + cs <- try @SomeException $ retrieveBlobs session $ V.mapMaybe getBlob as + print cs + pause -- [3] + + ds <- try @SomeException $ retrieveBlobs session $ V.mapMaybe getBlob bs + print ds + pause -- [4] + + -- 3. range lookups and cursors + + es <- rangeLookup table $ FromToIncluding (K 1) (K 4) + print (fmap getEntryValue es) + pause -- [5] + + withCursorAtOffset table (K 1) $ \cursor -> do + fs <- LSMT.take 2 cursor + print (fmap getEntryValue fs) + pause -- [6] + + -- 4. upserts (or monoidal updates) + + -- better than lookup followed by insert + upserts table $ V.fromList [ (K i, V 1) | i <- [1 .. 10_000] ] + gs <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ] + print (fmap getValue gs) + pause -- [7] + + -- 5. multiple independently writable references + + withDuplicate table $ \dupliTable -> do + inserts dupliTable $ V.fromList [ (K i, V 1, Nothing) | i <- [1 .. 10_000] ] + hs <- lookups dupliTable $ V.fromList [ K 1, K 2, K 3, K 4 ] + print (fmap getValue hs) + pause -- [8] + + is <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4] + print (fmap getValue is) + pause -- [9] + + -- 6. snapshots + + saveSnapshot "odds_evens" label table + saveSnapshot "all_ones" label dupliTable + js <- listSnapshots session + print js + pause -- [10] + + -- 6. snapshots continued + + withTableFromSnapshot session "odds_evens" label $ \(table :: Table IO K V B) -> do + withTableFromSnapshot session "all_ones" label $ \(dupliTable :: Table IO K V B) -> do + pause -- [11] + + -- 7. table unions + + withUnion table dupliTable $ \uniTable -> do + ks <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4] + print (fmap getValue ks) + pause -- [12] + + withIncrementalUnion table dupliTable $ \uniTable -> do + ls <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4] + print (fmap getValue ls) + pause -- [13] + + m@(UnionDebt m') <- remainingUnionDebt uniTable + supplyUnionCredits uniTable (UnionCredits (m' `div` 2)) + print m + pause -- [14] + + ns <- lookups uniTable $ V.fromList [ K 1, K 2, K 3, K 4] + print (fmap getValue ns) + pause -- [15] + + -- 8. simulation + + let + simpleAction :: + (LSMT.IOLike m, Typeable h) + => FS.HasFS m h -> FS.HasBlockIO m h -> m () + simpleAction hasFS hasBlockIO = do + let sessionDir = FS.mkFsPath ["_demo"] + FS.createDirectoryIfMissing hasFS False sessionDir + withOpenSession tracer hasFS hasBlockIO 17 sessionDir $ \session -> do + withTableWith config session $ \(table :: Table m K V B) -> do + inserts table $ V.fromList [ (K i, V i, Just (B i)) | i <- [1 .. 10_000] ] + os <- lookups table $ V.fromList [ K 1, K 2, K 3, K 4 ] + print' (fmap getValue os) + + do + let hasFS = FS.ioHasFS (FS.MountPoint "") + FS.withIOHasBlockIO hasFS FS.defaultIOCtxParams $ \hasBlockIO -> do + simpleAction hasFS hasBlockIO + pause -- [16] + + do + pure $! IOSim.runSimOrThrow $ do + (hasFS, hasBlockIO) <- FSSim.simHasBlockIO' FSSim.empty + simpleAction hasFS hasBlockIO + pause -- [17] + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +newtype K = K Word64 + deriving stock (Show, Eq) + deriving newtype SerialiseKey + +newtype V = V Word64 + deriving stock (Show, Eq) + deriving newtype (Num, SerialiseValue) +instance ResolveValue V where + resolve = (+) + +newtype B = B Word64 + deriving stock (Show, Eq) + deriving newtype (Num, SerialiseValue) + +config :: TableConfig +config = defaultTableConfig { + confWriteBufferAlloc = AllocNumEntries 172 + } + +tracer :: Monad m => Tracer m LSMTreeTrace +tracer = nullTracer + +label :: SnapshotLabel +label = "KVB" + +{------------------------------------------------------------------------------- + Utils +-------------------------------------------------------------------------------} + +{-# NOINLINE pauseRef #-} +pauseRef :: PrimVar RealWorld Int +pauseRef = unsafePerformIO $ newPrimVar 0 + +incrPauseRef :: IO Int +incrPauseRef = do + x <- readPrimVar pauseRef + writePrimVar pauseRef $! x + 1 + pure x + +pause :: IO () +pause = do + x <- incrPauseRef + putStr ("[" <> show x <> "] " <> "press ENTER to continue...") + void $ getLine + +freshDirectory :: FilePath -> IO () +freshDirectory path = do + b <- IO.doesDirectoryExist path + when b $ IO.removeDirectoryRecursive path + IO.createDirectoryIfMissing False path + +print' :: (Show a, MonadST m) => a -> m () +print' x = stToIO $ unsafeIOToST $ print x diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 000000000..445c1823d --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Database.LSMTree.Demo (demo) +import System.IO (BufferMode (..), hSetBuffering, stdout) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + demo diff --git a/bench/macro/utxo-bench.hs b/bench/macro/utxo-bench.hs index 4fe14a124..132502cdf 100644 --- a/bench/macro/utxo-bench.hs +++ b/bench/macro/utxo-bench.hs @@ -447,7 +447,7 @@ doSetup' gopts opts = do hasBlockIO <- FsIO.ioHasBlockIO hasFS FS.defaultIOCtxParams - let name = LSM.toSnapshotName "bench" + let name = LSM.toSnapshotName ("bench_" ++ show (initialSize gopts)) LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session -> do tbl <- LSM.newTableWith @IO @K @V @B (mkTableConfigSetup gopts opts benchTableConfig) session diff --git a/lsm-tree.cabal b/lsm-tree.cabal index ceaebb1ee..7828b5902 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -992,6 +992,7 @@ benchmark lsm-tree-bench-lookups library mcg import: language, warnings, wno-x-partial + visibility: private hs-source-dirs: src-mcg exposed-modules: MCG build-depends: @@ -1091,6 +1092,7 @@ benchmark utxo-rocksdb-bench library rocksdb import: language, warnings + visibility: private hs-source-dirs: src-rocksdb exposed-modules: RocksDB other-modules: RocksDB.FFI @@ -1107,6 +1109,7 @@ library rocksdb library kmerge import: language, warnings, wno-x-partial + visibility: private hs-source-dirs: src-kmerge exposed-modules: KMerge.Heap @@ -1171,6 +1174,7 @@ test-suite map-range-test library prototypes import: language, warnings, wno-x-partial + visibility: private hs-source-dirs: src-prototypes exposed-modules: FormatPage @@ -1215,6 +1219,7 @@ test-suite prototypes-test library control import: language, warnings + visibility: private hs-source-dirs: src-control exposed-modules: Control.ActionRegistry @@ -1247,3 +1252,25 @@ test-suite control-test , QuickCheck , tasty , tasty-quickcheck + +executable demo + import: language, warnings + scope: private + hs-source-dirs: app + main-is: Main.hs + other-modules: Database.LSMTree.Demo + build-depends: + , base <5 + , blockio + , blockio:sim + , contra-tracer + , directory + , fs-api + , fs-sim + , io-classes + , io-sim + , lsm-tree + , primitive + , vector + + ghc-options: -threaded diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 4b2fb4eac..d61da062f 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -45,6 +45,9 @@ module Database.LSMTree ( lookup, lookups, Entry (..), + getEntryKey, + getEntryValue, + getEntryBlob, rangeLookup, -- ** Table Updates #table_updates# @@ -1089,6 +1092,27 @@ data Entry k v b | EntryWithBlob !k !v !b deriving stock (Eq, Show, Functor, Foldable, Traversable) +{- | +Get the field of type @k@ from an @'Entry' k v b@. +-} +getEntryKey :: Entry k v b -> k +getEntryKey (Entry !k !_v) = k +getEntryKey (EntryWithBlob !k !_v !_b) = k + +{- | +Get the field of type @v@ from an @'Entry' k v b@. +-} +getEntryValue :: Entry k v b -> v +getEntryValue (Entry !_k !v) = v +getEntryValue (EntryWithBlob !_k !v !_b) = v + +{- | +Get the field of type @b@ from an @'Entry' k v b@, if any. +-} +getEntryBlob :: Entry k v b -> Maybe b +getEntryBlob (Entry !_k !_v) = Nothing +getEntryBlob (EntryWithBlob !_k !_v !b) = Just b + instance (NFData k, NFData v, NFData b) => NFData (Entry k v b) where rnf :: Entry k v b -> () rnf = \case