From 4d1e2b62dbe195b960fa189419edc769a66916fa Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Sat, 22 Mar 2025 23:57:59 +0100 Subject: [PATCH] Allow overriding the disk cache policy (feature restored) Since #608, using a `TableConfigOverride` when opening a snapshot has no effect. This commit restores the feature that we can change the disk cache policy on snapshot open. Internally, instead of threading through a modified config to open the snapshot, we modify the whole `SnapshotMetaData` (replacing the disk cache policy everywhere) and open the snapshot from that modified metadata. A first idea we had was to modify a table config while its table is live, but there are some challenges. Changing a table config when the table is offline seem to be more straightforward, so that's the approach we took (for now). An explanation of the challenges can be found in the `*.Config.Override` module. --- bench/macro/lsm-tree-bench-wp8.hs | 7 +- lsm-tree.cabal | 1 + src/Database/LSMTree.hs | 22 ++- src/Database/LSMTree/Common.hs | 8 +- src/Database/LSMTree/Internal.hs | 18 +- src/Database/LSMTree/Internal/Config.hs | 57 +----- .../LSMTree/Internal/Config/Override.hs | 162 ++++++++++++++++++ src/Database/LSMTree/Internal/Snapshot.hs | 3 - src/Database/LSMTree/Monoidal.hs | 17 +- src/Database/LSMTree/Normal.hs | 17 +- test/Database/LSMTree/Class.hs | 2 +- .../Database/LSMTree/Internal/Snapshot/FS.hs | 4 +- test/Test/Database/LSMTree/UnitTests.hs | 8 +- 13 files changed, 218 insertions(+), 108 deletions(-) create mode 100644 src/Database/LSMTree/Internal/Config/Override.hs diff --git a/bench/macro/lsm-tree-bench-wp8.hs b/bench/macro/lsm-tree-bench-wp8.hs index 4ba143e2c..64238c6b6 100644 --- a/bench/macro/lsm-tree-bench-wp8.hs +++ b/bench/macro/lsm-tree-bench-wp8.hs @@ -183,9 +183,8 @@ mkTableConfigRun GlobalOpts{diskCachePolicy} conf = conf { LSM.confDiskCachePolicy = diskCachePolicy } -mkTableConfigOverride :: GlobalOpts -> LSM.TableConfigOverride -mkTableConfigOverride GlobalOpts{diskCachePolicy} = - LSM.configOverrideDiskCachePolicy diskCachePolicy +mkOverrideDiskCachePolicy :: GlobalOpts -> LSM.OverrideDiskCachePolicy +mkOverrideDiskCachePolicy GlobalOpts{diskCachePolicy} = LSM.OverrideDiskCachePolicy diskCachePolicy mkTracer :: GlobalOpts -> Tracer IO LSM.LSMTreeTrace mkTracer gopts @@ -583,7 +582,7 @@ doRun gopts opts = do -- necessary for testing to load the whole snapshot). tbl <- if check opts then LSM.new @IO @K @V @B session (mkTableConfigRun gopts benchTableConfig) - else LSM.openSnapshot @IO @K @V @B session (mkTableConfigOverride gopts) label name + else LSM.openSnapshot @IO @K @V @B session (mkOverrideDiskCachePolicy gopts) label name -- In checking mode, compare each output against a pure reference. checkvar <- newIORef $ pureReference diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 095b0d567..435fd105a 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -241,6 +241,7 @@ library Database.LSMTree.Internal.ChecksumHandle Database.LSMTree.Internal.Chunk Database.LSMTree.Internal.Config + Database.LSMTree.Internal.Config.Override Database.LSMTree.Internal.CRC32C Database.LSMTree.Internal.Cursor Database.LSMTree.Internal.Entry diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 50a0e39ca..88335d266 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -88,9 +88,7 @@ module Database.LSMTree ( , Common.SnapshotLabel (..) , createSnapshot , openSnapshot - , Common.TableConfigOverride - , Common.configNoOverride - , Common.configOverrideDiskCachePolicy + , Common.OverrideDiskCachePolicy (..) , deleteSnapshot , listSnapshots @@ -142,6 +140,7 @@ import qualified Database.LSMTree.Internal.BlobRef as Internal import qualified Database.LSMTree.Internal.Entry as Entry import qualified Database.LSMTree.Internal.RawBytes as RB import qualified Database.LSMTree.Internal.Serialise as Internal +import qualified Database.LSMTree.Internal.Snapshot as Internal import qualified Database.LSMTree.Internal.Vector as V import Database.LSMTree.Monoidal (ResolveValue (..), resolveDeserialised, resolveValueAssociativity, @@ -501,12 +500,12 @@ createSnapshot :: forall m k v b. -> Table m k v b -> m () createSnapshot label snap (Internal.Table' t) = - void $ Internal.createSnapshot snap label Common.SnapFullTable t + void $ Internal.createSnapshot snap label Internal.SnapFullTable t {-# SPECIALISE openSnapshot :: ResolveValue v => Session IO - -> Common.TableConfigOverride + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> IO (Table IO k v b ) #-} @@ -515,12 +514,19 @@ openSnapshot :: forall m k v b. , ResolveValue v ) => Session m - -> Common.TableConfigOverride -- ^ Optional config override + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> m (Table m k v b) -openSnapshot (Internal.Session' sesh) override label snap = - Internal.Table' <$!> Internal.openSnapshot sesh label Common.SnapFullTable override snap (resolve (Proxy @v)) +openSnapshot (Internal.Session' sesh) policyOveride label snap = + Internal.Table' <$!> + Internal.openSnapshot + sesh + policyOveride + label + Internal.SnapFullTable + snap + (resolve (Proxy @v)) {------------------------------------------------------------------------------- Mutiple writable tables diff --git a/src/Database/LSMTree/Common.hs b/src/Database/LSMTree/Common.hs index a45a7556e..3d59c610c 100644 --- a/src/Database/LSMTree/Common.hs +++ b/src/Database/LSMTree/Common.hs @@ -35,7 +35,6 @@ module Database.LSMTree.Common ( , Internal.Range (..) -- * Snapshots , Internal.SnapshotLabel (..) - , Internal.SnapshotTableType (..) , deleteSnapshot , listSnapshots -- ** Snapshot names @@ -57,10 +56,8 @@ module Database.LSMTree.Common ( , Internal.DiskCachePolicy (..) , Internal.MergeSchedule (..) , Internal.defaultMergeSchedule - -- * Table configuration override - , Internal.TableConfigOverride - , Internal.configNoOverride - , Internal.configOverrideDiskCachePolicy + -- ** Override + , Internal.OverrideDiskCachePolicy (..) -- * Unions , UnionDebt (..) , UnionCredits (..) @@ -78,6 +75,7 @@ import Data.Typeable (Typeable) import qualified Database.LSMTree.Internal as Internal import qualified Database.LSMTree.Internal.BlobRef as Internal import qualified Database.LSMTree.Internal.Config as Internal +import qualified Database.LSMTree.Internal.Config.Override as Internal import qualified Database.LSMTree.Internal.Entry as Internal import qualified Database.LSMTree.Internal.MergeSchedule as Internal import Database.LSMTree.Internal.Paths (SnapshotName) diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs index b1431e53c..c36bb68b4 100644 --- a/src/Database/LSMTree/Internal.hs +++ b/src/Database/LSMTree/Internal.hs @@ -120,6 +120,8 @@ import Database.LSMTree.Internal.Arena (ArenaManager, newArenaManager) import Database.LSMTree.Internal.BlobRef (WeakBlobRef (..)) import qualified Database.LSMTree.Internal.BlobRef as BlobRef import Database.LSMTree.Internal.Config +import Database.LSMTree.Internal.Config.Override + (OverrideDiskCachePolicy, overrideDiskCachePolicy) import Database.LSMTree.Internal.CRC32C (FileCorruptedError (..), FileFormat (..)) import qualified Database.LSMTree.Internal.Cursor as Cursor @@ -219,7 +221,7 @@ data LSMTreeTrace = | TraceCloseSession -- Table | TraceNewTable - | TraceOpenSnapshot SnapshotName TableConfigOverride + | TraceOpenSnapshot SnapshotName OverrideDiskCachePolicy | TraceTable TableId TableTrace | TraceDeleteSnapshot SnapshotName | TraceListSnapshots @@ -1319,9 +1321,9 @@ data SnapshotNotCompatibleError {-# SPECIALISE openSnapshot :: Session IO h + -> OverrideDiskCachePolicy -> SnapshotLabel -> SnapshotTableType - -> TableConfigOverride -> SnapshotName -> ResolveSerialisedValue -> IO (Table IO h) #-} @@ -1329,15 +1331,15 @@ data SnapshotNotCompatibleError openSnapshot :: (MonadMask m, MonadMVar m, MonadST m, MonadSTM m) => Session m h + -> OverrideDiskCachePolicy -> SnapshotLabel -- ^ Expected label -> SnapshotTableType -- ^ Expected table type - -> TableConfigOverride -- ^ Optional config override -> SnapshotName -> ResolveSerialisedValue -> m (Table m h) -openSnapshot sesh label tableType override snap resolve = +openSnapshot sesh policyOveride label tableType snap resolve = wrapFileCorruptedErrorAsSnapshotCorruptedError snap $ do - traceWith (sessionTracer sesh) $ TraceOpenSnapshot snap override + traceWith (sessionTracer sesh) $ TraceOpenSnapshot snap policyOveride withOpenSession sesh $ \seshEnv -> do withActionRegistry $ \reg -> do let hfs = sessionHasFS seshEnv @@ -1354,7 +1356,8 @@ openSnapshot sesh label tableType override snap resolve = snapMetaData <- readFileSnapshotMetaData hfs contentPath checksumPath - let SnapshotMetaData label' tableType' conf snapWriteBuffer snapLevels mTreeOpt = snapMetaData + let SnapshotMetaData label' tableType' conf snapWriteBuffer snapLevels mTreeOpt + = overrideDiskCachePolicy policyOveride snapMetaData unless (tableType == tableType') $ throwIO (ErrSnapshotWrongTableType snap tableType tableType') @@ -1362,7 +1365,6 @@ openSnapshot sesh label tableType override snap resolve = unless (label == label') $ throwIO (ErrSnapshotWrongLabel snap label label') - let conf' = applyOverride override conf am <- newArenaManager let activeDir = Paths.activeDir (sessionRoot seshEnv) @@ -1387,7 +1389,7 @@ openSnapshot sesh label tableType override snap resolve = traverse_ (delayedCommit reg . releaseRef) snapLevels' tableCache <- mkLevelsCache reg tableLevels - newWith reg sesh seshEnv conf' am $! TableContent { + newWith reg sesh seshEnv conf am $! TableContent { tableWriteBuffer , tableWriteBufferBlobs , tableLevels diff --git a/src/Database/LSMTree/Internal/Config.hs b/src/Database/LSMTree/Internal/Config.hs index 40349281d..9e4cf4734 100644 --- a/src/Database/LSMTree/Internal/Config.hs +++ b/src/Database/LSMTree/Internal/Config.hs @@ -7,11 +7,6 @@ module Database.LSMTree.Internal.Config ( , defaultTableConfig , RunLevelNo (..) , runParamsForLevel - -- * Table configuration override - , TableConfigOverride - , applyOverride - , configNoOverride - , configOverrideDiskCachePolicy -- * Merge policy , MergePolicy (..) -- * Size ratio @@ -35,8 +30,6 @@ module Database.LSMTree.Internal.Config ( ) where import Control.DeepSeq (NFData (..)) -import Data.Maybe (fromMaybe) -import Data.Monoid (Last (..)) import Data.Word (Word64) import Database.LSMTree.Internal.Entry (NumEntries (..)) import Database.LSMTree.Internal.Index (IndexType) @@ -109,54 +102,6 @@ runParamsForLevel conf@TableConfig {..} levelNo = , runParamIndex = indexTypeForRun confFencePointerIndex } -{------------------------------------------------------------------------------- - Table configuration override --------------------------------------------------------------------------------} - --- | Override configuration options in 'TableConfig' that can be changed dynamically. --- --- Some parts of the 'TableConfig' are considered fixed after a table is --- created. That is, these options should (i) should stay the same over the --- lifetime of a table, and (ii) these options should not be changed when a --- snapshot is created or loaded. Other options can be changed dynamically --- without sacrificing correctness. --- --- This type has 'Semigroup' and 'Monoid' instances for composing override --- options. -data TableConfigOverride = TableConfigOverride { - -- | Override for 'confDiskCachePolicy' - confOverrideDiskCachePolicy :: Last DiskCachePolicy - } - deriving stock Show - --- | Behaves like a point-wise 'Last' instance -instance Semigroup TableConfigOverride where - override1 <> override2 = TableConfigOverride { - confOverrideDiskCachePolicy = - confOverrideDiskCachePolicy override1 <> - confOverrideDiskCachePolicy override2 - } - --- | Behaves like a point-wise 'Last' instance -instance Monoid TableConfigOverride where - mempty = configNoOverride - -applyOverride :: TableConfigOverride -> TableConfig -> TableConfig -applyOverride TableConfigOverride{..} conf = conf { - confDiskCachePolicy = - fromMaybe (confDiskCachePolicy conf) (getLast confOverrideDiskCachePolicy) - } - -configNoOverride :: TableConfigOverride -configNoOverride = TableConfigOverride { - confOverrideDiskCachePolicy = Last Nothing - } - -configOverrideDiskCachePolicy :: DiskCachePolicy -> TableConfigOverride -configOverrideDiskCachePolicy pol = TableConfigOverride { - confOverrideDiskCachePolicy = Last (Just pol) - } - {------------------------------------------------------------------------------- Merge policy -------------------------------------------------------------------------------} @@ -279,7 +224,7 @@ indexTypeForRun OrdinaryIndex = Index.Ordinary -- -- Caching data in memory can improve performance if the access pattern has -- good access locality or if the overall data size fits within memory. On the --- other hand, caching is determental to performance and wastes memory if the +-- other hand, caching is detrimental to performance and wastes memory if the -- access pattern has poor spatial or temporal locality. -- -- This implementation is designed to have good performance using a cacheless diff --git a/src/Database/LSMTree/Internal/Config/Override.hs b/src/Database/LSMTree/Internal/Config/Override.hs new file mode 100644 index 000000000..1d35efba1 --- /dev/null +++ b/src/Database/LSMTree/Internal/Config/Override.hs @@ -0,0 +1,162 @@ +-- Definitions for override table config options. +module Database.LSMTree.Internal.Config.Override ( + -- $override-policy + + -- * Override disk cache policy + OverrideDiskCachePolicy (..) + , overrideDiskCachePolicy + ) where + +import qualified Data.Vector as V +import Database.LSMTree.Internal.Config +import Database.LSMTree.Internal.MergeSchedule (MergePolicyForLevel, + NominalCredits, NominalDebt) +import Database.LSMTree.Internal.MergingRun (LevelMergeType, + MergeCredits, MergeDebt, TreeMergeType) +import Database.LSMTree.Internal.Run +import Database.LSMTree.Internal.RunAcc (RunBloomFilterAlloc) +import Database.LSMTree.Internal.RunNumber (RunNumber) +import Database.LSMTree.Internal.Snapshot + +-- $override-policy +-- +-- === Limitations +-- +-- Overriding config options should in many cases be possible as long as there +-- is a mitigation strategy to ensure that a change in options does not cause +-- the database state of a table to become inconsistent. But what does this +-- strategy look like? And if we allow a config option to be overridden on a +-- live table (one that a user has access to), how should we apply these new +-- options to shared data like merging runs? Moreover, would we answer these +-- questions differently for each type of config option? +-- +-- For now, it seems to be the most straightforward to limit the config options +-- we allow to be overridden, and that we only change the config options +-- offline. That is, we override the config option just before opening a +-- snapshot from disk. At that point, there is no sharing because the table is +-- not live yet, which simplifies how changing a config option is handled. +-- +-- Another complicating factor is that we have thought about the possibility of +-- restoring sharing of ongoing merges between live tables and newly opened +-- snapshots. At that point, we run into the same challenges again... But for +-- now, changing only the disk cache policy offline should work fine. + +{------------------------------------------------------------------------------- + Override disk cache policy +-------------------------------------------------------------------------------} + +-- | Override the 'DiskCachePolicy' +data OverrideDiskCachePolicy = + OverrideDiskCachePolicy DiskCachePolicy + | NoOverrideDiskCachePolicy + deriving stock (Show, Eq) + +-- | Override the disk cache policy that is stored in snapshot metadata. +-- +-- Tables opened from the new 'SnapshotMetaData' will use the new value for the +-- disk cache policy. +overrideDiskCachePolicy :: OverrideDiskCachePolicy -> SnapshotMetaData -> SnapshotMetaData +overrideDiskCachePolicy (OverrideDiskCachePolicy dcp) = override dcp +overrideDiskCachePolicy NoOverrideDiskCachePolicy = id + +-- | This class is only here so that we can recursively call 'override' on all +-- fields of a datatype, instead of having to invent a new name for each type +-- that the function is called on such as 'overrideTableConfig', +-- 'overrideSnapshotRun', etc. +class Override o a where + override :: o -> a -> a + +-- NOTE: the instances below explicitly pattern match on the types of +-- constructor fields. This makes the code more verbose, but it also makes the +-- code a little more future proof. It should help us not to forget to update +-- the instances when new fields are added or existing fields change. In +-- particular, if anything changes about the constructor or its fields (and +-- their types), then we will see a compiler error, and then we are forced to +-- look at the code and make adjustments. + +instance Override DiskCachePolicy SnapshotMetaData where + override dcp + (SnapshotMetaData (sl :: SnapshotLabel)(stt :: SnapshotTableType) + (tc :: TableConfig) (rn :: RunNumber) + (sls :: (SnapLevels SnapshotRun)) + (smt :: (Maybe (SnapMergingTree SnapshotRun)))) + = SnapshotMetaData sl stt (override dcp tc) rn (override dcp sls) $ + let rdc = diskCachePolicyForLevel dcp UnionLevel + in fmap (override rdc) smt + +instance Override DiskCachePolicy TableConfig where + override dcp + (TableConfig (cmp :: MergePolicy) (csz :: SizeRatio) + (cwba :: WriteBufferAlloc) (cbfa :: BloomFilterAlloc) + (cfit :: FencePointerIndexType) (_dcp :: DiskCachePolicy) + (cfs :: MergeSchedule)) + = TableConfig cmp csz cwba cbfa cfit dcp cfs + +instance Override DiskCachePolicy (SnapLevels SnapshotRun) where + override dcp (SnapLevels (vec :: V.Vector (SnapLevel SnapshotRun))) = + SnapLevels $ V.imap go vec + where + go (LevelNo . (+1) -> ln) (x :: SnapLevel SnapshotRun) = + let rdc = diskCachePolicyForLevel dcp (RegularLevel ln) + in override rdc x + +instance Override RunDataCaching (SnapLevel SnapshotRun) where + override rdc + (SnapLevel (sir :: SnapIncomingRun SnapshotRun) (srs :: V.Vector SnapshotRun)) + = SnapLevel (override rdc sir) (V.map (override rdc) srs) + +instance Override RunDataCaching (SnapIncomingRun SnapshotRun) where + override rdc = \case + SnapIncomingSingleRun (sr :: SnapshotRun) -> + SnapIncomingSingleRun $ override rdc sr + SnapIncomingMergingRun + (mpfl :: MergePolicyForLevel) (nd :: NominalDebt) + (nc :: NominalCredits) (smr :: SnapMergingRun LevelMergeType SnapshotRun) -> + SnapIncomingMergingRun mpfl nd nc (override rdc smr) + +instance Override RunDataCaching (SnapMergingRun t SnapshotRun) where + override rdc = \case + SnapCompletedMerge (md :: MergeDebt) (sr :: SnapshotRun) -> + SnapCompletedMerge md (override rdc sr) + SnapOngoingMerge + (rp :: RunParams) (mc :: MergeCredits) + (srs :: V.Vector SnapshotRun) (t :: t) -> + SnapOngoingMerge (override rdc rp) mc (V.map (override rdc) srs) t + +instance Override RunDataCaching RunParams where + override rdc + (RunParams (_rdc :: RunDataCaching) (rbfa :: RunBloomFilterAlloc) (it :: IndexType)) + = RunParams rdc rbfa it + +instance Override RunDataCaching SnapshotRun where + override rdc + (SnapshotRun (rn :: RunNumber) (_rdc :: RunDataCaching) (it ::IndexType)) + = SnapshotRun rn rdc it + +instance Override RunDataCaching (SnapMergingTree SnapshotRun) where + override rdc (SnapMergingTree (smts :: SnapMergingTreeState SnapshotRun)) + = SnapMergingTree (override rdc smts) + +instance Override RunDataCaching (SnapMergingTreeState SnapshotRun) where + override rdc = \case + SnapCompletedTreeMerge (sr :: SnapshotRun) -> + SnapCompletedTreeMerge (override rdc sr) + SnapPendingTreeMerge (spm :: SnapPendingMerge SnapshotRun) -> + SnapPendingTreeMerge (override rdc spm) + SnapOngoingTreeMerge (smr :: SnapMergingRun TreeMergeType SnapshotRun) -> + SnapOngoingTreeMerge (override rdc smr) + +instance Override RunDataCaching (SnapPendingMerge SnapshotRun) where + override rdc = \case + SnapPendingLevelMerge + (spers :: [SnapPreExistingRun SnapshotRun]) + (msmt :: Maybe (SnapMergingTree SnapshotRun)) -> + SnapPendingLevelMerge (fmap (override rdc) spers) (fmap (override rdc) msmt) + SnapPendingUnionMerge (smts :: [SnapMergingTree SnapshotRun]) -> + SnapPendingUnionMerge (fmap (override rdc) smts) + +instance Override RunDataCaching (SnapPreExistingRun SnapshotRun) where + override rdc = \case + SnapPreExistingRun (sr :: SnapshotRun) -> SnapPreExistingRun (override rdc sr) + SnapPreExistingMergingRun (smr :: SnapMergingRun LevelMergeType SnapshotRun) -> + SnapPreExistingMergingRun (override rdc smr) diff --git a/src/Database/LSMTree/Internal/Snapshot.hs b/src/Database/LSMTree/Internal/Snapshot.hs index ac3b06f63..88d18a37b 100644 --- a/src/Database/LSMTree/Internal/Snapshot.hs +++ b/src/Database/LSMTree/Internal/Snapshot.hs @@ -117,9 +117,6 @@ data SnapshotMetaData = SnapshotMetaData { -- distinction, we can get rid of this field. , snapMetaTableType :: !SnapshotTableType -- | The 'TableConfig' for the snapshotted table. - -- - -- Some of these configuration options can be overridden when a snapshot is - -- opened: see 'TableConfigOverride'. , snapMetaConfig :: !TableConfig -- | The write buffer. , snapWriteBuffer :: !RunNumber diff --git a/src/Database/LSMTree/Monoidal.hs b/src/Database/LSMTree/Monoidal.hs index 5e28fdcd7..44e5bdf42 100644 --- a/src/Database/LSMTree/Monoidal.hs +++ b/src/Database/LSMTree/Monoidal.hs @@ -105,9 +105,7 @@ module Database.LSMTree.Monoidal ( , Common.SnapshotLabel (..) , createSnapshot , openSnapshot - , Common.TableConfigOverride - , Common.configNoOverride - , Common.configOverrideDiskCachePolicy + , Common.OverrideDiskCachePolicy (..) , deleteSnapshot , listSnapshots @@ -161,6 +159,7 @@ import qualified Database.LSMTree.Internal as Internal import qualified Database.LSMTree.Internal.Entry as Entry import Database.LSMTree.Internal.RawBytes (RawBytes) import qualified Database.LSMTree.Internal.Serialise as Internal +import qualified Database.LSMTree.Internal.Snapshot as Internal import qualified Database.LSMTree.Internal.Vector as V import GHC.Exts (Proxy#, proxy#) @@ -578,12 +577,12 @@ createSnapshot :: forall m k v. -> Table m k v -> m () createSnapshot label snap (Internal.MonoidalTable t) = - Internal.createSnapshot snap label Common.SnapMonoidalTable t + Internal.createSnapshot snap label Internal.SnapMonoidalTable t {-# SPECIALISE openSnapshot :: ResolveValue v => Session IO - -> Common.TableConfigOverride + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> IO (Table IO k v) #-} @@ -610,17 +609,17 @@ openSnapshot :: forall m k v. , ResolveValue v ) => Session m - -> Common.TableConfigOverride -- ^ Optional config override + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> m (Table m k v) -openSnapshot (Internal.Session' sesh) override label snap = +openSnapshot (Internal.Session' sesh) policyOverride label snap = Internal.MonoidalTable <$> Internal.openSnapshot sesh + policyOverride label - Common.SnapMonoidalTable - override + Internal.SnapMonoidalTable snap (resolve @v Proxy) diff --git a/src/Database/LSMTree/Normal.hs b/src/Database/LSMTree/Normal.hs index a8a5767a6..af1716b5c 100644 --- a/src/Database/LSMTree/Normal.hs +++ b/src/Database/LSMTree/Normal.hs @@ -106,9 +106,7 @@ module Database.LSMTree.Normal ( , Common.SnapshotLabel (..) , createSnapshot , openSnapshot - , Common.TableConfigOverride - , Common.configNoOverride - , Common.configOverrideDiskCachePolicy + , Common.OverrideDiskCachePolicy (..) , deleteSnapshot , listSnapshots @@ -152,6 +150,7 @@ import qualified Database.LSMTree.Internal as Internal import qualified Database.LSMTree.Internal.BlobRef as Internal import qualified Database.LSMTree.Internal.Entry as Entry import qualified Database.LSMTree.Internal.Serialise as Internal +import qualified Database.LSMTree.Internal.Snapshot as Internal import qualified Database.LSMTree.Internal.Vector as V import GHC.Exts (Proxy#, proxy#) @@ -698,11 +697,11 @@ createSnapshot :: forall m k v b. -> Table m k v b -> m () createSnapshot label snap (Internal.NormalTable t) = - Internal.createSnapshot snap label Common.SnapNormalTable t + Internal.createSnapshot snap label Internal.SnapNormalTable t {-# SPECIALISE openSnapshot :: Session IO - -> Common.TableConfigOverride + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> IO (Table IO k v b ) #-} @@ -731,17 +730,17 @@ createSnapshot label snap (Internal.NormalTable t) = openSnapshot :: forall m k v b. IOLike m => Session m - -> Common.TableConfigOverride -- ^ Optional config override + -> Common.OverrideDiskCachePolicy -> Common.SnapshotLabel -> Common.SnapshotName -> m (Table m k v b) -openSnapshot (Internal.Session' sesh) override label snap = +openSnapshot (Internal.Session' sesh) policyOverride label snap = Internal.NormalTable <$!> Internal.openSnapshot sesh + policyOverride label - Common.SnapNormalTable - override + Internal.SnapNormalTable snap const diff --git a/test/Database/LSMTree/Class.hs b/test/Database/LSMTree/Class.hs index d4b75df50..a30c89042 100644 --- a/test/Database/LSMTree/Class.hs +++ b/test/Database/LSMTree/Class.hs @@ -289,7 +289,7 @@ instance IsTable R.Table where createSnapshot = R.createSnapshot corruptSnapshot = rCorruptSnapshot - openSnapshot sesh snap = R.openSnapshot sesh R.configNoOverride snap + openSnapshot sesh snap = R.openSnapshot sesh R.NoOverrideDiskCachePolicy snap duplicate = R.duplicate diff --git a/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs b/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs index cec087c00..9042f96e4 100644 --- a/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs +++ b/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs @@ -13,6 +13,8 @@ import Database.LSMTree.Extras (showPowersOf10) import Database.LSMTree.Extras.Generators () import Database.LSMTree.Internal import Database.LSMTree.Internal.Config +import Database.LSMTree.Internal.Config.Override + (OverrideDiskCachePolicy (..)) import Database.LSMTree.Internal.Entry import Database.LSMTree.Internal.Paths import Database.LSMTree.Internal.Serialise @@ -219,6 +221,6 @@ prop_flipSnapshotBit (Positive (Small bufferSize)) es pickFileBit = createSnapshot snapName snapLabel SnapFullTable t openSnap s = - openSnapshot s snapLabel SnapFullTable configNoOverride snapName resolve + openSnapshot s NoOverrideDiskCachePolicy snapLabel SnapFullTable snapName resolve getConstructorName e = takeWhile (/= ' ') (show e) diff --git a/test/Test/Database/LSMTree/UnitTests.hs b/test/Test/Database/LSMTree/UnitTests.hs index f603bca7f..c2035c575 100644 --- a/test/Test/Database/LSMTree/UnitTests.hs +++ b/test/Test/Database/LSMTree/UnitTests.hs @@ -112,8 +112,8 @@ unit_twoTableTypes = createSnapshot label1 snap1 table1 createSnapshot label2 snap2 table2 - table1' <- openSnapshot @_ @Key1 @Value1 @Blob1 sess configNoOverride label1 snap1 - table2' <- openSnapshot @_ @Key2 @Value2 @Blob2 sess configNoOverride label2 snap2 + table1' <- openSnapshot @_ @Key1 @Value1 @Blob1 sess NoOverrideDiskCachePolicy label1 snap1 + table2' <- openSnapshot @_ @Key2 @Value2 @Blob2 sess NoOverrideDiskCachePolicy label2 snap2 vs1 <- lookups table1' ((\(k,_,_)->k) <$> ins1) vs2 <- lookups table2' ((\(k,_,_)->k) <$> ins2) @@ -141,11 +141,11 @@ unit_snapshots = assertException (ErrSnapshotWrongLabel snap1 (SnapshotLabel "Key2 Value2 Blob2") (SnapshotLabel "Key1 Value1 Blob1")) $ do - _ <- openSnapshot @_ @Key2 @Value2 @Blob2 sess configNoOverride label2 snap1 + _ <- openSnapshot @_ @Key2 @Value2 @Blob2 sess NoOverrideDiskCachePolicy label2 snap1 return () assertException (ErrSnapshotDoesNotExist snap2) $ do - _ <- openSnapshot @_ @Key1 @Value1 @Blob1 sess configNoOverride label2 snap2 + _ <- openSnapshot @_ @Key1 @Value1 @Blob1 sess NoOverrideDiskCachePolicy label2 snap2 return () where snap1, snap2 :: SnapshotName