diff options
| -rw-r--r-- | Makefile | 6 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/SysTools/Info.hs | 2 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/Windows.hsc | 79 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Windows/Handle.hsc | 33 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 3 | ||||
| -rw-r--r-- | libraries/base/cbits/Win32Utils.c | 27 | ||||
| -rw-r--r-- | rts/win32/AsyncWinIO.c | 20 |
8 files changed, 137 insertions, 39 deletions
@@ -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; } |