Merge pull request #334 from IntersectMBO/jdral/mutvar-for-ioref

Replace `IORef` by `MutVar`
IntersectMBO · Aug 20, 2024 · dd8aac1 · dd8aac1
2 parents 2936863 + 3a93441
commit dd8aac1
Show file tree

Hide file tree

Showing 15 changed files with 202 additions and 188 deletions.
diff --git a/bench/macro/lsm-tree-bench-lookups.hs b/bench/macro/lsm-tree-bench-lookups.hs
@@ -318,7 +318,7 @@ lookupsEnv ::
   -> FS.HasFS IO FS.HandleIO
   -> FS.HasBlockIO IO FS.HandleIO
   -> Run.RunDataCaching
-  -> IO ( V.Vector (Run (FS.Handle FS.HandleIO))
+  -> IO ( V.Vector (Run RealWorld (FS.Handle FS.HandleIO))
         , V.Vector (Bloom SerialisedKey)
         , V.Vector IndexCompact
         , V.Vector (FS.Handle FS.HandleIO)
@@ -452,7 +452,7 @@ benchLookupsIO ::
      FS.HasBlockIO IO h
   -> ArenaManager RealWorld
   -> ResolveSerialisedValue
-  -> V.Vector (Run (FS.Handle h))
+  -> V.Vector (Run RealWorld (FS.Handle h))
   -> V.Vector (Bloom SerialisedKey)
   -> V.Vector IndexCompact
   -> V.Vector (FS.Handle h)

diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs b/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs
@@ -167,7 +167,7 @@ lookupsInBatchesEnv ::
         , ArenaManager RealWorld
         , FS.HasFS IO FS.HandleIO
         , FS.HasBlockIO IO FS.HandleIO
-        , V.Vector (Run (FS.Handle FS.HandleIO))
+        , V.Vector (Run RealWorld (FS.Handle FS.HandleIO))
         , V.Vector SerialisedKey
         )
 lookupsInBatchesEnv Config {..} = do
@@ -198,7 +198,7 @@ lookupsInBatchesCleanup ::
      , ArenaManager RealWorld
      , FS.HasFS IO FS.HandleIO
      , FS.HasBlockIO IO FS.HandleIO
-     , V.Vector (Run (FS.Handle FS.HandleIO))
+     , V.Vector (Run RealWorld (FS.Handle FS.HandleIO))
      , V.Vector SerialisedKey
      )
   -> IO ()

diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs b/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs
@@ -1,6 +1,7 @@
 module Bench.Database.LSMTree.Internal.Merge (benchmarks) where
 
 import           Control.Monad (when, zipWithM)
+import           Control.Monad.Primitive
 import           Criterion.Main (Benchmark, bench, bgroup)
 import qualified Criterion.Main as Cr
 import           Data.Bifunctor (first)
@@ -226,7 +227,7 @@ merge ::
   -> Config
   -> Run.RunFsPaths
   -> InputRuns
-  -> IO (Run (FS.Handle (FS.HandleIO)))
+  -> IO (Run RealWorld (FS.Handle (FS.HandleIO)))
 merge fs hbio Config {..} targetPaths runs = do
     let f = fromMaybe const mergeMappend
     m <- fromMaybe (error "empty inputs, no merge created") <$>
@@ -244,7 +245,7 @@ outputRunPaths = RunFsPaths (FS.mkFsPath []) 0
 inputRunPaths :: [Run.RunFsPaths]
 inputRunPaths = RunFsPaths (FS.mkFsPath []) <$> [1..]
 
-type InputRuns = [Run (FS.Handle FS.HandleIO)]
+type InputRuns = [Run RealWorld (FS.Handle FS.HandleIO)]
 
 type Mappend = SerialisedValue -> SerialisedValue -> SerialisedValue
 
@@ -360,7 +361,7 @@ createRun ::
   -> Maybe Mappend
   -> Run.RunFsPaths
   -> [SerialisedKOp]
-  -> IO (Run (FS.Handle h))
+  -> IO (Run RealWorld (FS.Handle h))
 createRun hasFS hasBlockIO mMappend targetPath =
       Run.fromWriteBuffer hasFS  hasBlockIO Run.CacheRunData (RunAllocFixed 10) targetPath
     . Fold.foldl insert WB.empty

diff --git a/bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs b/bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs
@@ -1,6 +1,7 @@
 module Bench.Database.LSMTree.Internal.WriteBuffer (benchmarks) where
 
 import           Control.DeepSeq (NFData (..))
+import           Control.Monad.Primitive
 import           Criterion.Main (Benchmark, bench, bgroup)
 import qualified Criterion.Main as Cr
 import           Data.Bifunctor (first)
@@ -166,7 +167,7 @@ flush :: FS.HasFS IO FS.HandleIO
       -> FS.HasBlockIO IO FS.HandleIO
       -> RunFsPaths
       -> WriteBuffer
-      -> IO (Run (FS.Handle (FS.HandleIO)))
+      -> IO (Run RealWorld (FS.Handle (FS.HandleIO)))
 flush hfs hbio = Run.fromWriteBuffer hfs hbio Run.CacheRunData (RunAllocFixed 10)
 
 data InputKOps

diff --git a/src/Database/LSMTree/Common.hs b/src/Database/LSMTree/Common.hs
@@ -29,6 +29,7 @@ import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM (MonadSTM, STM)
 import           Control.DeepSeq
 import           Control.Monad.Class.MonadThrow
+import           Control.Monad.Primitive (PrimMonad (..))
 import           Data.Kind (Type)
 import           Data.Typeable (Proxy, Typeable)
 import qualified Database.LSMTree.Internal as Internal
@@ -216,4 +217,4 @@ listSnapshots (Session sesh) = Internal.listSnapshots sesh
 -- TODO: get rid of the @m@ parameter?
 type BlobRef :: (Type -> Type) -> Type -> Type
 type role BlobRef nominal nominal
-data BlobRef m blob = forall h. Typeable h => BlobRef (Internal.BlobRef (Internal.Run h))
+data BlobRef m blob = forall h. Typeable h => BlobRef (Internal.BlobRef (Internal.Run (PrimState m) h))