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

4 files changed, 125 insertions, 27 deletions

diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index bb58f4d1cd..a695df71d2 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -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.
diff --git a/libraries/base/GHC/Event/Windows/FFI.hsc b/libraries/base/GHC/Event/Windows/FFI.hsc
index f8ea13b4a0..c9c96d9d1e 100644
--- a/libraries/base/GHC/Event/Windows/FFI.hsc
+++ b/libraries/base/GHC/Event/Windows/FFI.hsc
@@ -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
diff --git a/libraries/base/GHC/IO/Handle/Windows.hs b/libraries/base/GHC/IO/Handle/Windows.hs
index 19efbea3b5..0666ce42e3 100644
--- a/libraries/base/GHC/IO/Handle/Windows.hs
+++ b/libraries/base/GHC/IO/Handle/Windows.hs
@@ -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.
diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc
index 9a28b0dda2..bee7bc73a2 100644
--- a/libraries/base/GHC/IO/Windows/Handle.hsc
+++ b/libraries/base/GHC/IO/Windows/Handle.hsc
@@ -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)