blockio: refactor and document the IO module

Author: jorisdral

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

@@ -310,11 +310,10 @@ totalNumEntriesSanityCheck l1 runSizes =
 withFS ::
      (FS.HasFS IO FS.HandleIO -> FS.HasBlockIO IO FS.HandleIO -> IO a)
   -> IO a
-withFS action = do
-    let hfs = FS.ioHasFS (FS.MountPoint "_bench_lookups")
-    exists <- FS.doesDirectoryExist hfs (FS.mkFsPath [""])
-    unless exists $ error ("_bench_lookups directory does not exist")
-    FS.withIOHasBlockIO hfs FS.defaultIOCtxParams $ \hbio ->
+withFS action =
+    FS.withIOHasBlockIO (FS.MountPoint "_bench_lookups") FS.defaultIOCtxParams $ \hfs hbio -> do
+      exists <- FS.doesDirectoryExist hfs (FS.mkFsPath [""])
+      unless exists $ error ("_bench_lookups directory does not exist")
       action hfs hbio
 
 -- | Input environment for benchmarking lookup functions.

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

@@ -64,7 +64,6 @@ import           Prelude hiding (lookup)
 import qualified System.Clock as Clock
 import qualified System.FS.API as FS
 import qualified System.FS.BlockIO.IO as FsIO
-import qualified System.FS.IO as FsIO
 import           System.IO
 import           System.Mem (performMajorGC)
 import qualified System.Random as Random
@@ -414,17 +413,8 @@ doSetup gopts opts = do
     void $ timed_ $ doSetup' gopts opts
 
 doSetup' :: GlobalOpts -> SetupOpts -> IO ()
-doSetup' gopts opts = do
-    let mountPoint :: FS.MountPoint
-        mountPoint = FS.MountPoint (rootDir gopts)
-
-    let hasFS :: FS.HasFS IO FsIO.HandleIO
-        hasFS = FsIO.ioHasFS mountPoint
-
-    hasBlockIO <- FsIO.ioHasBlockIO hasFS FsIO.defaultIOCtxParams
-
-    let name = LSM.toSnapshotName "bench"
-
+doSetup' gopts opts =
+    FsIO.withIOHasBlockIO mountPoint FsIO.defaultIOCtxParams $ \hasFS hasBlockIO ->
     LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session -> do
         tbl <- LSM.newTableWith @IO @K @V @B (mkTableConfigSetup gopts opts benchTableConfig) session
 
@@ -438,6 +428,12 @@ doSetup' gopts opts = do
                 ]
 
         LSM.saveSnapshot name label tbl
+  where
+    mountPoint :: FS.MountPoint
+    mountPoint = FS.MountPoint (rootDir gopts)
+
+    name = LSM.toSnapshotName "bench"
+
 
 -------------------------------------------------------------------------------
 -- dry-run
@@ -576,17 +572,8 @@ toOperations lookups inserts = (batch1, batch2)
 -------------------------------------------------------------------------------
 
 doRun :: GlobalOpts -> RunOpts -> IO ()
-doRun gopts opts = do
-    let mountPoint :: FS.MountPoint
-        mountPoint = FS.MountPoint (rootDir gopts)
-
-    let hasFS :: FS.HasFS IO FsIO.HandleIO
-        hasFS = FsIO.ioHasFS mountPoint
-
-    hasBlockIO <- FsIO.ioHasBlockIO hasFS FsIO.defaultIOCtxParams
-
-    let name = LSM.toSnapshotName "bench"
-
+doRun gopts opts =
+    FsIO.withIOHasBlockIO mountPoint FsIO.defaultIOCtxParams $ \hasFS hasBlockIO ->
     LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session ->
       withLatencyHandle $ \h -> do
         -- open snapshot
@@ -628,6 +615,11 @@ doRun gopts opts = do
 
         let ops = batchCount opts * batchSize opts
         printf "Operations per second: %7.01f ops/sec\n" (fromIntegral ops / time)
+  where
+    mountPoint :: FS.MountPoint
+    mountPoint = FS.MountPoint (rootDir gopts)
+
+    name = LSM.toSnapshotName "bench"
 
 -------------------------------------------------------------------------------
 -- sequential

bench/micro/Bench/Database/LSMTree.hs

@@ -433,8 +433,7 @@ mkFiles ::
 mkFiles = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "full"
