winio: Various fixes related to rebase and testdriver

8 files changed, 137 insertions, 39 deletions

diff --git a/Makefile b/Makefile
index d7885995d0..cf15d1c086 100644
--- a/Makefile
+++ b/Makefile
@@ -217,15 +217,15 @@ endif
 # test`, runs each test at least once.
 .PHONY: fasttest
 fasttest:
-	$(MAKE) -C testsuite/tests CLEANUP=1 SUMMARY_FILE=../../testsuite_summary.txt fast
+	$(MAKE) -C testsuite/tests SUMMARY_FILE=../../testsuite_summary.txt fast
 
 .PHONY: test
 test:
-	$(MAKE) -C testsuite/tests CLEANUP=1 SUMMARY_FILE=../../testsuite_summary.txt
+	$(MAKE) -C testsuite/tests SUMMARY_FILE=../../testsuite_summary.txt
 
 .PHONY: slowtest fulltest
 slowtest fulltest:
-	$(MAKE) -C testsuite/tests CLEANUP=1 SUMMARY_FILE=../../testsuite_summary.txt slow
+	$(MAKE) -C testsuite/tests SUMMARY_FILE=../../testsuite_summary.txt slow
 
 .PHONY: fast
 fast:
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 83e637401e..81a141afee 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1980,6 +1980,7 @@ doCpp dflags raw input_fn output_fn = do
 
     let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags
         targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags
