Skip to content

Commit 4aabd30

Browse files
jorisdraljorisdral
committed
WIP: guard pinned
1 parent dca6656 commit 4aabd30

File tree

4 files changed

+170
-23
lines changed

4 files changed

+170
-23
lines changed

‎blockio/src-linux/System/FS/BlockIO/Async.hs‎

Lines changed: 17 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -12,15 +12,16 @@ import Foreign.C.Error
1212
import GHC.IO.Exception
1313
import GHC.Stack
1414
import System.FS.API (BufferOffset (..), FsErrorPath, FsPath,
15-
Handle (..), HasFS (..), SomeHasFS (..), ioToFsError)
15+
Handle (..), HasFS (..), ioToFsError)
1616
import qualified System.FS.BlockIO.API as API
1717
import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode,
1818
ioopHandle)
1919
import qualified System.FS.BlockIO.IO.Internal as IOI
2020
import System.FS.IO (HandleIO)
2121
import System.FS.IO.Handle
2222
import qualified System.IO.BlockIO as I
23-
import System.IO.Error (ioeSetErrorString, isResourceVanishedError)
23+
import System.IO.Error (ioeGetErrorType, ioeSetErrorString,
24+
isResourceVanishedError)
2425
import System.Posix.Types
2526

2627
-- | IO instantiation of 'HasBlockIO', using @blockio-uring@.
@@ -64,17 +65,22 @@ submitIO ::
6465
-> IO (VU.Vector IOResult)
6566
submitIO hasFS ioctx ioops = do
6667
ioops' <- mapM ioopConv ioops
67-
ress <- I.submitIO ioctx ioops' `catch` rethrowClosedError
68+
ress <- I.submitIO ioctx ioops' `catch` rethrowFsError
6869
hzipWithM rethrowErrno ioops ress
6970
where
70-
rethrowClosedError :: IOError -> IO a
71-
rethrowClosedError e@IOError{} =
72-
-- Pattern matching on the error is brittle, because the structure of
73-
-- the exception might change between versions of @blockio-uring@.
74-
-- Nonetheless, it's better than nothing.
75-
if isResourceVanishedError e && ioe_location e == "IOCtx closed"
76-
then throwIO (IOI.mkClosedError (SomeHasFS hasFS) "submitIO")
77-
else throwIO e
71+
rethrowFsError :: IOError -> IO a
72+
rethrowFsError e@IOError{}
73+
-- Pattern matching on the error is brittle, because the structure of
74+
-- the exception might change between versions of @blockio-uring@.
75+
-- Nonetheless, it's better than nothing.
76+
| isResourceVanishedError e
77+
, ioe_location e == "IOCtx closed"
78+
= throwIO (IOI.mkClosedError hasFS "submitIO")
79+
| ioeGetErrorType e == InvalidArgument
80+
, ioe_location e == "MutableByteArray is unpinned"
81+
= throwIO (IOI.mkNotPinnedError hasFS "submitIO")
82+
| otherwise
83+
= throwIO e
7884

7985
rethrowErrno ::
8086
HasCallStack

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

Lines changed: 25 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -5,18 +5,20 @@ module System.FS.BlockIO.IO.Internal (
55
IOCtxParams (..)
66
, defaultIOCtxParams
77
, mkClosedError
8+
, mkNotPinnedError
89
, tryLockFileIO
910
, createHardLinkIO
1011
) where
1112

1213
import Control.DeepSeq (NFData (..))
1314
import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
1415
MonadThrow (..), bracketOnError, try)
15-
import GHC.IO.Exception (IOErrorType (ResourceVanished))
16+
import GHC.IO.Exception
17+
(IOErrorType (InvalidArgument, ResourceVanished))
1618
import qualified GHC.IO.Handle.Lock as GHC
1719
import GHC.Stack (HasCallStack)
1820
import qualified System.FS.API as FS
19-
import System.FS.API (FsError (..), FsPath, HasFS, SomeHasFS (..))
21+
import System.FS.API (FsError (..), FsPath, HasFS)
2022
import System.FS.BlockIO.API (LockFileHandle (..))
2123
import System.FS.IO (HandleIO)
2224
import qualified System.IO as GHC
@@ -54,12 +56,27 @@ defaultIOCtxParams = IOCtxParams {
5456
ioctxConcurrencyLimit = 64 * 3
5557
}
5658

57-
mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError
58-
mkClosedError (SomeHasFS hasFS) loc = FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr
59-
where ioerr =
60-
ioeSetErrorString
61-
(mkIOError ResourceVanished loc Nothing Nothing)
62-
("HasBlockIO closed: " <> loc)
59+
{-------------------------------------------------------------------------------
60+
Errors
61+
-------------------------------------------------------------------------------}
62+
63+
mkClosedError :: HasCallStack => HasFS m h -> String -> FsError
64+
mkClosedError hasFS loc =
65+
FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr
66+
where
67+
ioerr =
68+
ioeSetErrorString
69+
(mkIOError ResourceVanished loc Nothing Nothing)
70+
("HasBlockIO closed: " <> loc)
71+
72+
mkNotPinnedError :: HasCallStack => HasFS m h -> String -> FsError
73+
mkNotPinnedError hasFS loc =
74+
FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr
75+
where
76+
ioerr =
77+
ioeSetErrorString
78+
(mkIOError InvalidArgument loc Nothing Nothing)
79+
("MutableByteArray is unpinned: " <> loc)
6380

