Allow overriding the disk cache policy (feature restored)

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

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

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

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)

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,25 +1321,25 @@ data SnapshotNotCompatibleError
 
 {-# SPECIALISE openSnapshot ::
      Session IO h
+  -> OverrideDiskCachePolicy
   -> SnapshotLabel
   -> SnapshotTableType
-  -> TableConfigOverride
   -> SnapshotName
   -> ResolveSerialisedValue
   -> IO (Table IO h) #-}
 -- |  See 'Database.LSMTree.Normal.openSnapshot'.
 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,15 +1356,15 @@ 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')
 
         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

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