+        isWindows = (platformOS $ targetPlatform dflags) == OSMinGW32
     let target_defs =
           [ "-D" ++ HOST_OS     ++ "_BUILD_OS",
             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",
@@ -1988,6 +1989,10 @@ doCpp dflags raw input_fn output_fn = do
         -- remember, in code we *compile*, the HOST is the same our TARGET,
         -- and BUILD is the same as our HOST.
 
+    let io_manager_defs =
+          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
+          [ "-D__IO_MANAGER_MIO__=1"               ]
+
     let sse_defs =
           [ "-D__SSE__"      | isSseEnabled      dflags ] ++
           [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
@@ -2033,6 +2038,7 @@ doCpp dflags raw input_fn output_fn = do
                     ++ map GHC.SysTools.Option hscpp_opts
                     ++ map GHC.SysTools.Option sse_defs
                     ++ map GHC.SysTools.Option avx_defs
+                    ++ map GHC.SysTools.Option io_manager_defs
                     ++ mb_macro_include
         -- Set the language mode to assembler-with-cpp when preprocessing. This
         -- alleviates some of the C99 macro rules relating to whitespace and the hash
diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs
index 039c1d12aa..fec6ecff15 100644
--- a/compiler/GHC/SysTools/Info.hs
+++ b/compiler/GHC/SysTools/Info.hs
@@ -241,7 +241,7 @@ getCompilerInfo' dflags = do
         | any ("Apple clang version" `isPrefixOf`) stde =
           return AppleClang
          -- Unknown linker.
-        | otherwise = fail "invalid -v output, or compiler is unsupported"
+        | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde
 
   -- Process the executable call
   info <- catchIO (do
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index 113f0c0eb9..5f65767fab 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -482,6 +482,7 @@ data CbResult a
   | CbError a            -- ^ I/O request abort, return failure immediately
   | CbNone Bool          -- ^ The caller did not do any checking, the I/O
                          --   manager will perform additional checks.
+    deriving Show
 
 -- | Called when the completion is delivered.
 type CompletionCallback a = ErrCode   -- ^ 0 indicates success
@@ -495,12 +496,20 @@ associateHandle' hwnd
   = do mngr <- getSystemManager
        associateHandle mngr hwnd
 
+-- | A handle value representing an invalid handle.
+invalidHandle :: HANDLE
+invalidHandle = intPtrToPtr (#{const INVALID_HANDLE_VALUE})
+
 -- | Associate a 'HANDLE' with the I/O manager's completion port.  This must be
 -- done before using the handle with 'withOverlapped'.
 associateHandle :: Manager -> HANDLE -> IO ()
 associateHandle Manager{..} h =
-    -- Use as completion key the file handle itself, so we can track completion
-    FFI.associateHandleWithIOCP mgrIOCP h (fromIntegral $ ptrToWordPtr h)
+    -- Don't try to if the handle is invalid.  This can happen with i.e a closed
+    -- std handle.
+    when (h /= invalidHandle) $
+      -- Use as completion key the file handle itself, so we can track
+      -- completion
+      FFI.associateHandleWithIOCP mgrIOCP h (fromIntegral $ ptrToWordPtr h)
 
 -- | Start an overlapped I/O operation, and wait for its completion.  If
 -- 'withOverlapped' is interrupted by an asynchronous exception, the operation
@@ -543,7 +552,6 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
         --       time.  This would allow us to scale better.
         cdData <- new (CompletionData h completionCB')
         let ptr_lpol = hs_lpol `plusPtr` cdOffset
-        poke ptr_lpol cdData
         let lpol = castPtr hs_lpol
         debugIO $ "hs_lpol:" ++ show hs_lpol
                 ++ " cdData:" ++ show cdData
@@ -562,25 +570,27 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
           -- synchronously we've requested to not have the completion queued.
           let result' =
                 case result of
-                  CbNone ret | success == #{const STATUS_SUCCESS}      -> CbDone Nothing
-                             | success == #{const STATUS_END_OF_FILE}  -> CbDone Nothing
-                             | success == #{const STATUS_PENDING}      -> CbPending
+                  CbNone ret | success == #{const STATUS_SUCCESS}          -> CbDone Nothing
+                             | success == #{const STATUS_END_OF_FILE}      -> CbDone Nothing
+                             | success == #{const STATUS_PENDING}          -> CbPending
                              -- Buffer was too small.. not sure what to do, so I'll just
                              -- complete the read request
-                             | err     == #{const ERROR_MORE_DATA}     -> CbDone Nothing
-                             | err     == #{const ERROR_SUCCESS}       -> CbDone Nothing
-                             | err     == #{const ERROR_IO_PENDING}    -> CbPending
-                             | err     == #{const ERROR_IO_INCOMPLETE} -> CbIncomplete
-                             | err     == #{const ERROR_HANDLE_EOF}    -> CbDone Nothing
-                             | not ret                                 -> CbError err
-                             | otherwise                               -> CbPending
-                  _                                                    -> result
+                             | err     == #{const ERROR_MORE_DATA}         -> CbDone Nothing
+                             | err     == #{const ERROR_SUCCESS}           -> CbDone Nothing
+                             | err     == #{const ERROR_IO_PENDING}        -> CbPending
+                             | err     == #{const ERROR_IO_INCOMPLETE}     -> CbIncomplete
+                             | err     == #{const ERROR_HANDLE_EOF}        -> CbDone Nothing
+                             | err     == #{const ERROR_BROKEN_PIPE}       -> CbDone Nothing
+                             | err     == #{const ERROR_OPERATION_ABORTED} -> CbDone Nothing
+                             | not ret                                     -> CbError err
+                             | otherwise                                   -> CbPending
+                  _                                                        -> result
           case result' of
             CbNone    _ -> error "shouldn't happen."
             CbIncomplete -> do
                debugIO $ "handling incomplete request synchronously " ++ show (h, lpol)
                res <- spinWaitComplete h lpol
-               debugIO $ "done blocking request " ++ show (h, lpol)
+               debugIO $ "done blocking request 2: " ++ show (h, lpol) ++ " - " ++ show res
                return res
             CbPending   -> do
               -- Before we enqueue check to see if operation finished in the
@@ -599,6 +609,8 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                                || status == #{const STATUS_END_OF_FILE}
                                || lasterr == #{const ERROR_HANDLE_EOF}
                                || lasterr == #{const ERROR_SUCCESS}
+                               || lasterr == #{const ERROR_BROKEN_PIPE}
+                               || lasterr == #{const ERROR_OPERATION_ABORTED}
               -- This status indicates that the request hasn't finished early,
               -- but it will finish shortly.  The I/O manager will not be
               -- enqueuing this either.  Also needs to be handled inline.
@@ -608,15 +620,22 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
               case (finished, done_early, will_finish_sync) of
                 -- Still pending
                 (Nothing, False, False) -> do
+                    -- Since FILE_SKIP_COMPLETION_PORT_ON_SUCCESS can't be
+                    -- relied on for non-file handles we need a way to prevent
+                    -- us from handling a request inline and handle a completion
+                    -- event handled without a queued I/O operation.  We can do
+                    -- this by deferring the setting data pointer until we know
+                    -- the request will be handled async.
+                    poke ptr_lpol cdData
                     reqs <- addRequest
                     debugIO $ "+1.. " ++ show reqs ++ " requests queued. | " ++ show lpol
-                    wakeupIOManager
+                    --wakeupIOManager
                     return result'
                 -- In progress, we will wait for completion.
                 (Nothing, False, True) -> do
                   debugIO $ "handling incomplete request synchronously " ++ show (h, lpol)
                   res <- spinWaitComplete h lpol
-                  debugIO $ "done blocking request " ++ show (h, lpol)
+                  debugIO $ "done blocking request 1: " ++ show (h, lpol) ++ " - " ++ show res
                   return res
                 _                -> do
                   debugIO "request handled immediately (o/b), not queued."
@@ -668,6 +687,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                         then return rdata
                         -- Make sure it's safe to free the OVERLAPPED buffer
                         else FFI.getOverlappedResult h lpol False
+            debugIO $ dbg $ ":: done bytes: " ++ show bytes
             case bytes of
               Just res ->  completionCB 0 res -- free hs_lpol >> completionCB 0 res
               Nothing  -> do err <- FFI.overlappedIOStatus lpol
@@ -676,6 +696,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                              -- of re-interpret here. But for now, don't care.
                              let err' = fromIntegral err
                              -- free hs_lpol
+                             debugIO $ dbg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
                              completionCB err' (fromIntegral numBytes)
           CbError err  -> do
             free cdData
@@ -700,6 +721,13 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                   return $ CbDone res
                         | otherwise ->
                   do m <- newEmptyIOPort
+                     lasterr <- fmap fromIntegral getLastError :: IO Int
+                     let done =
+                            lasterr == #{const ERROR_HANDLE_EOF}
+                            || lasterr == #{const ERROR_SUCCESS}
+                            || lasterr == #{const ERROR_BROKEN_PIPE}
+                            || lasterr == #{const ERROR_OPERATION_ABORTED}
+                     debugIO $ ":: loop - " ++ show lasterr ++ " :" ++ show done
                      -- We will complete quite soon, in the threaded RTS we
                      -- probably don't really want to wait for it while we could
                      -- have done something else.  In particular this is because
@@ -718,7 +746,9 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                        reg <- registerTimeout mgr usecs $
                                 writeIOPort m () >> return ()
                        readIOPort m `onException` unregisterTimeout mgr reg
-                     spinWaitComplete fhndl lpol
+                     if done
+                        then return $ CbDone Nothing
+                        else spinWaitComplete fhndl lpol
                 Just _ -> do
                    when (not threadedIOMgr) completeSynchronousRequest
                    return $ CbDone res
@@ -814,7 +844,7 @@ unregisterTimeout mgr (TK key) = do
 editTimeouts :: Manager -> TimeoutEdit -> IO ()
 editTimeouts mgr g = do
   atomicModifyIORef' (mgrTimeouts mgr) $ \tq -> (g tq, ())
-  wakeupIOManager
+  interruptSystemManager
 
 ------------------------------------------------------------------------
 -- I/O manager loop
@@ -977,11 +1007,12 @@ processCompletion Manager{..} n delay = do
                     ++ " cdData: " ++ show cdDataCheck
                     ++ " at idx " ++ show idx
           let oldDataPtr = exchangePtr ptr_lpol nullReq
-          when (oldDataPtr /= nullReq) $
-            do payload <- peek oldDataPtr
-               debugIO $ "exchanged: " ++ show oldDataPtr
+          debugIO $ ":: oldDataPtr " ++ show oldDataPtr
+          when (oldDataPtr /= nullPtr && oldDataPtr /= nullReq) $
+            do debugIO $ "exchanged: " ++ show oldDataPtr
+               payload <- peek oldDataPtr
                let !(CompletionData _hwnd cb) = payload
-               -- free oldDataPtr
+               free oldDataPtr
                reqs <- removeRequest
                debugIO $ "-1.. " ++ show reqs ++ " requests queued."
                status <- FFI.overlappedIOStatus (lpOverlapped oe)
@@ -989,7 +1020,7 @@ processCompletion Manager{..} n delay = do
                -- of re-interpret here. But for now, don't care.
                let status' = fromIntegral status
                cb status' (dwNumberOfBytesTransferred oe)
-               -- free hs_lpol
+               free hs_lpol
 
       -- clear the array so we don't erroneously interpret the output, in
       -- certain circumstances like lockFileEx the code could return 1 entry
diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc
index 1611ece011..9fc8d9af6d 100644
--- a/libraries/base/GHC/IO/Windows/Handle.hsc
+++ b/libraries/base/GHC/IO/Windows/Handle.hsc
@@ -34,6 +34,9 @@ module GHC.IO.Windows.Handle
    -- * Utility functions
    convertHandle,
    toHANDLE,
+   fromHANDLE,
+   handleToMode,
+   optimizeFileAccess,
 
    -- * Standard Handles
    stdin,
@@ -48,10 +51,11 @@ module GHC.IO.Windows.Handle
 
 #include <windows.h>
 #include <ntstatus.h>
+#include <winnt.h>
 ##include "windows_cconv.h"
 
-import Data.Bits ((.|.), shiftL)
-import Data.Word (Word8, Word16, Word64)
+-- Can't avoid these semantics leaks, they are base constructs
+import Data.Bits ((.|.), (.&.), shiftL)
 import Data.Functor ((<$>))
 import Data.Typeable
 
@@ -60,8 +64,9 @@ import GHC.Enum
 import GHC.Num
 import GHC.Real
 import GHC.List
+import GHC.Word (Word8, Word16, Word64)
 
-import GHC.IO
+import GHC.IO hiding (mask)
 import GHC.IO.Buffer
 import GHC.IO.BufferedIO
 import qualified GHC.IO.Device
@@ -430,6 +435,8 @@ hwndRead hwnd ptr offset bytes
       | err == #{const ERROR_SUCCESS}      = Mgr.ioSuccess $ fromIntegral dwBytes
       | err == #{const ERROR_HANDLE_EOF}   = Mgr.ioSuccess 0
       | err == #{const STATUS_END_OF_FILE} = Mgr.ioSuccess 0
+      | err == #{const ERROR_BROKEN_PIPE}  = Mgr.ioSuccess 0
+      | err == #{const STATUS_PIPE_BROKEN} = Mgr.ioSuccess 0
       | err == #{const ERROR_MORE_DATA}    = Mgr.ioSuccess $ fromIntegral dwBytes
       | otherwise                          = Mgr.ioFailed err
 
@@ -455,6 +462,8 @@ hwndReadNonBlocking hwnd ptr offset bytes
       | err == #{const ERROR_SUCCESS}      = Mgr.ioSuccess $ fromIntegral dwBytes
       | err == #{const ERROR_HANDLE_EOF}   = Mgr.ioSuccess 0
       | err == #{const STATUS_END_OF_FILE} = Mgr.ioSuccess 0
+      | err == #{const ERROR_BROKEN_PIPE}  = Mgr.ioSuccess 0
+      | err == #{const STATUS_PIPE_BROKEN} = Mgr.ioSuccess 0
       | otherwise                          = Mgr.ioFailed err
 
 hwndWrite :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO ()
@@ -583,7 +592,7 @@ consoleRead hwnd ptr _offset bytes
               else do w_first <- peekElemOff w_ptr 0
                       case () of
                         -- Handle Ctrl+Z which is the actual EOL sequence on
-                        -- windows, but also hanlde Ctrl+D which is what the
+                        -- windows, but also handle Ctrl+D which is what the
                         -- ASCII standard defines as EOL.
                         _ | w_first == fromIntegral acCtrlD -> return 0
                           | w_first == fromIntegral acCtrlZ -> return 0
@@ -938,6 +947,22 @@ optimizeFileAccess handle =
           (    #{const FILE_SKIP_COMPLETION_PORT_ON_SUCCESS}
             .|. #{const FILE_SKIP_SET_EVENT_ON_HANDLE})
 
+-- Reconstruct an I/O mode from an open HANDLE
+handleToMode :: HANDLE -> IO IOMode
+handleToMode hwnd = do
+  mask <- c_get_handle_access_mask hwnd
+  let flag = flagOn mask
+  case () of
+    () | flag (#{const FILE_APPEND_DATA})                        -> return AppendMode
+       | flag (#{const GENERIC_WRITE} .|. #{const GENERIC_READ}) -> return ReadWriteMode
+       | flag (#{const GENERIC_READ})                            -> return ReadMode
+       | flag (#{const GENERIC_WRITE})                           -> return WriteMode
+       | otherwise -> error "unknown access mask in handleToMode."
+    where flagOn mask v = (v .&. mask) == v
+
+foreign import ccall unsafe "__get_handle_access_mask"
+  c_get_handle_access_mask :: HANDLE -> IO DWORD
+
 release :: RawHandle a => a -> IO ()
 release h = if isLockable h
                then do let handle = fromIntegral $ ptrToWordPtr $ toHANDLE h
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 591368931e..fb6887911a 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -377,8 +377,9 @@ Library
         -- ws2_32: provides access to socket types and functions
         -- ole32: provides UUID functionality.
         -- rpcrt4: provides RPC UUID creation.
+        -- ntdll: provides access to functions to inspect window handles
         extra-libraries: wsock32, user32, shell32, msvcrt, mingw32,
-                         mingwex, ws2_32, shlwapi, ole32, rpcrt4
+                         mingwex, ws2_32, shlwapi, ole32, rpcrt4, ntdll
         -- Minimum supported Windows version.
         -- These numbers can be found at:
         --  https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index 4181e6105f..345e46811b 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -17,6 +17,8 @@
 #include <windows.h>
 #include <io.h>
 #include <objbase.h>
+#include <ntstatus.h>
+#include <winternl.h>
 #include "fs.h"
 
 /* This is the error table that defines the mapping between OS error
@@ -210,6 +212,31 @@ fail:
   return false;
 }
 
+
+/* Seems to be part of the Windows SDK so provide an inline definition for
+   use and rename it so it doesn't conflict for people who do have the SDK.  */
+
+typedef struct _MY_PUBLIC_OBJECT_BASIC_INFORMATION {
+  ULONG Attributes;
+  ACCESS_MASK GrantedAccess;
+  ULONG HandleCount;
+  ULONG PointerCount;
+  ULONG Reserved[10];
+ } MY_PUBLIC_OBJECT_BASIC_INFORMATION, *PMY_PUBLIC_OBJECT_BASIC_INFORMATION;
+
+ACCESS_MASK __get_handle_access_mask (HANDLE handle)
+{
+  MY_PUBLIC_OBJECT_BASIC_INFORMATION obi;
+  if (STATUS_SUCCESS != NtQueryObject(handle, ObjectBasicInformation, &obi,
+                                      sizeof(obi), NULL))
+  {
+    return obi.GrantedAccess;
+  }
+
+  maperrno();
+  return 0;
+}
+
 bool getTempFileNameErrorNo (wchar_t* pathName, wchar_t* prefix,
                              wchar_t* suffix, uint32_t uUnique,
                              wchar_t* tempFileName)
diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c
index 8a9a647160..70b4455c71 100644
--- a/rts/win32/AsyncWinIO.c
+++ b/rts/win32/AsyncWinIO.c
@@ -387,14 +387,22 @@ void registerAlertableWait (bool has_timeout, DWORD mssec, uint64_t num_req, boo
    finished overlapped entried belonging to the completed I/O requests.  The
    number of read entries will be returned in NUM.
 
-   NOTE: This function isn't thread safe, but is intended to be called only
-         when requested by the I/O manager via notifyScheduler.  In
-         that context it is thread safe as we're guaranteeing that the I/O
-         manager is blocked waiting for the read to happen followed by a
-         registerAlertableWait call.  */
+   We clear the outstanding request flag to prevent two threads from handling
+   the same payload early on.  Failing this the final safe guard is in
+   processCompletions.  */
 OVERLAPPED_ENTRY* getOverlappedEntries (uint32_t *num)
 {
-  *num = num_last_completed;
+  AcquireSRWLockExclusive (&lock);
+
+  if (outstanding_service_requests)
+    *num = num_last_completed;
+  else
+    *num = 0;
+
+  outstanding_service_requests = false;
+
+  ReleaseSRWLockExclusive (&lock);
+
   return entries;
 }