Commit 378c0bba authored by Tamar Christina's avatar Tamar Christina Committed by Marge Bot
Browse files

winio: use synchronous access explicitly for handles that may not be asynchronous.

parent 7ea3b7eb
......@@ -529,12 +529,13 @@ withOverlappedEx :: forall a.
Manager
-> String -- ^ Handle name
-> HANDLE -- ^ Windows handle associated with the operation.
-> Bool
-> Word64 -- ^ Value to use for the @OVERLAPPED@
-- structure's Offset/OffsetHigh members.
-> StartIOCallback Int
-> CompletionCallback (IOResult a)
-> IO (IOResult a)
withOverlappedEx mgr fname h offset startCB completionCB = do
withOverlappedEx mgr fname h async offset startCB completionCB = do
signal <- newEmptyIOPort :: IO (IOPort (IOResult a))
let signalReturn a = failIfFalse_ (dbgMsg "signalReturn") $
writeIOPort signal (IOSuccess a)
......@@ -552,7 +553,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
-- function will block until done so it can call completionCB at the end
-- we can safely use dynamic memory management here and so reduce the
-- possibility of memory errors.
withRequest offset callbackData $ \hs_lpol cdData -> do
withRequest async offset callbackData $ \hs_lpol cdData -> do
let ptr_lpol = hs_lpol `plusPtr` cdOffset
let lpol = castPtr hs_lpol
-- We need to add the payload before calling startCBResult, the reason being
......@@ -625,11 +626,11 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
-- Normally we'd have to clear lpol with 0 before this call,
-- however the statuses we're interested in would not get to here
-- so we can save the memset call.
finished <- FFI.getOverlappedResult h lpol False
finished <- FFI.getOverlappedResult h lpol (not async)
lasterr <- getLastError
debugIO $ "== " ++ show (finished)
status <- FFI.overlappedIOStatus lpol
debugIO $ "== >< " ++ show (status)
lasterr <- getLastError
-- This status indicated that we have finished early and so we
-- won't have a request enqueued. Handle it inline.
let done_early = status == #{const STATUS_SUCCESS}
......@@ -779,7 +780,8 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
unless :: Bool -> IO () -> IO ()
unless p a = if p then a else return ()
-- Safe version of function
-- Safe version of function of withOverlappedEx that assumes your handle is
-- set up for asynchronous access.
withOverlapped :: String
-> HANDLE
-> Word64 -- ^ Value to use for the @OVERLAPPED@
......@@ -789,7 +791,7 @@ withOverlapped :: String
-> IO (IOResult a)
withOverlapped fname h offset startCB completionCB = do
mngr <- getSystemManager
withOverlappedEx mngr fname h offset startCB completionCB
withOverlappedEx mngr fname h True offset startCB completionCB
------------------------------------------------------------------------
-- Helper to check if an error code implies an operation has completed.
......
......@@ -343,13 +343,69 @@ pokeOffsetOverlapped lpol offset = do
#{poke OVERLAPPED, OffsetHigh} lpol offsetHigh
{-# INLINE pokeOffsetOverlapped #-}
-- | Set the event field in an OVERLAPPED structure.
pokeEventOverlapped :: LPOVERLAPPED -> HANDLE -> IO ()
pokeEventOverlapped lpol event = do
#{poke OVERLAPPED, hEvent} lpol event
{-# INLINE pokeEventOverlapped #-}
------------------------------------------------------------------------
-- Request management
withRequest :: Word64 -> CompletionData
-- [Note AsyncHandles]
-- In `winio` we have designed it to work in asynchronous mode always.
-- According to the MSDN documentation[1][2], when a handle is not opened
-- in asynchronous mode then the operation would simply work but operate
-- synchronously.
--
-- This seems to happen as documented for `File` handles, but `pipes` don't
-- seem to follow this documented behavior and so are a problem.
-- Under `msys2` your standard handles are actually pipes, not console
-- handles or files. As such running under an msys2 console causes a hang
-- as the pipe read never returns.
--
-- [1] https://docs.microsoft.com/en-us/windows/win32/fileio/synchronous-and-asynchronous-i-o
-- [2] https://docs.microsoft.com/en-us/windows/win32/sync/synchronization-and-overlapped-input-and-output
--
-- As such we need to annotate all NativeHandles with a Boolean to indicate
-- wether it's an asynchronous handle or not.
-- This allows us to manually wait for the completion instead of relying
-- on the I/O system to do the right thing. As we have been using the
-- buffers in async mode we may not have moved the file pointer on the kernel
-- object, as such we still need to give an `OVERLAPPED` structure, but we
-- instead create an event object that we can wait on.
--
-- As documented in MSDN this even object must be in manual reset mode. This
-- approach gives us the flexibility, with minimum impact to support both
-- synchronous and asynchronous access.
--
-- Additional approaches explored
--
-- Normally the I/O system is in full control of all Handles it creates, with
-- one big exception: inheritance.
--
-- For any `HANDLE` we inherit we don't know how it's been open. A different
-- solution I have explored was to try to detect the `HANDLE` mode.
-- But this approach would never work for a few reasons:
--
-- 1. The presence of an asynchronous flag does not indicate that we are able
-- to handle the operation asynchronously. In particular, just because a
-- `HANDLE` is open in async mode, it may not be associated with our
-- completion port.
-- 2. One can only associate a `HANDLE` to a *single* completion port. As
-- such, if the handle is opened in async mode but already registered to a
-- completion port then we can't use it asynchronously.
-- 3. You can only associate a completion port once, even if it's the same
-- port. This means were we to strap a `HANDLE` of it's `NativeHandle`
-- wrapper and then wrap it again, we can't retest as the result would be
-- invalid. This is an issue because to pass `HANDLE`s we have to pass
-- the native OS Handle not the Haskell one. i.e. remote-iserv.
-- See [Note AsyncHandles]
withRequest :: Bool -> Word64 -> CompletionData
-> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
-> IO a
withRequest offset cbData f =
withRequest async offset cbData f =
-- Create the completion record and store it.
-- We only need the record when we enqueue a request, however if we
-- delay creating it then we will run into a race condition where the
......@@ -364,8 +420,30 @@ withRequest offset cbData f =
allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
with cbData $ \cdData -> do
zeroOverlapped hs_lpol
pokeOffsetOverlapped (castPtr hs_lpol) offset
f hs_lpol cdData
let lpol = castPtr hs_lpol
pokeOffsetOverlapped lpol offset
-- If doing a synchronous request then register an event object.
-- This event object MUST be manual reset per MSDN.
case async of
True -> f hs_lpol cdData
False -> do
event <- failIfNull "withRequest (create)" $
c_CreateEvent nullPtr True False nullPtr
debugIO $ "{{ event " ++ show event ++ " for " ++ show hs_lpol
pokeEventOverlapped lpol event
res <- f hs_lpol cdData
-- Once the request has finished, close the object and free it.
failIfFalse_ "withRequest (free)" $ c_CloseHandle event
return res
-- | Create an event object for use when the HANDLE isn't asynchronous
foreign import WINDOWS_CCONV unsafe "windows.h CreateEventW"
c_CreateEvent :: Ptr () -> Bool -> Bool -> LPCWSTR -> IO HANDLE
-- | Close a handle object
foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"
c_CloseHandle :: HANDLE -> IO Bool
------------------------------------------------------------------------
-- Cancel pending I/O
......
......@@ -62,7 +62,7 @@ mkConsoleHandle dev filepath ha_type buffered mb_codec nl finalizer other_side
case isTerm of
True -> mkHandle dev filepath ha_type buffered mb_codec nl finalizer
other_side
False -> mkHandle (Win.convertHandle dev) filepath ha_type buffered
False -> mkHandle (Win.convertHandle dev False) filepath ha_type buffered
mb_codec nl finalizer other_side
-- | A handle managing input from the Haskell program's standard input channel.
......
......@@ -36,6 +36,7 @@ module GHC.IO.Windows.Handle
toHANDLE,
fromHANDLE,
handleToMode,
isAsynchronous,
optimizeFileAccess,
-- * Standard Handles
......@@ -77,7 +78,7 @@ import GHC.IO.Windows.Encoding (withGhcInternalToUTF16, withUTF16ToGhcInternal)
import GHC.IO.Windows.Paths (getDevicePath)
import GHC.IO.Handle.Internals (debugIO)
import GHC.IORef
import GHC.Event.Windows (LPOVERLAPPED, withOverlapped, IOResult(..))
import GHC.Event.Windows (LPOVERLAPPED, withOverlappedEx, IOResult(..))
import Foreign.Ptr
import Foreign.C
import Foreign.Marshal.Array (pokeArray)
......@@ -103,7 +104,12 @@ data ConsoleHandle
-- We can't store it separately because we don't know when the handle will
-- be destroyed or invalidated.
data IoHandle a where
NativeHandle :: { getNativeHandle :: HANDLE } -> IoHandle NativeHandle
NativeHandle :: { getNativeHandle :: HANDLE
-- In certain cases we have inherited a handle and the
-- handle and it may not have been created for async
-- access. In those case we can't issue a completion
-- request as it would never finish and we'd deadlock.
, isAsynchronous :: Bool } -> IoHandle NativeHandle
ConsoleHandle :: { getConsoleHandle :: HANDLE
, cookedHandle :: IORef Bool
} -> IoHandle ConsoleHandle
......@@ -112,8 +118,10 @@ type Io a = IoHandle a
-- | Convert a ConsoleHandle into a general FileHandle
-- This will change which DeviceIO is used.
convertHandle :: Io ConsoleHandle -> Io NativeHandle
convertHandle = fromHANDLE . toHANDLE
convertHandle :: Io ConsoleHandle -> Bool -> Io NativeHandle
convertHandle io async
= let !hwnd = getConsoleHandle io
in NativeHandle hwnd async
-- | @since 4.11.0.0
instance Show (Io NativeHandle) where
......@@ -148,7 +156,9 @@ class (GHC.IO.Device.RawIO a, IODevice a, BufferedIO a, Typeable a)
instance RawHandle (Io NativeHandle) where
toHANDLE = getNativeHandle
fromHANDLE = NativeHandle
-- In order to convert to a native handle we have to check to see
-- is the handle can be used async or not.
fromHANDLE = flip NativeHandle True
isLockable _ = True
setCooked = const . return
isCooked _ = return False
......@@ -184,7 +194,7 @@ instance GHC.IO.Device.IODevice (Io NativeHandle) where
-- | @since 4.11.0.0
instance GHC.IO.Device.IODevice (Io ConsoleHandle) where
ready = handle_ready
close = handle_close . convertHandle
close = handle_close . flip convertHandle False
isTerminal = handle_is_console
isSeekable = handle_is_seekable
seek = handle_console_seek
......@@ -420,9 +430,11 @@ type LPSECURITY_ATTRIBUTES = LPVOID
-- am choosing never to let this block. But this can be easily accomplished by
-- a getOverlappedResult call with True
hwndRead :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
hwndRead hwnd ptr offset bytes
= fmap fromIntegral $ Mgr.withException "hwndRead" $
withOverlapped "hwndRead" (toHANDLE hwnd) offset (startCB ptr) completionCB
hwndRead hwnd ptr offset bytes = do
mngr <- Mgr.getSystemManager
fmap fromIntegral $ Mgr.withException "hwndRead" $
withOverlappedEx mngr "hwndRead" (toHANDLE hwnd) (isAsynchronous hwnd)
offset (startCB ptr) completionCB
where
startCB outBuf lpOverlapped = do
debugIO ":: hwndRead"
......@@ -448,8 +460,10 @@ hwndRead hwnd ptr offset bytes
hwndReadNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int
-> IO (Maybe Int)
hwndReadNonBlocking hwnd ptr offset bytes
= do val <- withOverlapped "hwndReadNonBlocking" (toHANDLE hwnd) offset
(startCB ptr) completionCB
= do mngr <- Mgr.getSystemManager
val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)
(isAsynchronous hwnd) offset (startCB ptr)
completionCB
return $ ioValue val
where
startCB inputBuf lpOverlapped = do
......@@ -471,9 +485,11 @@ hwndReadNonBlocking hwnd ptr offset bytes
hwndWrite :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO ()
hwndWrite hwnd ptr offset bytes
= do _ <- Mgr.withException "hwndWrite" $
withOverlapped "hwndWrite" (toHANDLE hwnd) offset (startCB ptr)
completionCB
= do mngr <- Mgr.getSystemManager
_ <- Mgr.withException "hwndWrite" $
withOverlappedEx mngr "hwndWrite" (toHANDLE hwnd)
(isAsynchronous hwnd) offset (startCB ptr)
completionCB
return ()
where
startCB outBuf lpOverlapped = do
......@@ -490,8 +506,10 @@ hwndWrite hwnd ptr offset bytes
hwndWriteNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
hwndWriteNonBlocking hwnd ptr offset bytes
= do val <- withOverlapped "hwndReadNonBlocking" (toHANDLE hwnd) offset
(startCB ptr) completionCB
= do mngr <- Mgr.getSystemManager
val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)
(isAsynchronous hwnd) offset (startCB ptr)
completionCB
return $ fromIntegral $ ioValue val
where
startCB :: Ptr a -> LPOVERLAPPED -> IO (Mgr.CbResult a1)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment