Merge pull request #418 from IntersectMBO/recursion-ninja/update-HasFS-HasBlockIO

Refactoring APIs involving HasIO & HasBlockIO

Author: dcoutts

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

@@ -329,7 +329,7 @@ lookupsEnv ::
   -> FS.HasFS IO FS.HandleIO
   -> FS.HasBlockIO IO FS.HandleIO
   -> Run.RunDataCaching
-  -> IO ( V.Vector (Run IO (FS.Handle FS.HandleIO))
+  -> IO ( V.Vector (Run IO FS.HandleIO)
         , V.Vector (Bloom SerialisedKey)
         , V.Vector IndexCompact
         , V.Vector (FS.Handle FS.HandleIO)
@@ -345,7 +345,7 @@ lookupsEnv runSizes keyRng0 hfs hbio caching = do
 
     -- create the runs
     rbs <- sequence
-            [ RunBuilder.new hfs
+            [ RunBuilder.new hfs hbio
                 (RunFsPaths (FS.mkFsPath []) (RunNumber i))
                 (NumEntries numEntries)
                 (RunAllocFixed benchmarkNumBitsPerEntry)
@@ -361,7 +361,7 @@ lookupsEnv runSizes keyRng0 hfs hbio caching = do
         flip VUM.imapM_ mvecLocal $ \ !j !k -> do
           -- progress
           when (j .&. 0xFFFF == 0) (putStr ".")
-          void $ RunBuilder.addKeyOp hfs rb (serialiseKey k) (Insert zero)
+          void $ RunBuilder.addKeyOp rb (serialiseKey k) (Insert zero)
         pure (i+n)
       )
       0
@@ -370,7 +370,7 @@ lookupsEnv runSizes keyRng0 hfs hbio caching = do
 
     -- return runs
     runs <- V.fromList <$>
-              mapM (Run.fromMutable hfs hbio caching (RefCount 1)) rbs
+              mapM (Run.fromMutable caching (RefCount 1)) rbs
     let blooms = V.map Run.runFilter runs
         indexes = V.map Run.runIndex runs
         handles = V.map Run.runKOpsFile runs
@@ -465,7 +465,7 @@ benchLookupsIO ::
   -> ResolveSerialisedValue
   -> WB.WriteBuffer
   -> WBB.WriteBufferBlobs IO h
-  -> V.Vector (Run IO (FS.Handle h))
+  -> V.Vector (Run IO h)
   -> V.Vector (Bloom SerialisedKey)
   -> V.Vector IndexCompact
   -> V.Vector (FS.Handle h)

bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs

@@ -180,7 +180,7 @@ lookupsInBatchesEnv ::
         , ArenaManager RealWorld
         , FS.HasFS IO FS.HandleIO
         , FS.HasBlockIO IO FS.HandleIO
-        , V.Vector (Run IO (FS.Handle FS.HandleIO))
+        , V.Vector (Run IO FS.HandleIO)
         , V.Vector SerialisedKey
         )
 lookupsInBatchesEnv Config {..} = do
@@ -212,7 +212,7 @@ lookupsInBatchesCleanup ::
      , ArenaManager RealWorld
      , FS.HasFS IO FS.HandleIO
      , FS.HasBlockIO IO FS.HandleIO
-     , V.Vector (Run IO (FS.Handle FS.HandleIO))
+     , V.Vector (Run IO FS.HandleIO)
      , V.Vector SerialisedKey
      )
   -> IO ()

bench/micro/Bench/Database/LSMTree/Internal/Merge.hs

@@ -228,7 +228,7 @@ merge ::
   -> Config
   -> Run.RunFsPaths
   -> InputRuns
-  -> IO (Run IO (FS.Handle (FS.HandleIO)))
+  -> IO (Run IO FS.HandleIO)
 merge fs hbio Config {..} targetPaths runs = do
     let f = fromMaybe const mergeMappend
     m <- fromMaybe (error "empty inputs, no merge created") <$>
@@ -241,7 +241,7 @@ outputRunPaths = RunFsPaths (FS.mkFsPath []) (RunNumber 0)
 inputRunPaths :: [Run.RunFsPaths]
 inputRunPaths = RunFsPaths (FS.mkFsPath []) . RunNumber <$> [1..]
 
-type InputRuns = V.Vector (Run IO (FS.Handle FS.HandleIO))
+type InputRuns = V.Vector (Run IO FS.HandleIO)
 
 type Mappend = SerialisedValue -> SerialisedValue -> SerialisedValue
 

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -184,9 +184,9 @@ instance NoThunks (Unsliced a) where
   Run
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic (Run m (Handle h))
-deriving anyclass instance (Typeable (PrimState m), Typeable h)
-                        => NoThunks (Run m (Handle h))
+deriving stock instance Generic (Run m h)
+deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
+                        => NoThunks (Run m h)
 
 deriving stock instance Generic RunDataCaching
 deriving anyclass instance NoThunks RunDataCaching
@@ -259,11 +259,11 @@ deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                            , NoThunks (StrictMVar m (MergingRunState m h))
                            ) => NoThunks (TableContent m h)
 