6481
{-------------------------------------------------------------------------------
6582
File locks

‎blockio/src/System/FS/BlockIO/Serial.hs‎

Lines changed: 19 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ import Control.Concurrent.Class.MonadMVar
66
import Control.Monad (unless)
77
import Control.Monad.Class.MonadThrow
88
import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)
9+
import Data.Primitive (MutableByteArray, isMutableByteArrayPinned)
910
import qualified Data.Vector as V
1011
import qualified Data.Vector.Unboxed as VU
1112
import qualified Data.Vector.Unboxed.Mutable as VUM
@@ -59,7 +60,9 @@ data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool }
5960
{-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-}
6061
guardIsOpen :: (HasCallStack, MonadMVar m, MonadThrow m) => IOCtx m -> m ()
6162
guardIsOpen ctx = readMVar (openVar ctx) >>= \b ->
62-
unless b $ throwIO (IOI.mkClosedError (ctxFS ctx) "submitIO")
63+
case ctxFS ctx of
64+
SomeHasFS hfs ->
65+
unless b $ throwIO $ IOI.mkClosedError hfs "submitIO"
6366

6467
{-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-}
6568
initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m)
@@ -90,11 +93,24 @@ ioop ::
9093
=> HasFS m h
9194
-> IOOp (PrimState m) h
9295
-> m IOResult
93-
ioop hfs (IOOpRead h off buf bufOff c) =
96+
ioop hfs (IOOpRead h off buf bufOff c) = do
97+
guardPinned hfs buf "submitIO"
9498
IOResult <$> hGetBufExactlyAt hfs h buf bufOff c (fromIntegral off)
95-
ioop hfs (IOOpWrite h off buf bufOff c) =
99+
ioop hfs (IOOpWrite h off buf bufOff c) = do
100+
guardPinned hfs buf "submitIO"
96101
IOResult <$> hPutBufExactlyAt hfs h buf bufOff c (fromIntegral off)
97102

103+
{-# SPECIALISE guardPinned :: HasFS IO h -> MutableByteArray RealWorld -> String -> IO () #-}
104+
guardPinned ::
105+
MonadThrow m
106+
=> HasFS m h
107+
-> MutableByteArray (PrimState m)
108+
-> String
109+
-> m ()
110+
guardPinned hfs buf loc =
111+
unless (isMutableByteArrayPinned buf) $
112+
throwIO (IOI.mkNotPinnedError hfs loc)
113+
98114
{-# SPECIALISE hmapM ::
99115
VUM.Unbox b
100116
=> (a -> IO b)

‎blockio/test/Main.hs‎

Lines changed: 109 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,20 +5,24 @@ module Main (main) where
55
import Control.Concurrent (modifyMVar_, newMVar, threadDelay,
66
withMVar)
77
import Control.Concurrent.Async
8-
import Control.Exception (SomeException (SomeException), bracket, try)
8+
import Control.Exception (Exception (displayException),
9+
SomeException (SomeException), bracket, try)
910
import Control.Monad
1011
import Control.Monad.Primitive
1112
import Data.ByteString (ByteString)
1213
import qualified Data.ByteString as BS
1314
import qualified Data.ByteString.Char8 as BSC
15+
import qualified Data.ByteString.Lazy as LBS
1416
import Data.Foldable (traverse_)
1517
import Data.Functor.Compose (Compose (Compose))
18+
import qualified Data.List as List
1619
import Data.Maybe (catMaybes)
1720
import Data.Primitive.ByteArray
1821
import Data.Typeable
1922
import qualified Data.Vector as V
2023
import qualified Data.Vector.Unboxed as VU
2124
import System.FS.API
25+
import qualified System.FS.API.Lazy as FS
2226
import qualified System.FS.API.Strict as FS
2327
import System.FS.API.Strict (hPutAllStrict)
2428
import qualified System.FS.BlockIO.API as FS
@@ -40,7 +44,17 @@ tests = testGroup "blockio:test" [
4044
, testCase "example_closeIsIdempotent" example_closeIsIdempotent
4145
, testProperty "prop_readWrite" prop_readWrite
4246
, testProperty "prop_submitToClosedCtx" prop_submitToClosedCtx
47+
48+
, testProperty "prop_submitIO_contextClosed" prop_submitIO_contextClosed
49+
50+
-- Pinned vs. unpinned buffers
51+
, testProperty "prop_submitIO_buffersPinned" prop_submitIO_buffersPinned
52+
, testProperty "prop_submitIO_buffersUnpinned" prop_submitIO_buffersUnpinned
53+
54+
-- File locks
4355
, testProperty "prop_tryLockFileExclusiveTwice" prop_tryLockFileExclusiveTwice
56+
57+
-- Storage synchronisation
4458
, testProperty "prop_synchronise" prop_synchronise
4559
, testProperty "prop_synchroniseFile_fileDoesNotExist"
4660
prop_synchroniseFile_fileDoesNotExist
@@ -118,6 +132,100 @@ prop_submitToClosedCtx bs = ioProperty $ withSystemTempDirectory "prop_a" $ \dir
118132
Left _ -> Just $ tabulate "submitIO successful" [show False] $ counterexample "expected failure, but got success" (b === True)
119133
Right _ -> Just $ tabulate "submitIO successful" [show True] $ counterexample "expected success, but got failure" (b === False)
120134

135+
{-------------------------------------------------------------------------------
136+
Pinned vs. unpinned buffers
137+
-------------------------------------------------------------------------------}
138+
139+
prop_submitIO_contextClosed :: Property
140+
prop_submitIO_contextClosed =
141+
ioProperty $
142+
withTempIOHasBlockIO "prop_submitIO_unpinnedBuffers" $ \hfs hbio ->
143+
FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do
144+
void $ FS.hPutAll hfs h $ LBS.pack [1..100]
145+
buf <- newByteArray 17
146+
let ioops = V.fromList [
147+
IOOpWrite h 0 buf 0 17
148+
, IOOpRead h 0 buf 0 17
149+
]
150+
close hbio
151+
eith <- try @FsError $ submitIO hbio ioops
152+
pure $ case eith of
153+
Left e
154+
| isClosedError e
155+
-> property True
156+
| otherwise
157+
-> counterexample ("Unexpected error: " <> displayException e) False
158+
Right _
159+
-> counterexample ("Unexpected success") False
160+
where
161+
path = FS.mkFsPath ["temp-file"]
162+
163+
-- TODO: add a property that checks @isClosedError . mkClosedError = True@
164+
isClosedError :: FsError -> Bool
165+
isClosedError e
166+
-- TODO: add an FsResourceVanished constructor to FsErrorType?
167+
| fsErrorType e == FsOther
168+
, "HasBlockIO closed: " `List.isPrefixOf` (fsErrorString e)
169+
= True
170+
| otherwise
171+
= False
172+
173+
{-------------------------------------------------------------------------------
174+
Pinned vs. unpinned buffers
175+
-------------------------------------------------------------------------------}
176+
177+
prop_submitIO_buffersPinned :: Property
178+
prop_submitIO_buffersPinned =
179+
ioProperty $
180+
withTempIOHasBlockIO "prop_submitIO_pinnedBuffers" $ \hfs hbio ->
181+
FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do
182+
void $ FS.hPutAll hfs h $ LBS.pack [1..100]
183+
buf <- newPinnedByteArray 17
184+
let ioops = V.fromList [
185+
IOOpWrite h 0 buf 0 17
186+
, IOOpRead h 0 buf 0 17
187+
]
188+
eith <- try @FsError $ submitIO hbio ioops
189+
pure $ case eith of
190+
Left e
191+
-> counterexample ("Unexpected error: " <> displayException e) False
192+
Right _
193+
-> property True
194+
where
195+
path = FS.mkFsPath ["temp-file"]
196+
197+
prop_submitIO_buffersUnpinned :: Property
198+
prop_submitIO_buffersUnpinned =
199+
ioProperty $
200+
withTempIOHasBlockIO "prop_submitIO_unpinnedBuffers" $ \hfs hbio ->
201+
FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do
202+
void $ FS.hPutAll hfs h $ LBS.pack [1..100]
203+
buf <- newByteArray 17
204+
let ioops = V.fromList [
205+
IOOpWrite h 0 buf 0 17
206+
, IOOpRead h 0 buf 0 17
207+
]
208+
eith <- try @FsError $ submitIO hbio ioops
209+
pure $ case eith of
210+
Left e
211+
| isNotPinnedError e
212+
-> property True
213+
| otherwise
214+
-> counterexample ("Unexpected error: " <> displayException e) False
215+
Right _
216+
-> counterexample ("Unexpected success") False
217+
where
218+
path = FS.mkFsPath ["temp-file"]
219+
220+
-- TODO: add a property that checks @isNotPinnedError . mkNotPinnedError = True@
221+
isNotPinnedError :: FsError -> Bool
222+
isNotPinnedError e
223+
| fsErrorType e == FsInvalidArgument
224+
, "MutableByteArray is unpinned: " `List.isPrefixOf` (fsErrorString e)
225+
= True
226+
| otherwise
227+
= False
228+
121229
{-------------------------------------------------------------------------------
122230
File locks
123231
-------------------------------------------------------------------------------}

0 commit comments

Comments
 (0)