-    let hfs = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hbio <- FS.ioHasBlockIO hfs FS.defaultIOCtxParams
+    (hfs, hbio) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) FS.defaultIOCtxParams
     pure (benchTmpDir, hfs, hbio)
 
 cleanupFiles ::

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

@@ -191,8 +191,7 @@ lookupsInBatchesEnv Config {..} = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "lookupsInBatchesEnv"
     (storedKeys, lookupKeys) <- lookupsEnv (mkStdGen 17) nentries npos nneg
-    let hasFS = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hasBlockIO <- FS.ioHasBlockIO hasFS (fromMaybe FS.defaultIOCtxParams ioctxps)
+    (hasFS, hasBlockIO) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) (fromMaybe FS.defaultIOCtxParams ioctxps)
     wbblobs <- WBB.new hasFS (FS.mkFsPath ["0.wbblobs"])
     wb <- WB.fromMap <$> traverse (traverse (WBB.addBlob hasFS wbblobs)) storedKeys
     let fsps = RunFsPaths (FS.mkFsPath []) (RunNumber 0)

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

@@ -373,8 +373,7 @@ mergeEnv ::
 mergeEnv config = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "mergeEnv"
-    let hasFS = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hasBlockIO <- FS.ioHasBlockIO hasFS FS.defaultIOCtxParams
+    (hasFS, hasBlockIO) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) FS.defaultIOCtxParams
     runs <- randomRuns hasFS hasBlockIO config (mkStdGen 17)
     pure (benchTmpDir, hasFS, hasBlockIO, runs)
 

blockio/src/System/FS/BlockIO/IO.hs

@@ -1,28 +1,174 @@
+-- | Implementations using the real file system.
+--
+-- The implementation of the 'HasBlockIO' interface provided in this module is
+-- platform-dependent. Most importantly, on Linux, the implementation of
+-- 'submitIO' is backed by @blockio-uring@: a library for asynchronous I/O. On
+-- Windows and MacOS, the implementation of 'submitIO' only supports serial I/O.
 module System.FS.BlockIO.IO (
+    -- * Implementation details #impl#
+    -- $impl
+
+    -- * Initialisation
     ioHasBlockIO
   , withIOHasBlockIO
+    -- ** Parameters
   , IOI.IOCtxParams (..)
   , IOI.defaultIOCtxParams
+    -- ** Unsafe
+  , unsafeFromHasFS
+  , withUnsafeFromHasFS
   ) where
 
 import           Control.Exception (bracket)
-import           System.FS.API (HasFS)
+import           System.FS.API (HasFS, MountPoint)
 import           System.FS.BlockIO.API (HasBlockIO (..))
 import qualified System.FS.BlockIO.Internal as I
 import qualified System.FS.BlockIO.IO.Internal as IOI
-import           System.FS.IO (HandleIO)
+import           System.FS.IO (HandleIO, ioHasFS)
 
