Skip to content

Commit aeca0a2

Browse files
jorisdraljorisdral
committed
Comparative benchmarks for hGetSome(at) and their replacement functions.
`hGetSome'` is a new function that provides the same functionality as `hGetSome`, but uses the `hGetSomeBuf` primitive. Similary, we implement a new `hGetSomeAt'` function that provides the same functionality as `hGetSomeAt`. These comparative benchmarks should show whether we can replace the `hGetSome(At)` primitives with `hGetBufSome(At)` primtives and the new compound functions.
1 parent 1b02b09 commit aeca0a2

File tree

3 files changed

+227
-12
lines changed

3 files changed

+227
-12
lines changed

‎fs-api/bench/Main.hs

Lines changed: 198 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,198 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE MagicHash #-}
6+
{-# LANGUAGE NamedFieldPuns #-}
7+
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE StandaloneDeriving #-}
9+
10+
{-# OPTIONS_GHC -Wno-orphans #-}
11+
12+
module Main (main) where
13+
14+
import Control.DeepSeq (NFData (..))
15+
import Control.Exception (assert)
16+
import Control.Monad.Primitive (PrimMonad)
17+
import Criterion.Main
18+
import qualified Data.ByteString as BS
19+
import qualified Data.ByteString.Internal as BS
20+
import qualified Data.ByteString.Lazy as LBS
21+
import Data.Int (Int64)
22+
import Data.List (unfoldr)
23+
import Data.Primitive.ByteArray
24+
import Data.Word (Word64)
25+
import Foreign (withForeignPtr)
26+
import qualified GHC.ForeignPtr as GHC
27+
import GHC.Generics (Generic)
28+
import qualified GHC.IO as GHC
29+
import qualified GHC.Ptr as GHC
30+
import GHC.Stack (HasCallStack)
31+
import qualified System.Directory as Dir
32+
import qualified System.FS.API as FS
33+
import qualified System.FS.API.Lazy as FS
34+
import System.FS.IO (HandleIO, ioHasBufFS, ioHasFS)
35+
import System.FS.IO.Internal.Handle (HandleOS (..))
36+
import System.IO.Temp (createTempDirectory,
37+
getCanonicalTemporaryDirectory)
38+
import System.Random (mkStdGen, uniform)
39+
40+
main :: IO ()
41+
main = do
42+
putStrLn "WARNING: it is recommended to run each benchmark in isolation \
43+
\with short cooldown pauses in between benchmark executable \
44+
\invocations. This prevents noise coming from one benchmark \
45+
\from influencing another benchmark. Example incantion: \
46+
\cabal run fs-api-bench -- -m glob \"System.FS.API/hGetSome\""
47+
defaultMain [benchmarks]
48+
49+
benchmarks :: Benchmark
50+
benchmarks = bgroup "System.FS.API" [
51+
envWithCleanup (mkFileEnv (4096 * 64) "hGetSome") cleanupFileEnv $ \ ~(hfs, _, _, fsp) ->
52+
bench "hGetSome" $
53+
perRunEnvWithCleanup (mkHandleEnv hfs fsp 0) (cleanupHandleEnv hfs) $ \h -> do
54+
FS.hGetSome hfs h (4096 * 64)
55+
, envWithCleanup (mkFileEnv (4096 * 64) "hGetSome'") cleanupFileEnv $ \ ~(hfs, hbfs, _, fsp) ->
56+
bench "hGetSome'" $
57+
perRunEnvWithCleanup (mkHandleEnv hfs fsp 0) (cleanupHandleEnv hfs) $ \h -> do
58+
hGetSome' hbfs h (4096 * 64)
59+
, envWithCleanup (mkFileEnv (4096 * 64) "hGetSomeAt") cleanupFileEnv $ \ ~(hfs, _, _, fsp) ->
60+
bench "hGetSomeAt" $
61+
perRunEnvWithCleanup (mkHandleEnv hfs fsp 0) (cleanupHandleEnv hfs) $ \h -> do
62+
FS.hGetSomeAt hfs h (4096 * 64) 0
63+
, envWithCleanup (mkFileEnv (4096 * 64) "hGetSomeAt'") cleanupFileEnv $ \ ~(hfs, hbfs, _, fsp) ->
64+
bench "hGetSomeAt'" $
65+
perRunEnvWithCleanup (mkHandleEnv hfs fsp 0) (cleanupHandleEnv hfs) $ \h -> do
66+
hGetSomeAt' hbfs h (4096 * 64) 0
67+
]
68+
69+
{-------------------------------------------------------------------------------
70+
Benchmarkable functions
71+
-------------------------------------------------------------------------------}
72+
73+
hGetSome' ::
74+
(HasCallStack, PrimMonad m)
75+
=> FS.HasBufFS m h
76+
-> FS.Handle h
77+
-> Word64
78+
-> m BS.ByteString
79+
hGetSome' hbfs !h !c = do
80+
!buf <- newPinnedByteArray (fromIntegral c)
81+
!c' <- FS.hGetBufSome hbfs h buf 0 (fromIntegral c)
82+
ba <- unsafeFreezeByteArray buf
83+
-- pure $ copyByteArrayToByteString ba 0 (fromIntegral c')
84+
pure $! unsafeByteArrayToByteString ba (fromIntegral c')
85+
86+
hGetSomeAt' ::
87+
(HasCallStack, PrimMonad m)
88+
=> FS.HasBufFS m h
89+
-> FS.Handle h
90+
-> Word64
91+
-> FS.AbsOffset
92+
-> m BS.ByteString
93+
hGetSomeAt' hbfs !h !c !off = do
94+
!buf <- newPinnedByteArray (fromIntegral c)
95+
!c' <- FS.hGetBufSomeAt hbfs h buf 0 (fromIntegral c) off
96+
ba <- unsafeFreezeByteArray buf
97+
-- pure $ copyByteArrayToByteString ba 0 (fromIntegral c')
98+
pure $! unsafeByteArrayToByteString ba (fromIntegral c')
99+
100+
{-# INLINE unsafeByteArrayToByteString #-}
101+
unsafeByteArrayToByteString :: ByteArray -> Int -> BS.ByteString
102+
unsafeByteArrayToByteString !ba !len =
103+
GHC.unsafeDupablePerformIO $ do
104+
let !(GHC.Ptr addr#) = byteArrayContents ba
105+
(MutableByteArray mba#) <- unsafeThawByteArray ba
106+
let fp = GHC.ForeignPtr addr# (GHC.PlainPtr mba#)
107+
BS.mkDeferredByteString fp len
108+
109+
-- | Copy a 'Prim.ByteArray' at a certain offset and length into a
110+
-- 'BS.ByteString'.
111+
--
112+
-- This is a copy of a function from @cborg@.
113+
_copyByteArrayToByteString ::
114+
ByteArray -- ^ 'ByteArray' to copy from.
115+
-> Int -- ^ Offset into the 'ByteArray' to start with.
116+
-> Int -- ^ Length of the data to copy.
117+
-> BS.ByteString
118+
_copyByteArrayToByteString ba off len =
119+
GHC.unsafeDupablePerformIO $ do
120+
fp <- BS.mallocByteString len
121+
withForeignPtr fp $ \ptr -> do
122+
copyByteArrayToPtr ptr ba off len
123+
return (BS.PS fp 0 len)
124+
125+
{-------------------------------------------------------------------------------
126+
Orphan instances
127+
-------------------------------------------------------------------------------}
128+
129+
deriving stock instance Generic (HandleOS h)
130+
deriving anyclass instance NFData (HandleOS h)
131+
deriving anyclass instance NFData FS.FsPath
132+
deriving anyclass instance NFData h => NFData (FS.Handle h)
133+
instance NFData (FS.HasFS m h) where
134+
rnf hfs =
135+
dumpState `seq` hOpen `seq` hClose `seq` hIsOpen `seq` hSeek `seq`
136+
hGetSome `seq`hGetSomeAt `seq` hPutSome `seq` hTruncate `seq`
137+
hGetSize `seq` createDirectory `seq` createDirectoryIfMissing `seq`
138+
listDirectory `seq` doesDirectoryExist `seq` doesFileExist `seq`
139+
removeDirectoryRecursive `seq` removeFile `seq` renameFile `seq`
140+
mkFsErrorPath `seq` unsafeToFilePath `seq` ()
141+
where
142+
FS.HasFS {..} = hfs
143+
_coveredAllCases x = case x of
144+
FS.HasFS _a _b _c _d _e _f _g _h _i _j _k _l _m _n _o _p _q _r _s _t -> ()
145+
146+
147+
instance NFData (FS.HasBufFS m h) where
148+
rnf hbfs = hPutBufSome `seq` hPutBufSomeAt `seq` ()
149+
where
150+
FS.HasBufFS { FS.hPutBufSome , FS.hPutBufSomeAt } = hbfs
151+
152+
{-------------------------------------------------------------------------------
153+
Environment initialisation and cleanup
154+
-------------------------------------------------------------------------------}
155+
156+
mkFileEnv ::
157+
Int
158+
-> String
159+
-> IO (FS.HasFS IO HandleIO, FS.HasBufFS IO HandleIO, FilePath, FS.FsPath)
160+
mkFileEnv nbytes dirName = do
161+
sysTmpDir <- getCanonicalTemporaryDirectory
162+
tmpDir <- createTempDirectory sysTmpDir dirName
163+
let hfs = ioHasFS (FS.MountPoint tmpDir)
164+
hbfs = ioHasBufFS (FS.MountPoint tmpDir)
165+
166+
-- Create a file containing random bytes.
167+
let g = mkStdGen 17
168+
bytes = take nbytes $ unfoldr (Just . uniform) g
169+
bs = LBS.pack bytes
170+
fp = "benchfile"
171+
fsp = FS.mkFsPath [fp]
172+
FS.withFile hfs fsp (FS.WriteMode FS.MustBeNew) $ \h -> do
173+
nbytes' <- FS.hPutAll hfs h bs
174+
assert (nbytes == fromIntegral nbytes') $ pure ()
175+
176+
-- Read the full file into memory to make doubly sure that the file is in
177+
-- the page cache, even though it might still be in the page cache as a
178+
-- result of writing the file.
179+
--
180+
-- Having the full file in the page cache will hopefully prevent some noise
181+
-- in the benchmark measurements.
182+
FS.withFile hfs fsp FS.ReadMode $ \h -> do
183+
bs' <- FS.hGetAll hfs h
184+
pure $! rnf bs'
185+
186+
pure (hfs, hbfs, tmpDir, fsp)
187+
188+
cleanupFileEnv :: (a, b, FilePath, d) -> IO ()
189+
cleanupFileEnv (_, _, fp, _) = Dir.removeDirectoryRecursive fp
190+
191+
mkHandleEnv :: FS.HasFS IO HandleIO -> FS.FsPath -> Int64 -> IO (FS.Handle HandleIO)
192+
mkHandleEnv hfs fsp n = do
193+
h <- FS.hOpen hfs fsp FS.ReadMode
194+
FS.hSeek hfs h FS.AbsoluteSeek n
195+
pure h
196+
197+
cleanupHandleEnv :: FS.HasFS IO HandleIO -> FS.Handle HandleIO -> IO ()
198+
cleanupHandleEnv = FS.hClose

‎fs-api/fs-api.cabal

Lines changed: 28 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,14 @@ source-repository head
2424
location: https://github.com/input-output-hk/fs-sim
2525
subdir: fs-api
2626

27+
common warnings
28+
ghc-options:
29+
-Wall -Wcompat -Wincomplete-uni-patterns
30+
-Wincomplete-record-updates -Wpartial-fields -Widentities
31+
-Wredundant-constraints -Wmissing-export-lists -Wunused-packages
32+
2733
library
34+
import: warnings
2835
hs-source-dirs: src
2936
exposed-modules:
3037
System.FS.API
@@ -69,12 +76,8 @@ library
6976
else
7077
hs-source-dirs: src-macos
7178

72-
ghc-options:
73-
-Wall -Wcompat -Wincomplete-uni-patterns
74-
-Wincomplete-record-updates -Wpartial-fields -Widentities
75-
-Wredundant-constraints -Wmissing-export-lists -Wunused-packages
76-
7779
test-suite fs-api-test
80+
import: warnings
7881
type: exitcode-stdio-1.0
7982
hs-source-dirs: test
8083
main-is: Main.hs
@@ -89,8 +92,23 @@ test-suite fs-api-test
8992
, tasty-quickcheck
9093
, temporary
9194

92-
ghc-options:
93-
-Wall -Wcompat -Wincomplete-uni-patterns
94-
-Wincomplete-record-updates -Wpartial-fields -Widentities
95-
-Wredundant-constraints -Wmissing-export-lists -Wunused-packages
96-
-fno-ignore-asserts
95+
ghc-options: -fno-ignore-asserts
96+
97+
benchmark fs-api-bench
98+
import: warnings
99+
type: exitcode-stdio-1.0
100+
hs-source-dirs: bench
101+
main-is: Main.hs
102+
default-language: Haskell2010
103+
build-depends:
104+
, base
105+
, bytestring
106+
, criterion
107+
, deepseq
108+
, directory
109+
, fs-api
110+
, primitive
111+
, random
112+
, temporary
113+
114+
ghc-options: -rtsopts -with-rtsopts=-T

‎fs-api/src-unix/System/FS/IO/Internal.hs

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE PackageImports #-}
1+
{-# LANGUAGE CPP #-}
32

43
-- | This is meant to be used for the implementation of HasFS instances and not
54
-- directly by client code.

0 commit comments

Comments
 (0)