-deriving stock instance Generic (LevelsCache m (Handle h))
-deriving anyclass instance (Typeable (PrimState m), Typeable h)
-                        => NoThunks (LevelsCache m (Handle h))
+deriving stock instance Generic (LevelsCache m h)
+deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
+                        => NoThunks (LevelsCache m h)
 
-deriving stock instance Generic (Level m  h)
+deriving stock instance Generic (Level m h)
 deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                            , NoThunks (StrictMVar m (MergingRunState m h))
                            ) => NoThunks (Level m h)
@@ -292,13 +292,13 @@ deriving anyclass instance NoThunks NumEntries
   RunBuilder
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic (RunBuilder s (Handle h))
-deriving anyclass instance (Typeable s, Typeable h)
-                        => NoThunks (RunBuilder s (Handle h))
+deriving stock instance Generic (RunBuilder m h)
+deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
+                        => NoThunks (RunBuilder m h)
 
-deriving stock instance Generic (ChecksumHandle s (Handle h))
+deriving stock instance Generic (ChecksumHandle s h)
 deriving anyclass instance (Typeable s, Typeable h)
-                        => NoThunks (ChecksumHandle s (Handle h))
+                        => NoThunks (ChecksumHandle s h)
 
 {-------------------------------------------------------------------------------
   RunAcc
@@ -348,35 +348,35 @@ deriving anyclass instance NoThunks Merge.MergeState
   Readers
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic (Readers m (Handle h))
+deriving stock instance Generic (Readers m h)
 deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
-                        => NoThunks (Readers m (Handle h))
+                        => NoThunks (Readers m h)
 
-deriving stock instance Generic (Reader m (Handle h))
+deriving stock instance Generic (Reader m h)
 instance (Typeable m, Typeable (PrimState m), Typeable h)
-      => NoThunks (Reader m (Handle h)) where
-  showTypeOf (_ :: Proxy (Reader m (Handle h))) = "Reader"
+      => NoThunks (Reader m h) where
+  showTypeOf (_ :: Proxy (Reader m h)) = "Reader"
   wNoThunks ctx = \case
     ReadRun r      -> noThunks ctx r
     ReadBuffer var -> noThunks ctx (OnlyCheckWhnf var) -- contents intentionally lazy
 
 deriving stock instance Generic ReaderNumber
 deriving anyclass instance NoThunks ReaderNumber
 
-deriving stock instance Generic (ReadCtx m (Handle h))
+deriving stock instance Generic (ReadCtx m h)
 deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
-                        => NoThunks (ReadCtx m (Handle h))
+                        => NoThunks (ReadCtx m h)
 
 {-------------------------------------------------------------------------------
   Reader
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic (RunReader m (Handle h))
-deriving anyclass instance (Typeable (PrimState m), Typeable h)
-                        => NoThunks (RunReader m (Handle h))
+deriving stock instance Generic (RunReader m h)
+deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
+                        => NoThunks (RunReader m h)
 
 deriving stock instance Generic (Reader.Entry m (Handle h))
-deriving anyclass instance (Typeable (PrimState m), Typeable h)
+deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                         => NoThunks (Reader.Entry m (Handle h))
 
 {-------------------------------------------------------------------------------

src-extras/Database/LSMTree/Extras/RunData.hs

@@ -53,7 +53,7 @@ withRun ::
   -> HasBlockIO IO h
   -> RunFsPaths
   -> SerialisedRunData
-  -> (Run IO (Handle h) -> IO a)
+  -> (Run IO h -> IO a)
   -> IO a
 withRun hfs hbio path rd = do
     bracket
@@ -67,7 +67,7 @@ withRuns ::
   => HasFS IO h
   -> HasBlockIO IO h
   -> f (RunFsPaths, SerialisedRunData)
-  -> (f (Run IO (Handle h)) -> IO a)
+  -> (f (Run IO h) -> IO a)
   -> IO a
 withRuns hfs hbio xs = do
     bracket
@@ -85,7 +85,7 @@ unsafeFlushAsWriteBuffer ::
   -> HasBlockIO IO h
   -> RunFsPaths
   -> SerialisedRunData
-  -> IO (Run IO (Handle h))
+  -> IO (Run IO h)
 unsafeFlushAsWriteBuffer fs hbio fsPaths (RunData m) = do
     let blobpath = addExtension (runBlobPath fsPaths) ".wb"
     wbblobs <- WBB.new fs blobpath

src/Database/LSMTree/Internal.hs

@@ -901,10 +901,10 @@ data CursorEnv m h = CursorEnv {
     -- However, the reference counts to the runs only get removed when calling
     -- 'closeCursor', as there might still be 'BlobRef's that need the
     -- corresponding run to stay alive.
-  , cursorReaders    :: !(Maybe (Readers.Readers m (Handle h)))
+  , cursorReaders    :: !(Maybe (Readers.Readers m h))
     -- | The runs held open by the cursor. We must remove a reference when the
     -- cursor gets closed.
-  , cursorRuns       :: !(V.Vector (Run m (Handle h)))
+  , cursorRuns       :: !(V.Vector (Run m h))
 
     -- | The write buffer blobs, which like the runs, we have to keep open
     -- untile the cursor is closed.
@@ -943,9 +943,6 @@ newCursor !offsetKey th = withOpenTable th $ \thEnv -> do
     let cursorTracer = TraceCursor cursorId `contramap` sessionTracer cursorSession
     traceWith cursorTracer $ TraceCreateCursor (tableId thEnv)
 
-    let hfs = tableHasFS thEnv
-    let hbio = tableHasBlockIO thEnv
-
     -- We acquire a read-lock on the session open-state to prevent races, see
     -- 'sessionOpenTables'.
     withOpenSession cursorSession $ \_ -> do
@@ -954,9 +951,8 @@ newCursor !offsetKey th = withOpenTable th $ \thEnv -> do
           allocTableContent reg (tableContent thEnv)
         cursorReaders <-
           allocateMaybeTemp reg
-            (Readers.new hfs hbio
-               offsetKey (Just (wb, wbblobs)) cursorRuns)
-            (Readers.close hfs hbio)
+            (Readers.new offsetKey (Just (wb, wbblobs)) cursorRuns)
+            Readers.close
         let cursorWBB = wbblobs
         cursorState <- newMVar (CursorOpen CursorEnv {..})
         let !cursor = Cursor {cursorState, cursorTracer}
@@ -997,9 +993,6 @@ closeCursor Cursor {..} = do
     modifyWithTempRegistry_ (takeMVar cursorState) (putMVar cursorState) $ \reg -> \case
       CursorClosed -> return CursorClosed
       CursorOpen CursorEnv {..} -> do
-        let hfs = sessionHasFS cursorSessionEnv
-        let hbio = sessionHasBlockIO cursorSessionEnv
-
         -- This should be safe-ish, but it's still not ideal, because it doesn't
         -- rule out sync exceptions in the cleanup operations.
         -- In that case, the cursor ends up closed, but resources might not have
@@ -1008,7 +1001,7 @@ closeCursor Cursor {..} = do
           modifyMVar_ (sessionOpenCursors cursorSessionEnv) $
             pure . Map.delete cursorId
 
-        forM_ cursorReaders $ freeTemp reg . Readers.close hfs hbio
+        forM_ cursorReaders $ freeTemp reg . Readers.close
         V.forM_ cursorRuns $ freeTemp reg . Run.removeReference
         freeTemp reg (WBB.removeReference cursorWBB)
         return CursorClosed
@@ -1067,9 +1060,7 @@ readCursorWhile resolve keyIsWanted n Cursor {..} fromEntry = do
             -- a drained cursor will just return an empty vector
             return (state, V.empty)
           Just readers -> do
-            let hfs = sessionHasFS (cursorSessionEnv cursorEnv)
-            let hbio = sessionHasBlockIO (cursorSessionEnv cursorEnv)
-            (vec, hasMore) <- readCursorEntriesWhile hfs hbio resolve keyIsWanted fromEntry readers n
+            (vec, hasMore) <- readCursorEntriesWhile resolve keyIsWanted fromEntry readers n
             -- if we drained the readers, remove them from the state
             let !state' = case hasMore of
                   Readers.HasMore -> state
@@ -1078,12 +1069,10 @@ readCursorWhile resolve keyIsWanted n Cursor {..} fromEntry = do
 
 {-# INLINE readCursorEntriesWhile #-}
 {-# SPECIALISE readCursorEntriesWhile :: forall h res.
-     HasFS IO h
-  -> HasBlockIO IO h
-  -> ResolveSerialisedValue
+     ResolveSerialisedValue
   -> (SerialisedKey -> Bool)
   -> (SerialisedKey -> SerialisedValue -> Maybe (WeakBlobRef IO (Handle h)) -> res)
-  -> Readers.Readers IO (Handle h)
+  -> Readers.Readers IO h
   -> Int
   -> IO (V.Vector res, Readers.HasMore) #-}
 -- | General notes on the code below:
@@ -1094,15 +1083,13 @@ readCursorWhile resolve keyIsWanted n Cursor {..} fromEntry = do
 -- * there is probably opportunity for optimisations
 readCursorEntriesWhile :: forall h m res.
      (MonadFix m, MonadMask m, MonadST m, MonadSTM m)
-  => HasFS m h
-  -> HasBlockIO m h
-  -> ResolveSerialisedValue
+  => ResolveSerialisedValue
   -> (SerialisedKey -> Bool)
   -> (SerialisedKey -> SerialisedValue -> Maybe (WeakBlobRef m (Handle h)) -> res)
-  -> Readers.Readers m (Handle h)
+  -> Readers.Readers m h
   -> Int
   -> m (V.Vector res, Readers.HasMore)
-readCursorEntriesWhile hfs hbio resolve keyIsWanted fromEntry readers n =
+readCursorEntriesWhile resolve keyIsWanted fromEntry readers n =
     flip (V.unfoldrNM' n) Readers.HasMore $ \case
       Readers.Drained -> return (Nothing, Readers.Drained)
       Readers.HasMore -> readEntryIfWanted
@@ -1117,7 +1104,7 @@ readCursorEntriesWhile hfs hbio resolve keyIsWanted fromEntry readers n =
 
     readEntry :: m (Maybe res, Readers.HasMore)
     readEntry = do
-        (key, readerEntry, hasMore) <- Readers.pop hfs hbio readers
+        (key, readerEntry, hasMore) <- Readers.pop readers
         let !entry = Reader.toFullEntry readerEntry
         case hasMore of
           Readers.Drained -> do
@@ -1134,7 +1121,7 @@ readCursorEntriesWhile hfs hbio resolve keyIsWanted fromEntry readers n =
 
     dropRemaining :: SerialisedKey -> m Readers.HasMore
     dropRemaining key = do
-        (_, hasMore) <- Readers.dropWhileKey hfs hbio readers key
+        (_, hasMore) <- Readers.dropWhileKey readers key
         return hasMore
 
     -- Resolve a 'Mupsert' value with the other entries of the same key.
@@ -1148,7 +1135,7 @@ readCursorEntriesWhile hfs hbio resolve keyIsWanted fromEntry readers n =
             -- No more entries for same key, done.
             handleResolved key (Entry.Mupdate v) Readers.HasMore
           else do
-            (_, nextEntry, hasMore) <- Readers.pop hfs hbio readers
+            (_, nextEntry, hasMore) <- Readers.pop readers
             let resolved = Entry.combine resolve (Entry.Mupdate v)
                              (Reader.toFullEntry nextEntry)
             case hasMore of

src/Database/LSMTree/Internal/CRC32C.hs

@@ -3,6 +3,10 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- Needed by GHC <= 9.2 for newtype deriving Prim below
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE UnboxedTuples       #-}
+
 -- | Functionalty related to CRC-32C (Castagnoli) checksums:
 --
 -- * Support for calculating checksums while incrementally writing files.
@@ -65,6 +69,7 @@ import           System.FS.BlockIO.API (ByteCount)
 
 newtype CRC32C = CRC32C Word32
   deriving stock (Eq, Ord, Show)
+  deriving newtype (Prim)
 
 
 initialCRC32C :: CRC32C

src/Database/LSMTree/Internal/Lookup.hs

@@ -157,7 +157,7 @@ data ByteCountDiscrepancy = ByteCountDiscrepancy {
     -> ResolveSerialisedValue
     -> WB.WriteBuffer
     -> WBB.WriteBufferBlobs IO h
-    -> V.Vector (Run IO (Handle h))
+    -> V.Vector (Run IO h)
     -> V.Vector (Bloom SerialisedKey)
     -> V.Vector IndexCompact
     -> V.Vector (Handle h)
@@ -177,7 +177,7 @@ lookupsIO ::
   -> ResolveSerialisedValue
   -> WB.WriteBuffer
   -> WBB.WriteBufferBlobs m h
-  -> V.Vector (Run m (Handle h)) -- ^ Runs @rs@
+  -> V.Vector (Run m h) -- ^ Runs @rs@
   -> V.Vector (Bloom SerialisedKey) -- ^ The bloom filters inside @rs@
   -> V.Vector IndexCompact -- ^ The indexes inside @rs@
   -> V.Vector (Handle h) -- ^ The file handles to the key\/value files inside @rs@
@@ -202,7 +202,7 @@ lookupsIO !hbio !mgr !resolveV !wb !wbblobs !rs !blooms !indexes !kopsFiles !ks
        ResolveSerialisedValue
     -> WB.WriteBuffer
     -> WBB.WriteBufferBlobs IO h
-    -> V.Vector (Run IO (Handle h))
+    -> V.Vector (Run IO h)
     -> V.Vector SerialisedKey
     -> VP.Vector RunIxKeyIx
     -> V.Vector (IOOp RealWorld h)
@@ -221,7 +221,7 @@ intraPageLookups ::
   => ResolveSerialisedValue
   -> WB.WriteBuffer
   -> WBB.WriteBufferBlobs m h
-  -> V.Vector (Run m (Handle h))
+  -> V.Vector (Run m h)
   -> V.Vector SerialisedKey
   -> VP.Vector RunIxKeyIx
   -> V.Vector (IOOp (PrimState m) h)