--- | Platform-dependent IO instantiation of 'HasBlockIO'.
-ioHasBlockIO ::
+{- $impl
+
+  Though the 'HasBlockIO' interface tries to capture uniform behaviour, each
+  function in this implementation for the real file system can have subtly
+  different effects depending on the underlying patform. For example, some
+  features are not provided by some operating systems, and in some cases the
+  features behave subtly differently for different operating systems. For this
+  reason, we include below some documentation about the effects of calling the
+  interface functions on different platforms.
+
+  Note: if the @serialblockio@ Cabal flag is enabled, then the Linux implementation
+  uses a mocked context and serial I/O for 'close' and 'submitIO', just like the
+  MacOS and Windows implementations do.
+
+  [IO context]:  When an instance of the 'HasBlockIO' interface for Linux
+    systems is initialised, an @io_uring@ context is created using the
+    @blockio-uring@ package and stored in the 'HasBlockIO' closure. For uniform
+    behaviour, each other platform creates and stores a mocked IO context that
+    has the same open/closed behaviour as an @io_uring@ context. In summary,
+    each platform creates:
+
+    * Linux: an @io_uring@ context provided by the @blockio-uring@ package
+    * MacOS: a mocked context using an @MVar@
+    * Windows: a mocked conext using an @MVar@
+
+  ['close']:
+
+    * Linux: close the @io_uring@ context through the @blockio-uring@ package
+    * MacOS: close the mocked context
+    * Windows: close the mocked context
+
+  ['submitIO']: Submit a batch of I/O operations using:
+
+    * Linux: the @submitIO@ function from the @blockio-uring@ package
+    * MacOS: serial I/O using a 'HasFS'
+    * Windows: serial I/O using a 'HasFS'
+
+  ['hSetNoCache']:
+
+    * Linux: set the @O_DIRECT@ flag
+    * MacOS: set the @F_NOCACHE@ flag
+    * Windows: no-op
+
+  ['hAdvise']:
+
+    * Linux: perform @posix_fadvise(2)@
+    * MacOS: no-op
+    * Windows: no-op
+
+  ['hAllocate']:
+
+    * Linux: perform @posix_fallocate(2)@
+    * MacOS: no-op
+    * Windows: no-op
+
+  ['tryLockFile']: This uses different locking methods depending on the OS.
+
+    * Linux: Open file descriptor (OFD)
+    * MacOS: @flock@
+    * Windows: @LockFileEx@
+
+  ['hSynchronise']:
+
+    * Linux: perform @fsync(2)@
+    * MacOS: perform @fsync(2)@
+    * Windows: perform @flushFileBuffers@
+
+  ['synchroniseDirectory']:
+
+    * Linux: perform @fsync(2)@
+    * MacOS: perform @fsync(2)@
+    * Windows: no-op
+
+  ['createHardLink']:
+
+    * Linux: perform @link@
+    * MacOS: perform @link@
+    * Windows: perform @CreateHardLinkW@
+-}
+
+-- | An implementation of the 'HasBlockIO' interface using the real file system.
+--
+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer
+-- used. 'withUnsafeFromHasFS' does this automatically.
+--
+-- === Unsafe
+--
+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.
+--
+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to
+-- 'unsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated file
+-- system, but then the resulting 'HasBlockIO' would contain a mix of simulated
+-- and real functions, which is probably not what you want.
+unsafeFromHasFS ::
      HasFS IO HandleIO
   -> IOI.IOCtxParams
   -> IO (HasBlockIO IO HandleIO)
-ioHasBlockIO = I.ioHasBlockIO
+unsafeFromHasFS = I.ioHasBlockIO
 
-withIOHasBlockIO ::
+-- | Perform an action using a 'HasBlockIO' instance that is only open for the
+-- duration of the action.
+--
+-- The 'HasBlockIO' is initialised using 'unsafeFromHasFS'.
+--
+-- === Unsafe
+--
+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.
+--
+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to
+-- 'withUnsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated
+-- file system, but then the resulting 'HasBlockIO' would contain a mix of
+-- simulated and real functions, which is probably not what you want.
+withUnsafeFromHasFS ::
      HasFS IO HandleIO
   -> IOI.IOCtxParams
   -> (HasBlockIO IO HandleIO -> IO a)
   -> IO a
-withIOHasBlockIO hfs params action =
-    bracket (ioHasBlockIO hfs params) (\HasBlockIO{close} -> close) action
+withUnsafeFromHasFS hfs params =
+    bracket (unsafeFromHasFS hfs params) (\HasBlockIO{close} -> close)
+
+-- | An implementation of the 'HasBlockIO' interface using the real file system.
+--
+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer
+-- used. 'withIOHasBlockIO' does this automatically.
+--
+-- The 'HasFS' interface is instantiated using 'ioHasFS'.
+ioHasBlockIO ::
+     MountPoint
+  -> IOI.IOCtxParams
+  -> IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
+ioHasBlockIO mount params = do
+    let hfs = ioHasFS mount
+    hbio <- unsafeFromHasFS hfs params
+    pure (hfs, hbio)
+
+-- | Perform an action using a 'HasFS' and a 'HasBlockIO' instance. The latter
+-- is only open for the duration of the action.
+--
+-- The 'HasFS' and 'HasBlockIO' interfaces are initialised using 'ioHasBlockIO'.
+withIOHasBlockIO ::
+     MountPoint
+  -> IOI.IOCtxParams
+  -> (HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO a)
+  -> IO a
+withIOHasBlockIO mount params action =
+    bracket (ioHasBlockIO mount params) (\(_, HasBlockIO{close}) -> close) (uncurry action)