diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2020-07-16 10:56:54 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-07-16 10:56:54 -0400 |
| commit | c0979cc53442b3a6202acab9cf164f0a4beea0b7 (patch) | |
| tree | d08b956887e69f9bd2959f1ac75cc2a2182f9a32 | |
| parent | ae11bdfd98a10266bfc7de9e16b500be220307ac (diff) | |
| parent | 2143c49273d7d87ee2f3ef1211856d60b1427af1 (diff) | |
| download | haskell-c0979cc53442b3a6202acab9cf164f0a4beea0b7.tar.gz | |
Merge remote-tracking branch 'origin/wip/winio'
156 files changed, 7450 insertions, 1192 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/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 02a10d4b35..b9ef184923 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1747,7 +1747,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, eqTyConKey, heqTyConKey, + stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, stringTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 @@ -1783,11 +1783,12 @@ mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 orderingTyConKey = mkPreludeTyConUnique 32 mVarPrimTyConKey = mkPreludeTyConUnique 33 -ratioTyConKey = mkPreludeTyConUnique 34 -rationalTyConKey = mkPreludeTyConUnique 35 -realWorldTyConKey = mkPreludeTyConUnique 36 -stablePtrPrimTyConKey = mkPreludeTyConUnique 37 -stablePtrTyConKey = mkPreludeTyConUnique 38 +ioPortPrimTyConKey = mkPreludeTyConUnique 34 +ratioTyConKey = mkPreludeTyConUnique 35 +rationalTyConKey = mkPreludeTyConUnique 36 +realWorldTyConKey = mkPreludeTyConUnique 37 +stablePtrPrimTyConKey = mkPreludeTyConUnique 38 +stablePtrTyConKey = mkPreludeTyConUnique 39 eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 88ef943a64..13f08739d0 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -62,6 +62,7 @@ module GHC.Builtin.Types.Prim( mutVarPrimTyCon, mkMutVarPrimTy, mVarPrimTyCon, mkMVarPrimTy, + ioPortPrimTyCon, mkIOPortPrimTy, tVarPrimTyCon, mkTVarPrimTy, stablePtrPrimTyCon, mkStablePtrPrimTy, stableNamePrimTyCon, mkStableNamePrimTy, @@ -171,6 +172,7 @@ exposedPrimTyCons , mutableArrayArrayPrimTyCon , smallMutableArrayPrimTyCon , mVarPrimTyCon + , ioPortPrimTyCon , tVarPrimTyCon , mutVarPrimTyCon , realWorldTyCon @@ -207,7 +209,7 @@ mkBuiltInPrimTc fs unique tycon BuiltInSyntax -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon @@ -238,6 +240,7 @@ mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByte mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +ioPortPrimTyConName = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon @@ -1006,7 +1009,22 @@ mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] {- ************************************************************************ * * +\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type} +* * +************************************************************************ +-} + +ioPortPrimTyCon :: TyCon +ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep + +mkIOPortPrimTy :: Type -> Type -> Type +mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [s, elt] + +{- +************************************************************************ +* * The synchronizing variable type +\subsection[TysPrim-synch-var]{The synchronizing variable type} * * ************************************************************************ -} diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index a12ac1f29c..261d02aa67 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -2827,6 +2827,45 @@ primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp out_of_line = True has_side_effects = True + +------------------------------------------------------------------------ +section "Synchronized I/O Ports" + {Operations on {\tt IOPort\#}s. } +------------------------------------------------------------------------ + +primtype IOPort# s a + { A shared I/O port is almost the same as a {\tt MVar\#}!). + The main difference is that IOPort has no deadlock detection or + deadlock breaking code that forcibly releases the lock. } + +primop NewIOPortrOp "newIOPort#" GenPrimOp + State# s -> (# State# s, IOPort# s a #) + {Create new {\tt IOPort\#}; initially empty.} + with + out_of_line = True + has_side_effects = True + +primop ReadIOPortOp "readIOPort#" GenPrimOp + IOPort# s a -> State# s -> (# State# s, a #) + {If {\tt IOPort\#} is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + out_of_line = True + has_side_effects = True + +primop WriteIOPortOp "writeIOPort#" GenPrimOp + IOPort# s a -> a -> State# s -> (# State# s, Int# #) + {If {\tt IOPort\#} is full, immediately return with integer 0. + Otherwise, store value arg as {\tt IOPort\#}'s new contents, + and return with integer 1. } + with + out_of_line = True + has_side_effects = True + +primop SameIOPortOp "sameIOPort#" GenPrimOp + IOPort# s a -> IOPort# s a -> Int# + + ------------------------------------------------------------------------ section "Delay/wait operations" ------------------------------------------------------------------------ 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/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index ef5e376be8..afbcc34836 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1320,6 +1320,7 @@ emitPrimOp dflags primop = case primop of SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform) SameMVarOp -> \args -> opTranslate args (mo_wordEq platform) + SameIOPortOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform) SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform) @@ -1467,6 +1468,9 @@ emitPrimOp dflags primop = case primop of ReadMVarOp -> alwaysExternal TryReadMVarOp -> alwaysExternal IsEmptyMVarOp -> alwaysExternal + NewIOPortrOp -> alwaysExternal + ReadIOPortOp -> alwaysExternal + WriteIOPortOp -> alwaysExternal DelayOp -> alwaysExternal WaitReadOp -> alwaysExternal WaitWriteOp -> alwaysExternal 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/configure.ac b/configure.ac index 6e710c7f8d..d3ef6eee62 100644 --- a/configure.ac +++ b/configure.ac @@ -117,6 +117,18 @@ if test "$EnableDistroToolchain" = "YES"; then TarballsAutodownload=NO fi +AC_ARG_ENABLE(native-io-manager, +[AC_HELP_STRING([--enable-native-io-manager], + [Enable the native I/O manager by default.])], + EnableNativeIOManager=YES, + EnableNativeIOManager=NO +) + +if test "$EnableNativeIOManager" = "YES"; then + AC_DEFINE_UNQUOTED([DEFAULT_NATIVE_IO_MANAGER], [1], [Enable Native I/O manager as default.]) + +fi + dnl CC_STAGE0, LD_STAGE0, AR_STAGE0 are like the "previous" variable dnl CC, LD, AR (inherited by CC_STAGE[123], etc.) dnl but instead used by stage0 for bootstrapping stage1 diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index 8c9d7875d4..42e95f6664 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -368,7 +368,6 @@ rtsPackageArgs = package rts ? do , input "**/RetainerProfile.c" ? flag CcLlvmBackend ? arg "-Wno-incompatible-pointer-types" - , windowsHost ? arg ("-DWINVER=" ++ windowsVersion) -- libffi's ffi.h triggers various warnings , inputs [ "**/Interpreter.c", "**/Storage.c", "**/Adjustor.c" ] ? @@ -455,12 +454,3 @@ rtsWarnings = mconcat , arg "-Wredundant-decls" , arg "-Wundef" , arg "-fno-strict-aliasing" ] - --- These numbers can be found at: --- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx --- If we're compiling on windows, enforce that we only support Vista SP1+ --- Adding this here means it doesn't have to be done in individual .c files --- and also centralizes the versioning. --- | Minimum supported Windows version. -windowsVersion :: String -windowsVersion = "0x06010000" diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index c2cad8fc80..043099bd1a 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -256,7 +256,13 @@ by tryWakeupThread() */ #define ThreadMigrating 13 -/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */ +/* Lightweight non-deadlock checked version of MVar. Used for the why_blocked + field of a TSO. Threads blocked for this reason are not forcibly release by + the GC, as we expect them to be unblocked in the future based on outstanding + IO events. */ +#define BlockedOnIOCompletion 15 + +/* Next number is 16. */ /* * These constants are returned to the scheduler by a thread that has diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h index 978ccf86b6..69df911595 100644 --- a/includes/rts/FileLock.h +++ b/includes/rts/FileLock.h @@ -11,9 +11,27 @@ * * ---------------------------------------------------------------------------*/ +/* Note [RTS File locking] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * + * The Haskell report dictates certain file locking behaviour. + * This is specified in the Haskell98 report under: 21.2.3 File locking + * + * GHC does not rely on the platform it's on to implement this. + * Instead we keep track of locked files in a data structure in + * the RTS. This file provides the interface to this data structure. + * + * In the base librarie we then use this interface to "lock" files. + * This means it's very much still possible for users outside of the + * rts/base library to open the files in question even if they are + * locked. + * */ + #pragma once #include "Stg.h" -int lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing); -int unlockFile(int fd); +/* No valid FD would be negative, so use a word instead of int so the value + is compatible with a Windows handle. */ +int lockFile(StgWord64 id, StgWord64 dev, StgWord64 ino, int for_writing); +int unlockFile(StgWord64 id); diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index d0c41a1576..bf84c5dc96 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -206,6 +206,9 @@ typedef struct _CONCURRENT_FLAGS { #define DEFAULT_LINKER_ALWAYS_PIC false #endif +/* Which I/O Manager to use in the target program. */ +typedef enum _IO_MANAGER { IO_MNGR_NATIVE, IO_MNGR_POSIX } IO_MANAGER; + /* See Note [Synchronization of flags and base APIs] */ typedef struct _MISC_FLAGS { Time tickInterval; /* units: TIME_RESOLUTION */ @@ -224,6 +227,8 @@ typedef struct _MISC_FLAGS { bool linkerAlwaysPic; /* Assume the object code is always PIC */ StgWord linkerMemBase; /* address to ask the OS for memory * for the linker, NULL ==> off */ + IO_MANAGER ioManager; /* The I/O manager to use. */ + uint32_t numIoWorkerThreads; /* Number of I/O worker threads to use. */ } MISC_FLAGS; /* See Note [Synchronization of flags and base APIs] */ diff --git a/includes/rts/IOManager.h b/includes/rts/IOManager.h index 603cb3f578..4c392e2058 100644 --- a/includes/rts/IOManager.h +++ b/includes/rts/IOManager.h @@ -15,6 +15,11 @@ #if defined(mingw32_HOST_OS) +#define IO_MANAGER_WAKEUP 0xffffffff +#define IO_MANAGER_DIE 0xfffffffe +/* spurious wakeups are returned as zero. */ +/* console events are ((event<<1) | 1). */ + int rts_InstallConsoleEvent ( int action, StgStablePtr *handler ); void rts_ConsoleHandlerDone ( int ev ); extern StgInt console_handler; @@ -31,13 +36,15 @@ void setIOManagerWakeupFd (int fd); #endif -// -// Communicating with the IO manager thread (see GHC.Conc). -// Posix implementation in posix/Signals.c -// Win32 implementation in win32/ThrIOManager.c -// +/* + * Communicating with the IO manager thread (see GHC.Conc). + * Posix implementation in posix/Signals.c + * Win32 implementation in win32/ThrIOManager.c, Windows's WINIO has the same + * interfaces for Threaded and Non-threaded I/O, so these methods are always + * available for WINIO. +*/ void ioManagerWakeup (void); -#if defined(THREADED_RTS) +#if defined(THREADED_RTS) || defined(mingw32_HOST_OS) void ioManagerDie (void); void ioManagerStart (void); #endif diff --git a/includes/rts/OSThreads.h b/includes/rts/OSThreads.h index ada2a9a787..a68f1ea140 100644 --- a/includes/rts/OSThreads.h +++ b/includes/rts/OSThreads.h @@ -77,18 +77,22 @@ EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex) #if defined(CMINUSMINUS) -/* We jump through a hoop here to get a CCall EnterCriticalSection - and LeaveCriticalSection, as that's what C-- wants. */ +/* We jump through a hoop here to get a CCall AcquireSRWLockExclusive + and ReleaseSRWLockExclusive, as that's what C-- wants. */ -#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" EnterCriticalSection(mutex) -#define OS_RELEASE_LOCK(mutex) foreign "stdcall" LeaveCriticalSection(mutex) +#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" AcquireSRWLockExclusive(mutex) +#define OS_RELEASE_LOCK(mutex) foreign "stdcall" ReleaseSRWLockExclusive(mutex) #define OS_ASSERT_LOCK_HELD(mutex) /* nothing */ -#else +#else // CMINUSMINUS #include <windows.h> +#include <synchapi.h> -typedef HANDLE Condition; +/* Use native conditional variables coupled with SRW locks, these are more + efficient and occur a smaller overhead then emulating them with events. + See Note [SRW locks]. */ +typedef CONDITION_VARIABLE Condition; typedef DWORD OSThreadId; // don't be tempted to use HANDLE as the OSThreadId: there can be // many HANDLES to a given thread, so comparison would not work. @@ -98,58 +102,47 @@ typedef DWORD ThreadLocalKey; #define INIT_COND_VAR 0 -// We have a choice for implementing Mutexes on Windows. Standard -// Mutexes are kernel objects that require kernel calls to -// acquire/release, whereas CriticalSections are spin-locks that block -// in the kernel after spinning for a configurable number of times. -// CriticalSections are *much* faster, so we use those. The Mutex -// implementation is left here for posterity. -#define USE_CRITICAL_SECTIONS 1 - -#if USE_CRITICAL_SECTIONS - -typedef CRITICAL_SECTION Mutex; +/* Note [SRW locks] + We have a choice for implementing Mutexes on Windows. Standard + Mutexes are kernel objects that require kernel calls to + acquire/release, whereas CriticalSections are spin-locks that block + in the kernel after spinning for a configurable number of times. + CriticalSections are *much* faster than Mutexes, however not as fast as + slim reader/writer locks. CriticalSections also require a 48 byte structure + to provide lock re-entrancy. We don't need that because the other primitives + used for other platforms don't have this, as such locks are used defensively + in the RTS in a way that we don't need re-entrancy. This means that SRW's + 8 byte size is much more appropriate. With an 8 byte payload there's a + higher chance of it being in your cache line. They're also a lot faster than + CriticalSections when multiple threads are involved. CS requires setup and + teardown via kernel calls while SRWL is zero-initialized via + SRWLOCK_INIT assignment. */ + +typedef SRWLOCK Mutex; #if defined(LOCK_DEBUG) #define OS_ACQUIRE_LOCK(mutex) \ debugBelch("ACQUIRE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \ - EnterCriticalSection(mutex) + AcquireSRWLockExclusive(mutex) #define OS_RELEASE_LOCK(mutex) \ debugBelch("RELEASE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \ - LeaveCriticalSection(mutex) + ReleaseSRWLockExclusive(mutex) #define OS_ASSERT_LOCK_HELD(mutex) /* nothing */ #else -#define OS_ACQUIRE_LOCK(mutex) EnterCriticalSection(mutex) -#define TRY_ACQUIRE_LOCK(mutex) (TryEnterCriticalSection(mutex) == 0) -#define OS_RELEASE_LOCK(mutex) LeaveCriticalSection(mutex) +#define OS_ACQUIRE_LOCK(mutex) AcquireSRWLockExclusive(mutex) +#define TRY_ACQUIRE_LOCK(mutex) (TryAcquireSRWLockExclusive(mutex) == 0) +#define OS_RELEASE_LOCK(mutex) ReleaseSRWLockExclusive(mutex) +#define OS_INIT_LOCK(mutex) InitializeSRWLock(mutex) +#define OS_CLOSE_LOCK(mutex) // I don't know how to do this. TryEnterCriticalSection() doesn't do // the right thing. #define OS_ASSERT_LOCK_HELD(mutex) /* nothing */ -#endif - -#else - -typedef HANDLE Mutex; - -// casting to (Mutex *) here required due to use in .cmm files where -// the argument has (void *) type. -#define OS_ACQUIRE_LOCK(mutex) \ - if (WaitForSingleObject(*((Mutex *)mutex),INFINITE) == WAIT_FAILED) { \ - barf("WaitForSingleObject: %d", GetLastError()); \ - } - -#define OS_RELEASE_LOCK(mutex) \ - if (ReleaseMutex(*((Mutex *)mutex)) == 0) { \ - barf("ReleaseMutex: %d", GetLastError()); \ - } - -#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */ -#endif +#endif // LOCK_DEBUG #endif // CMINUSMINUS diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h index 3a488d97b5..33eebffc7c 100644 --- a/includes/rts/storage/TSO.h +++ b/includes/rts/storage/TSO.h @@ -288,6 +288,7 @@ void dirty_STACK (Capability *cap, StgStack *stack); BlockedOnBlackHole MessageBlackHole * TSO->bq BlockedOnMVar the MVAR the MVAR's queue + BlockedOnIOCompletion the PortEVent the IOCP's queue BlockedOnSTM END_TSO_QUEUE STM wait queue(s) BlockedOnSTM STM_AWOKEN run queue diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index dc2b0715ca..5ffdd5cd7b 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -337,6 +337,10 @@ RTS_FUN_DECL(stg_block_stmwait); RTS_FUN_DECL(stg_block_throwto); RTS_RET(stg_block_throwto); +RTS_FUN_DECL(stg_readIOPortzh); +RTS_FUN_DECL(stg_writeIOPortzh); +RTS_FUN_DECL(stg_newIOPortzh); + /* Entry/exit points from StgStartup.cmm */ RTS_RET(stg_stop_thread); diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 8dc7f0db292ff1a5b1316127e3652d06ab51f3a +Subproject 32dad5c1cf70d65ecb93b0ec214445cf9c9f661 diff --git a/libraries/base/Control/Concurrent.hs-boot b/libraries/base/Control/Concurrent.hs-boot new file mode 100644 index 0000000000..213340432e --- /dev/null +++ b/libraries/base/Control/Concurrent.hs-boot @@ -0,0 +1,30 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent +-- Copyright : (c) The University of Glasgow 2018-2019 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (concurrency) +-- +-- A common interface to a collection of useful concurrency +-- abstractions. +-- +----------------------------------------------------------------------------- +module Control.Concurrent ( + -- * Bound Threads + rtsSupportsBoundThreads, + forkOS + ) where + +import Data.Bool + +import GHC.IO +import GHC.Conc.Sync + +rtsSupportsBoundThreads :: Bool +forkOS :: IO () -> IO ThreadId diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index 7b87adc7ea..d65f9c0acf 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -4,7 +4,6 @@ , MagicHash , UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -29,6 +28,7 @@ module GHC.Conc.IO ( ensureIOManagerIsRunning , ioManagerCapabilitiesChanged + , interruptIOManager -- * Waiting , threadDelay @@ -61,6 +61,7 @@ import System.Posix.Types #if defined(mingw32_HOST_OS) import qualified GHC.Conc.Windows as Windows +import GHC.IO.SubSystem import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA, asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler, toWin32ConsoleEvent) @@ -75,6 +76,17 @@ ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning #endif +-- | Interrupts the current wait of the I/O manager if it is currently blocked. +-- This instructs it to re-read how much it should wait and to process any +-- pending events. +-- @since 4.15 +interruptIOManager :: IO () +#if !defined(mingw32_HOST_OS) +interruptIOManager = return () +#else +interruptIOManager = Windows.interruptIOManager +#endif + ioManagerCapabilitiesChanged :: IO () #if !defined(mingw32_HOST_OS) ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged @@ -179,11 +191,12 @@ closeFdWith close fd threadDelay :: Int -> IO () threadDelay time #if defined(mingw32_HOST_OS) - | threaded = Windows.threadDelay time + | isWindowsNativeIO = Windows.threadDelay time + | threaded = Windows.threadDelay time #else - | threaded = Event.threadDelay time + | threaded = Event.threadDelay time #endif - | otherwise = IO $ \s -> + | otherwise = IO $ \s -> case time of { I# time# -> case delay# time# s of { s' -> (# s', () #) }} @@ -195,10 +208,11 @@ threadDelay time registerDelay :: Int -> IO (TVar Bool) registerDelay usecs #if defined(mingw32_HOST_OS) - | threaded = Windows.registerDelay usecs + | isWindowsNativeIO = Windows.registerDelay usecs + | threaded = Windows.registerDelay usecs #else - | threaded = Event.registerDelay usecs + | threaded = Event.registerDelay usecs #endif - | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff --git a/libraries/base/GHC/Conc/POSIX.hs b/libraries/base/GHC/Conc/POSIX.hs new file mode 100644 index 0000000000..84dc68fc30 --- /dev/null +++ b/libraries/base/GHC/Conc/POSIX.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.POSIX +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager +-- +-- This is the I/O manager based on posix FDs for windows. +-- When using the winio manager these functions may not +-- be used as they will behave in unexpected ways. +-- +-- TODO: This manager is currently the default. But we will eventually +-- switch to use winio instead. +-- +----------------------------------------------------------------------------- + +-- #not-home +module GHC.Conc.POSIX + ( ensureIOManagerIsRunning + , interruptIOManager + + -- * Waiting + , threadDelay + , registerDelay + + -- * Miscellaneous + , asyncRead + , asyncWrite + , asyncDoProc + + , asyncReadBA + , asyncWriteBA + + , module GHC.Event.Windows.ConsoleEvent + ) where + + +#include "windows_cconv.h" + +import Data.Bits (shiftR) +import GHC.Base +import GHC.Conc.Sync +import GHC.Conc.POSIX.Const +import GHC.Event.Windows.ConsoleEvent +import GHC.IO (unsafePerformIO) +import GHC.IORef +import GHC.MVar +import GHC.Num (Num(..)) +import GHC.Ptr +import GHC.Real (div, fromIntegral) +import GHC.Word (Word32, Word64) +import GHC.Windows +import Unsafe.Coerce ( unsafeCoerceUnlifted ) + +-- ---------------------------------------------------------------------------- +-- Thread waiting + +-- Note: threadWaitRead and threadWaitWrite aren't really functional +-- on Win32, but left in there because lib code (still) uses them (the manner +-- in which they're used doesn't cause problems on a Win32 platform though.) + +asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncRead# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncWrite# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int +asyncDoProc (FunPtr proc) (Ptr param) = + -- the 'length' value is ignored; simplifies implementation of + -- the async*# primops to have them all return the same result. + IO $ \s -> case asyncDoProc# proc param s of + (# s', _len#, err# #) -> (# s', I# err# #) + +-- to aid the use of these primops by the IO Handle implementation, +-- provide the following convenience funs: + +-- this better be a pinned byte array! +asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncReadBA fd isSock len off bufB = + asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerceUnlifted bufB))) `plusPtr` off) + +asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncWriteBA fd isSock len off bufB = + asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerceUnlifted bufB))) `plusPtr` off) + +-- ---------------------------------------------------------------------------- +-- Threaded RTS implementation of threadDelay + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +-- +threadDelay :: Int -> IO () +threadDelay time + | threaded = waitForDelayEvent time + | otherwise = IO $ \s -> + case time of { I# time# -> + case delay# time# s of { s' -> (# s', () #) + }} + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs + | threaded = waitForDelayEventSTM usecs + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +waitForDelayEvent :: Int -> IO () +waitForDelayEvent usecs = do + m <- newEmptyMVar + target <- calculateTarget usecs + _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs) + prodServiceThread + takeMVar m + +-- Delays for use in STM +waitForDelayEventSTM :: Int -> IO (TVar Bool) +waitForDelayEventSTM usecs = do + t <- atomically $ newTVar False + target <- calculateTarget usecs + _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs) + prodServiceThread + return t + +calculateTarget :: Int -> IO USecs +calculateTarget usecs = do + now <- getMonotonicUSec + return $ now + (fromIntegral usecs) + +data DelayReq + = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ()) + | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) + +{-# NOINLINE pendingDelays #-} +pendingDelays :: IORef [DelayReq] +pendingDelays = unsafePerformIO $ do + m <- newIORef [] + sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore" + getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManagerThread #-} +ioManagerThread :: MVar (Maybe ThreadId) +ioManagerThread = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" + getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | threaded = startIOManagerThread + | otherwise = return () + +interruptIOManager :: IO () +interruptIOManager = return () + +startIOManagerThread :: IO () +startIOManagerThread = do + modifyMVar_ ioManagerThread $ \old -> do + let create = do t <- forkIO ioManager; + labelThread t "IOManagerThread"; + return (Just t) + case old of + Nothing -> create + Just t -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> return (Just t) + +insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] +insertDelay d [] = [d] +insertDelay d1 ds@(d2 : rest) + | delayTime d1 <= delayTime d2 = d1 : ds + | otherwise = d2 : insertDelay d1 rest + +delayTime :: DelayReq -> USecs +delayTime (Delay t _) = t +delayTime (DelaySTM t _) = t + +type USecs = Word64 +type NSecs = Word64 + +foreign import ccall unsafe "getMonotonicNSec" + getMonotonicNSec :: IO NSecs + +getMonotonicUSec :: IO USecs +getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec + +{-# NOINLINE prodding #-} +prodding :: IORef Bool +prodding = unsafePerformIO $ do + r <- newIORef False + sharedCAF r getOrSetGHCConcWindowsProddingStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" + getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a) + +prodServiceThread :: IO () +prodServiceThread = do + -- NB. use atomicSwapIORef here, otherwise there are race + -- conditions in which prodding is left at True but the server is + -- blocked in select(). + was_set <- atomicSwapIORef prodding True + when (not was_set) wakeupIOManager + +-- ---------------------------------------------------------------------------- +-- Windows IO manager thread + +ioManager :: IO () +ioManager = do + wakeup <- c_getIOManagerEvent + service_loop wakeup [] + +service_loop :: HANDLE -- read end of pipe + -> [DelayReq] -- current delay requests + -> IO () + +service_loop wakeup old_delays = do + -- pick up new delay requests + new_delays <- atomicSwapIORef pendingDelays [] + let delays = foldr insertDelay old_delays new_delays + + now <- getMonotonicUSec + (delays', timeout) <- getDelay now delays + + r <- c_WaitForSingleObject wakeup timeout + case r of + 0xffffffff -> do throwGetLastError "service_loop" + 0 -> do + r2 <- c_readIOManagerEvent + exit <- + case r2 of + _ | r2 == io_MANAGER_WAKEUP -> return False + _ | r2 == io_MANAGER_DIE -> return True + 0 -> return False -- spurious wakeup + _ -> do start_console_handler (r2 `shiftR` 1); return False + when (not exit) $ service_cont wakeup delays' + + _other -> service_cont wakeup delays' -- probably timeout + +service_cont :: HANDLE -> [DelayReq] -> IO () +service_cont wakeup delays = do + _ <- atomicSwapIORef prodding False + service_loop wakeup delays + +wakeupIOManager :: IO () +wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP + +-- Walk the queue of pending delays, waking up any that have passed +-- and return the smallest delay to wait for. The queue of pending +-- delays is kept ordered. +getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD) +getDelay _ [] = return ([], iNFINITE) +getDelay now all@(d : rest) + = case d of + Delay time m | now >= time -> do + putMVar m () + getDelay now rest + DelaySTM time t | now >= time -> do + atomically $ writeTVar t True + getDelay now rest + _otherwise -> + -- delay is in millisecs for WaitForSingleObject + let micro_seconds = delayTime d - now + milli_seconds = (micro_seconds + 999) `div` 1000 + in return (all, fromIntegral milli_seconds) + +foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_getIOManagerEvent :: IO HANDLE + +foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_readIOManagerEvent :: IO Word32 + +foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_sendIOManagerEvent :: Word32 -> IO () + +foreign import WINDOWS_CCONV "WaitForSingleObject" + c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD + diff --git a/libraries/base/GHC/Conc/POSIX/Const.hsc b/libraries/base/GHC/Conc/POSIX/Const.hsc new file mode 100644 index 0000000000..b9c59bb439 --- /dev/null +++ b/libraries/base/GHC/Conc/POSIX/Const.hsc @@ -0,0 +1,29 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.POSIX.Const +-- Copyright : (c) The University of Glasgow, 2019 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Constants shared with the rts, GHC.Conc.POSIX uses MagicHash which confuses +-- hsc2hs so these are moved to a new module. +-- +----------------------------------------------------------------------------- + +-- #not-home +module GHC.Conc.POSIX.Const where + +import Data.Word + +#include <Rts.h> + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 +io_MANAGER_WAKEUP = #{const IO_MANAGER_WAKEUP} +io_MANAGER_DIE = #{const IO_MANAGER_DIE} diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index d6ffbc2de9..a15e91f956 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -8,7 +8,6 @@ , StandaloneDeriving , RankNTypes #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -33,6 +32,7 @@ -- #not-home module GHC.Conc.Sync ( ThreadId(..) + , showThreadId -- * Forking and suchlike , forkIO @@ -102,7 +102,7 @@ import Data.Maybe import GHC.Base import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) -import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import {-# SOURCE #-} GHC.IO.StdHandles ( stdout ) import GHC.Int import GHC.IO import GHC.IO.Encoding.UTF8 @@ -151,6 +151,9 @@ instance Show ThreadId where showString "ThreadId " . showsPrec d (getThreadId (id2TSO t)) +showThreadId :: ThreadId -> String +showThreadId = show + foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt id2TSO :: ThreadId -> ThreadId# @@ -538,6 +541,8 @@ data BlockReason -- ^blocked in 'retry' in an STM transaction | BlockedOnForeignCall -- ^currently in a foreign call + | BlockedOnIOCompletion + -- ^currently blocked on an I/O Completion port | BlockedOnOther -- ^blocked on some other resource. Without @-threaded@, -- I\/O and 'Control.Concurrent.threadDelay' show up as @@ -576,6 +581,7 @@ threadStatus (ThreadId t) = IO $ \s -> mk_stat 11 = ThreadBlocked BlockedOnForeignCall mk_stat 12 = ThreadBlocked BlockedOnException mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead + mk_stat 15 = ThreadBlocked BlockedOnIOCompletion -- NB. these are hardcoded in rts/PrimOps.cmm mk_stat 16 = ThreadFinished mk_stat 17 = ThreadDied diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot new file mode 100644 index 0000000000..07b4ef05ab --- /dev/null +++ b/libraries/base/GHC/Conc/Sync.hs-boot @@ -0,0 +1,72 @@ +{-# LANGUAGE MagicHash, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.Sync [boot] +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +module GHC.Conc.Sync + ( forkIO, + TVar(..), + ThreadId(..), + myThreadId, + showThreadId, + ThreadStatus(..), + threadStatus, + sharedCAF + ) where + +import GHC.Base +import GHC.Ptr + +forkIO :: IO () -> IO ThreadId + +data ThreadId = ThreadId ThreadId# +data TVar a = TVar (TVar# RealWorld a) + +data BlockReason + = BlockedOnMVar + -- ^blocked on 'MVar' + {- possibly (see 'threadstatus' below): + | BlockedOnMVarRead + -- ^blocked on reading an empty 'MVar' + -} + | BlockedOnBlackHole + -- ^blocked on a computation in progress by another thread + | BlockedOnException + -- ^blocked in 'throwTo' + | BlockedOnSTM + -- ^blocked in 'retry' in an STM transaction + | BlockedOnForeignCall + -- ^currently in a foreign call + | BlockedOnIOCompletion + -- ^currently blocked on an I/O Completion port + | BlockedOnOther + -- ^blocked on some other resource. Without @-threaded@, + -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ + -- they show up as 'BlockedOnMVar'. + +data ThreadStatus + = ThreadRunning + -- ^the thread is currently runnable or running + | ThreadFinished + -- ^the thread has finished + | ThreadBlocked BlockReason + -- ^the thread is blocked on some resource + | ThreadDied + -- ^the thread received an uncaught exception + +myThreadId :: IO ThreadId +showThreadId :: ThreadId -> String +threadStatus :: ThreadId -> IO ThreadStatus +sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a diff --git a/libraries/base/GHC/Conc/WinIO.hs b/libraries/base/GHC/Conc/WinIO.hs new file mode 100644 index 0000000000..d0325910b1 --- /dev/null +++ b/libraries/base/GHC/Conc/WinIO.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.WinIO +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O Completion Port interface to the one defined in +-- GHC.Event.Windows. +-- +-- This module is an indirection to keep things in the same structure as before +-- but also to keep the new code where the actual I/O manager is. As such it +-- just re-exports GHC.Event.Windows.Thread +-- +----------------------------------------------------------------------------- + +-- #not-home +module GHC.Conc.WinIO + ( module GHC.Event.Windows.Thread ) where + +import GHC.Event.Windows.Thread diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs index 53f22d6d50..34131cc416 100644 --- a/libraries/base/GHC/Conc/Windows.hs +++ b/libraries/base/GHC/Conc/Windows.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -13,13 +12,15 @@ -- Stability : internal -- Portability : non-portable (GHC extensions) -- --- Windows I/O manager +-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used +-- requests will be routed to different places. -- ----------------------------------------------------------------------------- -- #not-home module GHC.Conc.Windows ( ensureIOManagerIsRunning + , interruptIOManager -- * Waiting , threadDelay @@ -33,37 +34,22 @@ module GHC.Conc.Windows , asyncReadBA , asyncWriteBA - , ConsoleEvent(..) - , win32ConsoleHandler - , toWin32ConsoleEvent + -- * Console event handler + , module GHC.Event.Windows.ConsoleEvent ) where -import Data.Bits (shiftR) + +#include "windows_cconv.h" + import GHC.Base import GHC.Conc.Sync -import GHC.Enum (Enum) -import GHC.IO (unsafePerformIO) -import GHC.IORef -import GHC.MVar -import GHC.Num (Num(..)) +import qualified GHC.Conc.POSIX as POSIX +import qualified GHC.Conc.WinIO as WINIO +import GHC.Event.Windows.ConsoleEvent +import GHC.IO.SubSystem ((<!>)) import GHC.Ptr -import GHC.Read (Read) -import GHC.Real (div, fromIntegral) -import GHC.Show (Show) -import GHC.Word (Word32, Word64) -import GHC.Windows import Unsafe.Coerce ( unsafeCoerceUnlifted ) -#if defined(mingw32_HOST_OS) -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif -#endif - -- ---------------------------------------------------------------------------- -- Thread waiting @@ -111,232 +97,19 @@ asyncWriteBA fd isSock len off bufB = -- run /earlier/ than specified. -- threadDelay :: Int -> IO () -threadDelay time - | threaded = waitForDelayEvent time - | otherwise = IO $ \s -> - case time of { I# time# -> - case delay# time# s of { s' -> (# s', () #) - }} +threadDelay = POSIX.threadDelay <!> WINIO.threadDelay -- | Set the value of returned TVar to True after a given number of -- microseconds. The caveats associated with threadDelay also apply. -- registerDelay :: Int -> IO (TVar Bool) -registerDelay usecs - | threaded = waitForDelayEventSTM usecs - | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" - -foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool - -waitForDelayEvent :: Int -> IO () -waitForDelayEvent usecs = do - m <- newEmptyMVar - target <- calculateTarget usecs - _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs) - prodServiceThread - takeMVar m - --- Delays for use in STM -waitForDelayEventSTM :: Int -> IO (TVar Bool) -waitForDelayEventSTM usecs = do - t <- atomically $ newTVar False - target <- calculateTarget usecs - _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs) - prodServiceThread - return t - -calculateTarget :: Int -> IO USecs -calculateTarget usecs = do - now <- getMonotonicUSec - return $ now + (fromIntegral usecs) - -data DelayReq - = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ()) - | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) - -{-# NOINLINE pendingDelays #-} -pendingDelays :: IORef [DelayReq] -pendingDelays = unsafePerformIO $ do - m <- newIORef [] - sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore - -foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore" - getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a) - -{-# NOINLINE ioManagerThread #-} -ioManagerThread :: MVar (Maybe ThreadId) -ioManagerThread = unsafePerformIO $ do - m <- newMVar Nothing - sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore - -foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" - getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a) +registerDelay = POSIX.registerDelay <!> WINIO.registerDelay ensureIOManagerIsRunning :: IO () -ensureIOManagerIsRunning - | threaded = startIOManagerThread - | otherwise = return () - -startIOManagerThread :: IO () -startIOManagerThread = do - modifyMVar_ ioManagerThread $ \old -> do - let create = do t <- forkIO ioManager; return (Just t) - case old of - Nothing -> create - Just t -> do - s <- threadStatus t - case s of - ThreadFinished -> create - ThreadDied -> create - _other -> return (Just t) - -insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] -insertDelay d [] = [d] -insertDelay d1 ds@(d2 : rest) - | delayTime d1 <= delayTime d2 = d1 : ds - | otherwise = d2 : insertDelay d1 rest - -delayTime :: DelayReq -> USecs -delayTime (Delay t _) = t -delayTime (DelaySTM t _) = t - -type USecs = Word64 -type NSecs = Word64 - -foreign import ccall unsafe "getMonotonicNSec" - getMonotonicNSec :: IO NSecs - -getMonotonicUSec :: IO USecs -getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec - -{-# NOINLINE prodding #-} -prodding :: IORef Bool -prodding = unsafePerformIO $ do - r <- newIORef False - sharedCAF r getOrSetGHCConcWindowsProddingStore - -foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" - getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a) - -prodServiceThread :: IO () -prodServiceThread = do - -- NB. use atomicSwapIORef here, otherwise there are race - -- conditions in which prodding is left at True but the server is - -- blocked in select(). - was_set <- atomicSwapIORef prodding True - when (not was_set) wakeupIOManager - --- ---------------------------------------------------------------------------- --- Windows IO manager thread - -ioManager :: IO () -ioManager = do - wakeup <- c_getIOManagerEvent - service_loop wakeup [] - -service_loop :: HANDLE -- read end of pipe - -> [DelayReq] -- current delay requests - -> IO () - -service_loop wakeup old_delays = do - -- pick up new delay requests - new_delays <- atomicSwapIORef pendingDelays [] - let delays = foldr insertDelay old_delays new_delays - - now <- getMonotonicUSec - (delays', timeout) <- getDelay now delays - - r <- c_WaitForSingleObject wakeup timeout - case r of - 0xffffffff -> do throwGetLastError "service_loop" - 0 -> do - r2 <- c_readIOManagerEvent - exit <- - case r2 of - _ | r2 == io_MANAGER_WAKEUP -> return False - _ | r2 == io_MANAGER_DIE -> return True - 0 -> return False -- spurious wakeup - _ -> do start_console_handler (r2 `shiftR` 1); return False - when (not exit) $ service_cont wakeup delays' - - _other -> service_cont wakeup delays' -- probably timeout - -service_cont :: HANDLE -> [DelayReq] -> IO () -service_cont wakeup delays = do - _ <- atomicSwapIORef prodding False - service_loop wakeup delays - --- must agree with rts/win32/ThrIOManager.c -io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 -io_MANAGER_WAKEUP = 0xffffffff -io_MANAGER_DIE = 0xfffffffe - -data ConsoleEvent - = ControlC - | Break - | Close - -- these are sent to Services only. - | Logoff - | Shutdown - deriving ( Eq -- ^ @since 4.3.0.0 - , Ord -- ^ @since 4.3.0.0 - , Enum -- ^ @since 4.3.0.0 - , Show -- ^ @since 4.3.0.0 - , Read -- ^ @since 4.3.0.0 - ) - -start_console_handler :: Word32 -> IO () -start_console_handler r = - case toWin32ConsoleEvent r of - Just x -> withMVar win32ConsoleHandler $ \handler -> do - _ <- forkIO (handler x) - return () - Nothing -> return () - -toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent -toWin32ConsoleEvent ev = - case ev of - 0 {- CTRL_C_EVENT-} -> Just ControlC - 1 {- CTRL_BREAK_EVENT-} -> Just Break - 2 {- CTRL_CLOSE_EVENT-} -> Just Close - 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff - 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown - _ -> Nothing - -win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) -win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler")) - -wakeupIOManager :: IO () -wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP - --- Walk the queue of pending delays, waking up any that have passed --- and return the smallest delay to wait for. The queue of pending --- delays is kept ordered. -getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD) -getDelay _ [] = return ([], iNFINITE) -getDelay now all@(d : rest) - = case d of - Delay time m | now >= time -> do - putMVar m () - getDelay now rest - DelaySTM time t | now >= time -> do - atomically $ writeTVar t True - getDelay now rest - _otherwise -> - -- delay is in millisecs for WaitForSingleObject - let micro_seconds = delayTime d - now - milli_seconds = (micro_seconds + 999) `div` 1000 - in return (all, fromIntegral milli_seconds) - -foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_getIOManagerEvent :: IO HANDLE - -foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_readIOManagerEvent :: IO Word32 +ensureIOManagerIsRunning = POSIX.ensureIOManagerIsRunning + <!> WINIO.ensureIOManagerIsRunning -foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_sendIOManagerEvent :: Word32 -> IO () +interruptIOManager :: IO () +interruptIOManager = POSIX.interruptIOManager <!> WINIO.interruptIOManager -foreign import WINDOWS_CCONV "WaitForSingleObject" - c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hsc index 8579c22739..1fc26f0563 100644 --- a/libraries/base/GHC/ConsoleHandler.hs +++ b/libraries/base/GHC/ConsoleHandler.hsc @@ -27,9 +27,9 @@ import GHC.Base () -- dummy dependency ( Handler(..) , installHandler , ConsoleEvent(..) - , flushConsole ) where +#include <windows.h> {- #include "rts/Signals.h" @@ -44,13 +44,8 @@ Note: this #include is inside a Haskell comment import GHC.Base import Foreign import Foreign.C -import GHC.IO.FD -import GHC.IO.Exception -import GHC.IO.Handle.Types -import GHC.IO.Handle.Internals import GHC.Conc import Control.Concurrent.MVar -import Data.Typeable data Handler = Default @@ -122,11 +117,11 @@ installHandler handler where fromConsoleEvent ev = case ev of - ControlC -> 0 {- CTRL_C_EVENT-} - Break -> 1 {- CTRL_BREAK_EVENT-} - Close -> 2 {- CTRL_CLOSE_EVENT-} - Logoff -> 5 {- CTRL_LOGOFF_EVENT-} - Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-} + ControlC -> #{const CTRL_C_EVENT } + Break -> #{const CTRL_BREAK_EVENT } + Close -> #{const CTRL_CLOSE_EVENT } + Logoff -> #{const CTRL_LOGOFF_EVENT } + Shutdown -> #{const CTRL_SHUTDOWN_EVENT} toHandler hdlr ev = do case toWin32ConsoleEvent ev of @@ -144,19 +139,4 @@ foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone" rts_ConsoleHandlerDone :: CInt -> IO () - -flushConsole :: Handle -> IO () -flushConsole h = - wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} -> - case cast dev of - Nothing -> ioException $ - IOError (Just h) IllegalOperation "flushConsole" - "handle is not a file descriptor" Nothing Nothing - Just fd -> do - throwErrnoIfMinus1Retry_ "flushConsole" $ - flush_console_fd (fdFD fd) - -foreign import ccall unsafe "consUtils.h flush_input_console__" - flush_console_fd :: CInt -> IO CInt - #endif /* mingw32_HOST_OS */ diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs index 903f7c0c23..9558ece576 100644 --- a/libraries/base/GHC/Event/Array.hs +++ b/libraries/base/GHC/Event/Array.hs @@ -19,6 +19,7 @@ module GHC.Event.Array , removeAt , snoc , unsafeLoad + , unsafeCopyFromBuffer , unsafeRead , unsafeWrite , useAsPtr @@ -139,6 +140,16 @@ unsafeLoad (Array ref) load = do writeIORef ref (AC es len' cap) return len' +-- | Reads n elements from the pointer and copies them +-- into the array. +unsafeCopyFromBuffer :: Array a -> Ptr a -> Int -> IO () +unsafeCopyFromBuffer (Array ref) sptr n = + readIORef ref >>= \(AC es _ cap) -> + CHECK_BOUNDS("unsafeCopyFromBuffer", cap, n-1) + withForeignPtr es $ \pdest -> do + _ <- memcpy pdest sptr (fromIntegral n) + writeIORef ref (AC es n cap) + ensureCapacity :: Storable a => Array a -> Int -> IO () ensureCapacity (Array ref) c = do ac@(AC _ _ cap) <- readIORef ref diff --git a/libraries/base/GHC/Event/IntTable.hs b/libraries/base/GHC/Event/IntTable.hs index 56993d18b3..a821cfdf07 100644 --- a/libraries/base/GHC/Event/IntTable.hs +++ b/libraries/base/GHC/Event/IntTable.hs @@ -143,3 +143,4 @@ updateWith f k (IntTable ref) = do size <- peek ptr poke ptr (size - 1) return oldVal + diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 5778c6f3fe..2ed8d2e66c 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -10,150 +10,16 @@ module GHC.Event.Internal , poll , modifyFd , modifyFdOnce - -- * Event type - , Event - , evtRead - , evtWrite - , evtClose - , eventIs - -- * Lifetimes - , Lifetime(..) - , EventLifetime - , eventLifetime - , elLifetime - , elEvent - -- * Timeout type - , Timeout(..) + , module GHC.Event.Internal.Types -- * Helpers , throwErrnoIfMinus1NoRetry ) where -import Data.Bits ((.|.), (.&.)) -import Data.OldList (foldl', filter, intercalate, null) import Foreign.C.Error (eINTR, getErrno, throwErrno) import System.Posix.Types (Fd) import GHC.Base -import GHC.Word (Word64) import GHC.Num (Num(..)) -import GHC.Show (Show(..)) -import Data.Semigroup.Internal (stimesMonoid) - --- | An I\/O event. -newtype Event = Event Int - deriving Eq -- ^ @since 4.4.0.0 - -evtNothing :: Event -evtNothing = Event 0 -{-# INLINE evtNothing #-} - --- | Data is available to be read. -evtRead :: Event -evtRead = Event 1 -{-# INLINE evtRead #-} - --- | The file descriptor is ready to accept a write. -evtWrite :: Event -evtWrite = Event 2 -{-# INLINE evtWrite #-} - --- | Another thread closed the file descriptor. -evtClose :: Event -evtClose = Event 4 -{-# INLINE evtClose #-} - -eventIs :: Event -> Event -> Bool -eventIs (Event a) (Event b) = a .&. b /= 0 - --- | @since 4.4.0.0 -instance Show Event where - show e = '[' : (intercalate "," . filter (not . null) $ - [evtRead `so` "evtRead", - evtWrite `so` "evtWrite", - evtClose `so` "evtClose"]) ++ "]" - where ev `so` disp | e `eventIs` ev = disp - | otherwise = "" - --- | @since 4.10.0.0 -instance Semigroup Event where - (<>) = evtCombine - stimes = stimesMonoid - --- | @since 4.4.0.0 -instance Monoid Event where - mempty = evtNothing - mconcat = evtConcat - -evtCombine :: Event -> Event -> Event -evtCombine (Event a) (Event b) = Event (a .|. b) -{-# INLINE evtCombine #-} - -evtConcat :: [Event] -> Event -evtConcat = foldl' evtCombine evtNothing -{-# INLINE evtConcat #-} - --- | The lifetime of an event registration. --- --- @since 4.8.1.0 -data Lifetime = OneShot -- ^ the registration will be active for only one - -- event - | MultiShot -- ^ the registration will trigger multiple times - deriving ( Show -- ^ @since 4.8.1.0 - , Eq -- ^ @since 4.8.1.0 - ) - --- | The longer of two lifetimes. -elSupremum :: Lifetime -> Lifetime -> Lifetime -elSupremum OneShot OneShot = OneShot -elSupremum _ _ = MultiShot -{-# INLINE elSupremum #-} - --- | @since 4.10.0.0 -instance Semigroup Lifetime where - (<>) = elSupremum - stimes = stimesMonoid - --- | @mappend@ takes the longer of two lifetimes. --- --- @since 4.8.0.0 -instance Monoid Lifetime where - mempty = OneShot - --- | A pair of an event and lifetime --- --- Here we encode the event in the bottom three bits and the lifetime --- in the fourth bit. -newtype EventLifetime = EL Int - deriving ( Show -- ^ @since 4.8.0.0 - , Eq -- ^ @since 4.8.0.0 - ) - --- | @since 4.11.0.0 -instance Semigroup EventLifetime where - EL a <> EL b = EL (a .|. b) - --- | @since 4.8.0.0 -instance Monoid EventLifetime where - mempty = EL 0 - -eventLifetime :: Event -> Lifetime -> EventLifetime -eventLifetime (Event e) l = EL (e .|. lifetimeBit l) - where - lifetimeBit OneShot = 0 - lifetimeBit MultiShot = 8 -{-# INLINE eventLifetime #-} - -elLifetime :: EventLifetime -> Lifetime -elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot -{-# INLINE elLifetime #-} - -elEvent :: EventLifetime -> Event -elEvent (EL x) = Event (x .&. 0x7) -{-# INLINE elEvent #-} - --- | A type alias for timeouts, specified in nanoseconds. -data Timeout = Timeout {-# UNPACK #-} !Word64 - | Forever - deriving Show -- ^ @since 4.4.0.0 +import GHC.Event.Internal.Types -- | Event notification backend. data Backend = forall a. Backend { diff --git a/libraries/base/GHC/Event/Internal/Types.hs b/libraries/base/GHC/Event/Internal/Types.hs new file mode 100644 index 0000000000..e02ff36b61 --- /dev/null +++ b/libraries/base/GHC/Event/Internal/Types.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE NoImplicitPrelude #-} +------------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Types +-- Copyright : (c) Tamar Christina 2018 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Abstraction over C Handle types for GHC, Unix wants FD (CInt) while Windows +-- Wants Handle (CIntPtr), so we abstract over them here. +-- +------------------------------------------------------------------------------- + +module GHC.Event.Internal.Types + ( + -- * Event type + Event + , evtRead + , evtWrite + , evtClose + , evtNothing + , eventIs + -- * Lifetimes + , Lifetime(..) + , EventLifetime + , eventLifetime + , elLifetime + , elEvent + -- * Timeout type + , Timeout(..) + ) where + +import Data.OldList (foldl', filter, intercalate, null) + +import Data.Bits ((.|.), (.&.)) +import Data.Semigroup.Internal (stimesMonoid) + +import GHC.Base +import GHC.Show (Show(..)) +import GHC.Word (Word64) + +-- | An I\/O event. +newtype Event = Event Int + deriving Eq -- ^ @since 4.4.0.0 + +evtNothing :: Event +evtNothing = Event 0 +{-# INLINE evtNothing #-} + +-- | Data is available to be read. +evtRead :: Event +evtRead = Event 1 +{-# INLINE evtRead #-} + +-- | The file descriptor is ready to accept a write. +evtWrite :: Event +evtWrite = Event 2 +{-# INLINE evtWrite #-} + +-- | Another thread closed the file descriptor. +evtClose :: Event +evtClose = Event 4 +{-# INLINE evtClose #-} + +eventIs :: Event -> Event -> Bool +eventIs (Event a) (Event b) = a .&. b /= 0 + +-- | @since 4.4.0.0 +instance Show Event where + show e = '[' : (intercalate "," . filter (not . null) $ + [evtRead `so` "evtRead", + evtWrite `so` "evtWrite", + evtClose `so` "evtClose"]) ++ "]" + where ev `so` disp | e `eventIs` ev = disp + | otherwise = "" + +-- | @since 4.10.0.0 +instance Semigroup Event where + (<>) = evtCombine + stimes = stimesMonoid + +-- | @since 4.4.0.0 +instance Monoid Event where + mempty = evtNothing + mconcat = evtConcat + +evtCombine :: Event -> Event -> Event +evtCombine (Event a) (Event b) = Event (a .|. b) +{-# INLINE evtCombine #-} + +evtConcat :: [Event] -> Event +evtConcat = foldl' evtCombine evtNothing +{-# INLINE evtConcat #-} + +-- | The lifetime of an event registration. +-- +-- @since 4.8.1.0 +data Lifetime = OneShot -- ^ the registration will be active for only one + -- event + | MultiShot -- ^ the registration will trigger multiple times + deriving ( Show -- ^ @since 4.8.1.0 + , Eq -- ^ @since 4.8.1.0 + ) + +-- | The longer of two lifetimes. +elSupremum :: Lifetime -> Lifetime -> Lifetime +elSupremum OneShot OneShot = OneShot +elSupremum _ _ = MultiShot +{-# INLINE elSupremum #-} + +-- | @since 4.10.0.0 +instance Semigroup Lifetime where + (<>) = elSupremum + stimes = stimesMonoid + +-- | @mappend@ takes the longer of two lifetimes. +-- +-- @since 4.8.0.0 +instance Monoid Lifetime where + mempty = OneShot + +-- | A pair of an event and lifetime +-- +-- Here we encode the event in the bottom three bits and the lifetime +-- in the fourth bit. +newtype EventLifetime = EL Int + deriving ( Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + ) + +-- | @since 4.11.0.0 +instance Semigroup EventLifetime where + EL a <> EL b = EL (a .|. b) + +-- | @since 4.8.0.0 +instance Monoid EventLifetime where + mempty = EL 0 + +eventLifetime :: Event -> Lifetime -> EventLifetime +eventLifetime (Event e) l = EL (e .|. lifetimeBit l) + where + lifetimeBit OneShot = 0 + lifetimeBit MultiShot = 8 +{-# INLINE eventLifetime #-} + +elLifetime :: EventLifetime -> Lifetime +elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot +{-# INLINE elLifetime #-} + +elEvent :: EventLifetime -> Event +elEvent (EL x) = Event (x .&. 0x7) +{-# INLINE elEvent #-} + +-- | A type alias for timeouts, specified in nanoseconds. +data Timeout = Timeout {-# UNPACK #-} !Word64 + | Forever + deriving Show -- ^ @since 4.4.0.0 diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index ad922d73f2..19b6cd4117 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -15,7 +15,7 @@ module GHC.Event.Thread , registerDelay , blockedOnBadFD -- used by RTS ) where - +-- TODO: Use new Windows I/O manager import Control.Exception (finally, SomeException, toException) import Data.Foldable (forM_, mapM_, sequence_) import Data.IORef (IORef, newIORef, readIORef, writeIORef) diff --git a/libraries/base/GHC/Event/TimeOut.hs b/libraries/base/GHC/Event/TimeOut.hs new file mode 100644 index 0000000000..7be0a4ebc4 --- /dev/null +++ b/libraries/base/GHC/Event/TimeOut.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +------------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.TimeOut +-- Copyright : (c) Tamar Christina 2018 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Common Timer definitions shared between WinIO and RIO. +-- +------------------------------------------------------------------------------- + +module GHC.Event.TimeOut where + +import GHC.IO +import GHC.Base + +import qualified GHC.Event.PSQ as Q +import GHC.Event.Unique (Unique) + +-- | A priority search queue, with timeouts as priorities. +type TimeoutQueue = Q.PSQ TimeoutCallback + +-- | +-- Warning: since the 'TimeoutCallback' is called from the I/O manager, it must +-- not throw an exception or block for a long period of time. In particular, +-- be wary of 'Control.Exception.throwTo' and 'Control.Concurrent.killThread': +-- if the target thread is making a foreign call, these functions will block +-- until the call completes. +type TimeoutCallback = IO () + +-- | An edit to apply to a 'TimeoutQueue'. +type TimeoutEdit = TimeoutQueue -> TimeoutQueue + +-- | A timeout registration cookie. +newtype TimeoutKey = TK Unique + deriving (Eq, Ord) diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index 946f2333bf..c6518d8cba 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -6,7 +6,7 @@ , TypeSynonymInstances , FlexibleInstances #-} - +-- TODO: use the new Windows IO manager module GHC.Event.TimerManager ( -- * Types TimerManager @@ -51,7 +51,8 @@ import GHC.Real (quot, fromIntegral) import GHC.Show (Show(..)) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) -import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import GHC.Event.Unique (UniqueSource, newSource, newUnique) +import GHC.Event.TimeOut import System.Posix.Types (Fd) import qualified GHC.Event.Internal as I @@ -66,13 +67,6 @@ import qualified GHC.Event.Poll as Poll ------------------------------------------------------------------------ -- Types --- | A timeout registration cookie. -newtype TimeoutKey = TK Unique - deriving Eq -- ^ @since 4.7.0.0 - --- | Callback invoked on timeout events. -type TimeoutCallback = IO () - data State = Created | Running | Dying @@ -81,12 +75,6 @@ data State = Created , Show -- ^ @since 4.7.0.0 ) --- | A priority search queue, with timeouts as priorities. -type TimeoutQueue = Q.PSQ TimeoutCallback - --- | An edit to apply to a 'TimeoutQueue'. -type TimeoutEdit = TimeoutQueue -> TimeoutQueue - -- | The event manager state. data TimerManager = TimerManager { emBackend :: !Backend diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc new file mode 100644 index 0000000000..d074a300b3 --- /dev/null +++ b/libraries/base/GHC/Event/Windows.hsc @@ -0,0 +1,1324 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +------------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.Windows +-- Copyright : (c) Tamar Christina 2018 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- WinIO Windows event manager. +-- +------------------------------------------------------------------------------- + +module GHC.Event.Windows ( + -- * Manager + Manager, + getSystemManager, + interruptSystemManager, + wakeupIOManager, + processRemoteCompletion, + + -- * Overlapped I/O + associateHandle, + associateHandle', + withOverlapped, + withOverlappedEx, + StartCallback, + StartIOCallback, + CbResult(..), + CompletionCallback, + LPOVERLAPPED, + + -- * Timeouts + TimeoutCallback, + TimeoutKey, + Seconds, + registerTimeout, + updateTimeout, + unregisterTimeout, + + -- * Utilities + withException, + ioSuccess, + ioFailed, + ioFailedAny, + getLastError, + + -- * I/O Result type + IOResult(..), + + -- * I/O Event notifications + HandleData (..), -- seal for release + HandleKey (handleValue), + registerHandle, + unregisterHandle, + + -- * Console events + module GHC.Event.Windows.ConsoleEvent +) where + +-- define DEBUG 1 + +-- #define DEBUG_TRACE 1 + +##include "windows_cconv.h" +#include <windows.h> +#include <ntstatus.h> +#include <Rts.h> +#include "winio_structs.h" + +-- There doesn't seem to be GHC.* import for these +import Control.Concurrent.MVar (modifyMVar) +import {-# SOURCE #-} Control.Concurrent (forkOS) +import Data.Semigroup.Internal (stimesMonoid) +import Data.Foldable (mapM_, length, forM_) +import Data.Maybe (isJust, maybe) + +import GHC.Event.Windows.Clock (Clock, Seconds, getClock, getTime) +import GHC.Event.Windows.FFI (LPOVERLAPPED, OVERLAPPED_ENTRY(..)) +import GHC.Event.Windows.ManagedThreadPool +import GHC.Event.Internal.Types +import GHC.Event.Unique +import GHC.Event.TimeOut +import GHC.Event.Windows.ConsoleEvent +import qualified GHC.Event.Windows.FFI as FFI +import qualified GHC.Event.PSQ as Q +import qualified GHC.Event.IntTable as IT +import qualified GHC.Event.Internal as I + +import GHC.MVar +import GHC.Exception as E +import GHC.IORef +import GHC.Maybe +import GHC.Word +import GHC.OldList (deleteBy) +import Foreign +import qualified GHC.Event.Array as A +import GHC.Base +import GHC.Conc.Sync +import GHC.IO +import GHC.IOPort +import GHC.Num +import GHC.Real +import GHC.Enum (maxBound) +import GHC.Windows +import GHC.List (null) +import GHC.Ptr +import Text.Show + +#if defined(DEBUG) +import Foreign.C +import System.Posix.Internals (c_write) +import GHC.Conc.Sync (myThreadId) +#endif + +import qualified GHC.Windows as Win32 + +#if defined(DEBUG_TRACE) +import {-# SOURCE #-} Debug.Trace (traceEventIO) +#endif + +-- Note [WINIO Manager design] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- This file contains the Windows I//O manager. Windows's IO subsystem is by +-- design fully asynchronous, however there are multiple ways and interfaces +-- to the async methods. +-- +-- The chosen Async interface for this implementation is using Completion Ports +-- See also Note [Completion Ports]. The I/O manager uses a new interface added +-- in Windows Vista called `GetQueuedCompletionStatusEx` which allows us to +-- service multiple requests in one go. +-- +-- See https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/overview-of-the-windows-i-o-model +-- and https://www.microsoftpressstore.com/articles/article.aspx?p=2201309&seqNum=3 +-- +-- In order to understand this file, here is what you should know: +-- We're using relatively new APIs that allow us to service multiple requests at +-- the same time using one OS thread. This happens using so called Completion +-- ports. All I/O actions get associated with one and the same completion port. +-- +-- The I/O manager itself has two mode of operation: +-- 1) Threaded: We have N dedicated OS threads in the Haskell world that service +-- completion requests. Everything is Handled 100% in view of the runtime. +-- Whenever the OS has completions that need to be serviced it wakes up one +-- one of the OS threads that are blocked in GetQueuedCompletionStatusEx and +-- lets it proceed with the list of completions that are finished. If more +-- completions finish before the first list is done being processed then +-- another thread is woken up. These threads are associated with the I/O +-- manager through the completion port. If a thread blocks for any reason the +-- OS I/O manager will wake up another thread blocked in GetQueuedCompletionStatusEx +-- from the pool to finish processing the remaining entries. This worker thread +-- must be able to handle the +-- fact that something else has finished the remainder of their queue or must +-- have a guarantee to never block. In this implementation we strive to +-- never block. This is achieved by not having the worker threads call out +-- to any user code, and to have the IOPort synchronization primitive never +-- block. This means if the port is full the message is lost, however we +-- have an invariant that the port can never be full and have a waiting +-- receiver. As such, dropping the message does not change anything as there +-- will never be anyone to receive it. e.g. it is an impossible situation to +-- land in. +-- Note that it is valid (and perhaps expected) that at times two workers +-- will receive the same requests to handle. We deal with this by using +-- atomic operations to prevent race conditions. See processCompletion +-- for details. +-- 2) Non-threaded: We don't have any dedicated Haskell threads servicing +-- I/O Requests. Instead we have an OS thread inside the RTS that gets +-- notified of new requests and does the servicing. When a request completes +-- a Haskell thread is scheduled to run to finish off the processing of any +-- completed requests. See Note [Non-Threaded WINIO design]. +-- +-- These two modes of operations share the majority of the code and so they both +-- support the same operations and fixing one will fix the other. +-- Unlike MIO, we don't threat network I/O any differently than file I/O. Hence +-- any network specific code is now only in the network package. +-- +-- See also Note [Completion Ports] which has some of the details which +-- informed this design. +-- +-- Note [Threaded WINIO design] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The threaded WiNIO is designed around a simple blocking call that's called in +-- a service loop in a dedicated thread: `GetQueuedCompletionStatusEx`. +-- as such the loop is reasonably simple. We're either servicing finished +-- requests or blocking in `getQueuedCompletionStatusEx` waiting for new +-- requests to arrive. +-- +-- Each time a Handle is made three important things happen that affect the I/O +-- manager design: +-- 1) Files are opened with the `FILE_FLAG_OVERLAPPED` flag, which instructs the +-- OS that we will be doing purely asynchronous requests. See +-- `GHC.IO.Windows.Handle.openFile`. They are also opened with +-- `FILE_FLAG_SEQUENTIAL_SCAN` to indicate to the OS that we want to optimize +-- the access of the file for sequential access. (e.g. equivalent to MADVISE) +-- 2) The created handle is associated with the I/O manager's completion port. +-- This allows the I/O manager to be able to service I/O events from this +-- handle. See `associateHandle`. +-- 3) File handles are additionally modified with two optimization flags: +-- +-- FILE_SKIP_COMPLETION_PORT_ON_SUCCESS: If the request can be serviced +-- immediately, then do not queue the IRP (IO Request Packet) into the I/O +-- manager waiting for us to service it later. Instead service it +-- immediately in the same call. This is beneficial for two reasons: +-- 1) We don't have to block in the Haskell RTS. +-- 2) We save a bunch of work in the OS's I/O subsystem. +-- The downside is though that we have to do a bunch of work to handle these +-- cases. This is abstracted away from the user by the `withOverlapped` +-- function. +-- This together with the buffering strategy mentioned above means we +-- actually skip the I/O manager on quite a lot of I/O requests due to the +-- value being in the cache. Because of the Lazy I/O in Haskell, the time +-- to read and decode the buffer of bytes is usually longer than the OS needs +-- to read the next chunk, so we hit the FAST_IO IRP quite often. +-- +-- FILE_SKIP_SET_EVENT_ON_HANDLE: Since we will not be using an event object +-- to monitor asynchronous completions, don't bother updating or checking for +-- one. This saves some precious cycles, especially on operations with very +-- high number of I/O operations (e.g. servers.) +-- +-- So what does servicing a request actually mean. As mentioned before the +-- I/O manager will be blocked or servicing a request. In reality it doesn't +-- always block till an I/O request has completed. In cases where we have event +-- timers, we block till the next timer's timeout. This allows us to also +-- service timers in the same loop. The side effect of this is that we will +-- exit the I/O wait sometimes without any completions. Not really a problem +-- but it's an important design decision. +-- +-- Every time we wait, we give a pre-allocated buffer of `n` +-- `OVERLAPPED_ENTRIES` to the OS. This means that in a single call we can +-- service up to `n` I/O requests at a time. The size of `n` is not fixed, +-- anytime we dequeue `n` I/O requests in a single operation we double the +-- buffer size, allowing the I/O manager to be able to scale up depending +-- on the workload. This buffer is kept alive throughout the lifetime of the +-- program and is never freed until the I/O manager is shutting down. +-- +-- One very important property of the I/O subsystem is that each I/O request +-- now requires an `OVERLAPPED` structure be given to the I/O manager. See +-- `withOverlappedEx`. This buffer is used by the OS to fill in various state +-- information. Throughout the duration of I/O call, this buffer MUST +-- remain live. The address is pinned by the kernel, which means that the +-- pointer must remain accessible until `GetQueuedCompletionStatusEx` returns +-- the completion associated with the handle and not just until the call to what +-- ever I/O operation was used to initialize the I/O request returns. +-- The only exception to this is when the request has hit the FAST_IO path, in +-- which case it has skipped the I/O queue and so can be freed immediately after +-- reading the results from it. +-- +-- To prevent having to lookup the Haskell payload in a shared state after the +-- request completes we attach it as part of the I/O request by extending the +-- `OVERLAPPED` structure. Instead of passing an `OVERLAPPED` structure to the +-- Windows API calls we instead pass a `HASKELL_OVERLAPPED` struct which has +-- as the first element an `OVERLAPPED structure. This means when a request is +-- done all we need to do is cast the pointer back to `HASKELL_OVERLAPPED` and +-- read the accompanying data. This also means we don't have a global lock and +-- so can scale much easier. +-- + +-- --------------------------------------------------------------------------- +-- I/O manager global thread + +-- When running GHCi we still want to ensure we still only have one +-- io manager thread, even if base is loaded twice. See the docs for +-- sharedCAF for how this is done. + +{-# NOINLINE ioManagerThread #-} +ioManagerThread :: MVar (Maybe ThreadId) +ioManagerThread = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" + getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +-- --------------------------------------------------------------------------- +-- Non-threaded I/O manager callback hooks. See `ASyncWinIO.c` + +foreign import ccall safe "registerIOCPHandle" + registerIOCPHandle :: FFI.IOCP -> IO () + +foreign import ccall safe "registerAlertableWait" +-- (bool has_timeout, DWORD mssec, uint64_t num_req, bool pending_service); + c_registerAlertableWait :: Bool -> DWORD -> Word64 -> Bool -> IO () + +foreign import ccall safe "getOverlappedEntries" + getOverlappedEntries :: Ptr DWORD -> IO (Ptr OVERLAPPED_ENTRY) + +foreign import ccall safe "completeSynchronousRequest" + completeSynchronousRequest :: IO () + +------------------------------------------------------------------------ +-- Manager structures + +-- | Callback type that will be called when an I/O operation completes. +type IOCallback = CompletionCallback () + +-- | Wrap the IOCallback type into a FunPtr. +foreign import ccall "wrapper" + wrapIOCallback :: IOCallback -> IO (FunPtr IOCallback) + +-- | Unwrap a FunPtr IOCallback to a normal Haskell function. +foreign import ccall "dynamic" + mkIOCallback :: FunPtr IOCallback -> IOCallback + +-- | Structure that the I/O manager uses to associate callbacks with +-- additional payload such as their OVERLAPPED structure and Win32 handle +-- etc. *Must* be kept in sync with that in `winio_structs.h` or horrible things +-- happen. +-- +-- We keep the handle around for the benefit of ghc-external libraries making +-- use of the manager. +data CompletionData = CompletionData { cdHandle :: !HANDLE + , cdCallback :: !IOCallback + } + +instance Storable CompletionData where + sizeOf _ = #{size CompletionData} + alignment _ = #{alignment CompletionData} + + peek ptr = do + cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr + cdHandle <- #{peek CompletionData, cdHandle} ptr + let !cd = CompletionData{..} + return cd + + poke ptr CompletionData{..} = do + cb <- wrapIOCallback cdCallback + #{poke CompletionData, cdCallback} ptr cb + #{poke CompletionData, cdHandle} ptr cdHandle + +-- | Pointer offset in bytes to the location of hoData in HASKELL_OVERLAPPPED +cdOffset :: Int +cdOffset = #{const __builtin_offsetof (HASKELL_OVERLAPPED, hoData)} + +-- | Terminator symbol for IOCP request +nullReq :: Ptr (Ptr a) +nullReq = castPtr $ unsafePerformIO $ new $ (nullPtr :: Ptr ()) + +-- I don't expect a lot of events, so a simple linked lists should be enough. +type EventElements = [(Event, HandleData)] +data EventData = EventData { evtTopLevel :: !Event, evtElems :: !EventElements } + +instance Monoid EventData where + mempty = EventData evtNothing [] + mappend = (<>) + +instance Semigroup EventData where + (<>) = \a b -> EventData (evtTopLevel a <> evtTopLevel b) + (evtElems a ++ evtElems b) + stimes = stimesMonoid + +data IOResult a + = IOSuccess { ioValue :: a } + | IOFailed { ioErrCode :: Maybe Int } + +-- | The state object for the I/O manager. This structure is available for both +-- the threaded and the non-threaded RTS. +data Manager = Manager + { mgrIOCP :: {-# UNPACK #-} !FFI.IOCP + , mgrClock :: !Clock + , mgrUniqueSource :: {-# UNPACK #-} !UniqueSource + , mgrTimeouts :: {-# UNPACK #-} !(IORef TimeoutQueue) + , mgrEvntHandlers :: {-# UNPACK #-} + !(MVar (IT.IntTable EventData)) + , mgrOverlappedEntries + :: {-#UNPACK #-} !(A.Array OVERLAPPED_ENTRY) + , mgrThreadPool :: Maybe ThreadPool + } + +{-# INLINE startIOManagerThread #-} +-- | Starts a new I/O manager thread. +-- For the threaded runtime it creates a pool of OS threads which stays alive +-- until they are instructed to die. +-- For the non-threaded runtime we have a single worker thread in +-- the C runtime which we force to wake up instead. +-- +-- TODO: Threadpools are not yet implemented. +startIOManagerThread :: IO () -> IO () +startIOManagerThread loop + | not threadedIOMgr + = debugIO "startIOManagerThread:NonThreaded" >> + interruptSystemManager + | otherwise = do + modifyMVar_ ioManagerThread $ \old -> do + let create = do debugIO "spawning worker threads.." + t <- forkOS loop + debugIO $ "created io-manager threads." + labelThread t "IOManagerThread" + return (Just t) + debugIO $ "startIOManagerThread old=" ++ show old + case old of + Nothing -> create + Just t -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> do interruptSystemManager + return (Just t) + +requests :: MVar Word64 +requests = unsafePerformIO $ newMVar 0 + +addRequest :: IO Word64 +addRequest = modifyMVar requests (\x -> return (x + 1, x + 1)) + +removeRequest :: IO Word64 +removeRequest = modifyMVar requests (\x -> return (x - 1, x - 1)) + +outstandingRequests :: IO Word64 +outstandingRequests = withMVar requests return + +getSystemManager :: IO Manager +getSystemManager = readMVar managerRef + +-- | Mutable reference to the IO manager +managerRef :: MVar Manager +managerRef = unsafePerformIO $ createManager >>= newMVar + where + -- | Create the I/O manager. In the Threaded I/O manager this call doesn't + -- have any side effects, but in the Non-Threaded I/O manager the newly + -- created IOCP handle will be registered with the RTS. Users should never + -- call this. + -- It's only used to create the single global manager which is stored + -- in an MVar. + -- + -- NOTE: This needs to finish without making any calls to anything requiring the + -- I/O manager otherwise we'll get into some weird synchronization issues. + -- Essentially this means avoid using long running operations here. + createManager :: IO Manager + createManager = do + debugIO "Starting io-manager..." + mgrIOCP <- FFI.newIOCP + when (not threadedIOMgr) $ + registerIOCPHandle mgrIOCP + debugIO $ "iocp: " ++ show mgrIOCP + mgrClock <- getClock + mgrUniqueSource <- newSource + mgrTimeouts <- newIORef Q.empty + mgrOverlappedEntries <- A.new 64 + mgrEvntHandlers <- newMVar =<< IT.new callbackArraySize + let mgrThreadPool = Nothing + + let !mgr = Manager{..} + return mgr +{-# NOINLINE managerRef #-} + +-- | Interrupts an I/O manager Wait. This will force the I/O manager to process +-- any outstanding events and timers. Also called when console events such as +-- ctrl+c are used to break abort an I/O request. +interruptSystemManager :: IO () +interruptSystemManager = do + mgr <- getSystemManager + debugIO "interrupt received.." + FFI.postQueuedCompletionStatus (mgrIOCP mgr) 0 0 nullPtr + +-- | The initial number of I/O requests we can service at the same time. +-- Must be power of 2. This number is used as the starting point to scale +-- the number of concurrent requests. It will be doubled every time we are +-- saturated. +callbackArraySize :: Int +callbackArraySize = 32 + +----------------------------------------------------------------------- +-- Time utilities + +secondsToNanoSeconds :: Seconds -> Q.Prio +secondsToNanoSeconds s = ceiling $ s * 1000000000 + +secondsToMilliSeconds :: Seconds -> Word32 +secondsToMilliSeconds s = ceiling $ s * 1000 + +nanoSecondsToSeconds :: Q.Prio -> Seconds +nanoSecondsToSeconds n = fromIntegral n / 1000000000.0 + +------------------------------------------------------------------------ +-- Overlapped I/O + +-- | Callback that starts the overlapped I/O operation. +-- It must return successfully if and only if an I/O completion has been +-- queued. Otherwise, it must throw an exception, which 'withOverlapped' +-- will rethrow. +type StartCallback a = LPOVERLAPPED -> IO a + +-- | Specialized callback type for I/O Completion Ports calls using +-- withOverlapped. +type StartIOCallback a = StartCallback (CbResult a) + +-- | CallBack result type to disambiguate between the different states +-- an I/O Completion call could be in. +data CbResult a + = CbDone (Maybe DWORD) -- ^ Request was handled immediately, no queue. + | CbPending -- ^ Queued and to be handled by I/O manager + | CbIncomplete -- ^ I/O request is incomplete but not enqueued, handle + -- it synchronously. + | 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 + -> DWORD -- ^ Number of bytes transferred + -> IO a + +-- | Associate a 'HANDLE' with the current I/O manager's completion port. +-- This must be done before using the handle with 'withOverlapped'. +associateHandle' :: HANDLE -> IO () +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 = + -- 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) + + +{- Note [Why use non-waiting getOverlappedResult requests.] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + When waiting for a request that is bound to be done soon + we spin inside waitForCompletion. There are multiple reasons + for this. + + In the non-threaded RTS we can't perform blocking calls to + C functions without blocking the whole RTS so immediately + a blocking call is not an option there. + + In the threaded RTS we don't use a blocking wait for different + reasons. In particular performing a waiting request using + getOverlappedResult uses the hEvent object embedded in the + OVERLAPPED structure to wait for a signal. + However we do not provide such an object as their creation + would incur to much overhead. Making a waiting request a + less useful operation as it doesn't guarantee that the + operation we were waiting one finished. Only that some + operation on the handle did. + +-} + +-- | Start an overlapped I/O operation, and wait for its completion. If +-- 'withOverlapped' is interrupted by an asynchronous exception, the operation +-- will be canceled using @CancelIoEx@. +-- +-- 'withOverlapped' waits for a completion to arrive before returning or +-- throwing an exception. This means you can use functions like +-- 'Foreign.Marshal.Alloc.alloca' to allocate buffers for the operation. +withOverlappedEx :: forall a. + Manager + -> String -- ^ Handle name + -> HANDLE -- ^ Windows handle associated with the operation. + -> 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 + signal <- newEmptyIOPort :: IO (IOPort (IOResult a)) + let signalReturn a = failIfFalse_ (dbgMsg "signalReturn") $ + writeIOPort signal (IOSuccess a) + signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $ + writeIOPort signal (IOFailed ex) + mask_ $ do + let completionCB' e b = completionCB e b >>= \result -> + case result of + IOSuccess val -> signalReturn val + IOFailed err -> signalThrow err + hs_lpol <- FFI.allocOverlapped offset + -- 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 + -- driver may have finished servicing the request before we were ready + -- and so the request won't have the book keeping information to know + -- what to do. So because of that we always create the payload, If we + -- need it ok, if we don't that's no problem. This approach prevents + -- expensive lookups in hash-tables. + -- + -- Todo: Use a memory pool for this so we don't have to hit malloc every + -- time. This would allow us to scale better. + cdData <- new (CompletionData h completionCB') :: IO (Ptr CompletionData) + let ptr_lpol = hs_lpol `plusPtr` cdOffset + let lpol = castPtr hs_lpol + debugIO $ "hs_lpol:" ++ show hs_lpol + ++ " cdData:" ++ show cdData + ++ " ptr_lpol:" ++ show ptr_lpol + + startCBResult <- startCB lpol `onException` + (CbError `fmap` Win32.getLastError) >>= \result -> do + -- Check to see if the operation was completed on a + -- non-overlapping handle or was completed immediately. + -- e.g. stdio redirection or data in cache, FAST I/O. + success <- FFI.overlappedIOStatus lpol + err <- getLastError + -- Determine if the caller has done any checking. If not then check + -- to see if the request was completed synchronously. We have to + -- in order to prevent deadlocks since if it has completed + -- synchronously we've requested to not have the completion queued. + let result' = + case result of + CbNone ret -- Start by checking some flags which indicates we + -- are done. + | success == #{const STATUS_SUCCESS} -> CbDone Nothing + | success == #{const STATUS_END_OF_FILE} -> CbDone Nothing + -- 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 + | err == #{const ERROR_BROKEN_PIPE} -> CbDone Nothing + | err == #{const ERROR_NO_MORE_ITEMS} -> CbDone Nothing + | err == #{const ERROR_OPERATION_ABORTED} -> CbDone Nothing + -- This is currently mapping all non-complete requests we don't know + -- about as an error. I wonder if this isn't too strict.. + | not ret -> CbError $ fromIntegral err + -- We check success codes after checking error as + -- errors are much more indicative + | success == #{const STATUS_PENDING} -> CbPending + -- If not just assume we can complete. If we can't this will + -- hang because we don't know how to properly deal with it. + -- I don't know what the best default here is... + | otherwise -> CbPending + _ -> result + case result' of + CbNone _ -> error "withOverlappedEx: CbNone shouldn't happen." + CbIncomplete -> do + debugIO $ "handling incomplete request synchronously " ++ show (h, lpol) + res <- waitForCompletion h lpol + debugIO $ "done blocking request 2: " ++ show (h, lpol) ++ " - " ++ show res + return res + CbPending -> do + -- Before we enqueue check see if operation finished in the + -- mean time, since caller may not have done this. + -- 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 + 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} + || status == #{const STATUS_END_OF_FILE} + || errorIsCompleted lasterr + -- 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. + -- Sadly named pipes will always return this error, so in practice + -- we end up always handling them synchronously. There is no good + -- documentation on this. + let will_finish_sync = lasterr == #{const ERROR_IO_INCOMPLETE} + + debugIO $ "== >*< " ++ show (finished, done_early, will_finish_sync, h, lpol, lasterr) + 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 + -- If we should add back support to suspend the IO Manager thread + -- then we will need to make sure it's running at this point. + return result' + -- In progress, we will wait for completion. + (Nothing, False, True) -> do + debugIO $ "handling incomplete request synchronously " ++ show (h, lpol) + res <- waitForCompletion h lpol + debugIO $ "done blocking request 1: " ++ show (h, lpol) ++ " - " ++ show res + return res + _ -> do + debugIO "request handled immediately (o/b), not queued." + return $ CbDone finished + CbError err' -> signalThrow (Just err') >> return result' + CbDone _ -> do + debugIO "request handled immediately (o), not queued." >> return result' + + -- If an exception was received while waiting for IO to complete + -- we try to cancel the request here. + let cancel e = do + debugIO $ "## Exception occurred. Cancelling request... " + debugIO $ show (e :: SomeException) + _ <- uninterruptibleMask_ $ FFI.cancelIoEx' h lpol + -- we need to wait for the cancellation before removing + -- the pointer. + debugIO $ "## Waiting for cancellation record... " + _ <- FFI.getOverlappedResult h lpol True + oldDataPtr <- exchangePtr ptr_lpol nullReq + -- Check if we have to free and cleanup pointer + when (oldDataPtr == cdData) $ + do free oldDataPtr + free hs_lpol + reqs <- removeRequest + debugIO $ "-1.. " ++ show reqs ++ " requests queued after error." + status <- fmap fromIntegral getLastError + completionCB' status 0 + when (not threadedIOMgr) $ + do num_remaining <- outstandingRequests + -- Run timeouts. This way if we canceled the last + -- IO Request and have no timer events waiting we + -- can go into an unbounded alertable wait. + delay <- runExpiredTimeouts mgr + registerAlertableWait delay num_remaining True + return $ IOFailed Nothing + let runner = do debugIO $ (dbgMsg ":: waiting ") ++ " | " ++ show lpol + res <- readIOPort signal `catch` cancel + debugIO $ dbgMsg ":: signaled " + case res of + IOFailed err -> FFI.throwWinErr fname (maybe 0 fromIntegral err) + _ -> return res + + -- Sometimes we shouldn't bother with the I/O manager as the call has + -- failed or is done. + case startCBResult of + CbPending -> runner + CbDone rdata -> do + free cdData + debugIO $ dbgMsg $ ":: done " ++ show lpol ++ " - " ++ show rdata + bytes <- if isJust rdata + then return rdata + -- Make sure it's safe to free the OVERLAPPED buffer + else FFI.getOverlappedResult h lpol False + debugIO $ dbgMsg $ ":: done bytes: " ++ show bytes + case bytes of + Just res -> free hs_lpol >> completionCB 0 res + Nothing -> do err <- FFI.overlappedIOStatus lpol + numBytes <- FFI.overlappedIONumBytes lpol + -- TODO: Remap between STATUS_ and ERROR_ instead + -- of re-interpret here. But for now, don't care. + let err' = fromIntegral err + free hs_lpol + debugIO $ dbgMsg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes + completionCB err' (fromIntegral numBytes) + CbError err -> do + free cdData + free hs_lpol + let err' = fromIntegral err + completionCB err' 0 + _ -> do + free cdData + free hs_lpol + error "unexpected case in `startCBResult'" + where dbgMsg s = s ++ " (" ++ show h ++ ":" ++ show offset ++ ")" + -- Wait for .25ms (threaded) and 1ms (non-threaded) + -- Yields in the threaded case allowing other work. + -- Blocks all haskell execution in the non-threaded case. + -- We might want to reconsider the non-threaded handling + -- at some point. + doShortWait :: IO () + doShortWait + | threadedIOMgr = do + -- Uses an inline definition of threadDelay to prevent an import + -- cycle. + let usecs = 250 -- 0.25ms + m <- newEmptyIOPort + reg <- registerTimeout mgr usecs $ + writeIOPort m () >> return () + readIOPort m `onException` unregisterTimeout mgr reg + | otherwise = sleepBlock 1 -- 1 ms + waitForCompletion :: HANDLE -> Ptr FFI.OVERLAPPED -> IO (CbResult Int) + waitForCompletion fhndl lpol = do + -- Wait for the request to finish as it was running before and + -- The I/O manager won't enqueue it due to our optimizations to + -- prevent context switches in such cases. + -- In the non-threaded case we must use a non-waiting query here + -- otherwise the RTS will lock up until we get a result back. + -- In the threaded case it can be beneficial to spin on the haskell + -- side versus + -- See also Note [Why use non-waiting getOverlappedResult requests.] + res <- FFI.getOverlappedResult fhndl lpol False + status <- FFI.overlappedIOStatus lpol + case res of + Nothing | status == #{const STATUS_END_OF_FILE} + -> do + when (not threadedIOMgr) completeSynchronousRequest + return $ CbDone res + | otherwise -> + do lasterr <- getLastError + let done = errorIsCompleted lasterr + -- 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 + -- of sockets which make take slightly longer. + -- There's a trade-off. Using the timer would allow it do + -- to continue running other Haskell threads, but also + -- means it may take longer to complete the wait. + unless done doShortWait + if done + then do when (not threadedIOMgr) + completeSynchronousRequest + return $ CbDone Nothing + else waitForCompletion fhndl lpol + Just _ -> do + when (not threadedIOMgr) completeSynchronousRequest + return $ CbDone res + unless :: Bool -> IO () -> IO () + unless p a = if p then a else return () + +-- Safe version of function +withOverlapped :: String + -> HANDLE + -> Word64 -- ^ Value to use for the @OVERLAPPED@ + -- structure's Offset/OffsetHigh members. + -> StartIOCallback Int + -> CompletionCallback (IOResult a) + -> IO (IOResult a) +withOverlapped fname h offset startCB completionCB = do + mngr <- getSystemManager + withOverlappedEx mngr fname h offset startCB completionCB + +------------------------------------------------------------------------ +-- Helper to check if an error code implies an operation has completed. + +errorIsCompleted :: ErrCode -> Bool +errorIsCompleted lasterr = + lasterr == #{const ERROR_HANDLE_EOF} + || lasterr == #{const ERROR_SUCCESS} + || lasterr == #{const ERROR_BROKEN_PIPE} + || lasterr == #{const ERROR_NO_MORE_ITEMS} + || lasterr == #{const ERROR_OPERATION_ABORTED} + +------------------------------------------------------------------------ +-- I/O Utilities + +-- | Process an IOResult and throw an exception back to the user if the action +-- has failed, or return the result. +withException :: String -> IO (IOResult a) -> IO a +withException name fn + = do res <- fn + case res of + IOSuccess a -> return a + IOFailed (Just err) -> FFI.throwWinErr name $ fromIntegral err + IOFailed Nothing -> FFI.throwWinErr name 0 + +-- | Signal that the I/O action was successful. +ioSuccess :: a -> IO (IOResult a) +ioSuccess = return . IOSuccess + +-- | Signal that the I/O action has failed with the given reason. +ioFailed :: Integral a => a -> IO (IOResult a) +ioFailed = return . IOFailed . Just . fromIntegral + +-- | Signal that the I/O action has failed with the given reason. +-- Polymorphic in successful result type. +ioFailedAny :: Integral a => a -> IO (IOResult b) +ioFailedAny = return . IOFailed . Just . fromIntegral + +------------------------------------------------------------------------ +-- Timeouts + +-- | Convert uS(Int) to nS(Word64/Q.Prio) capping at maxBound +expirationTime :: Clock -> Int -> IO Q.Prio +expirationTime mgr us = do + now <- getTime mgr :: IO Seconds -- Double + let now_ns = ceiling $ now * 1000 * 1000 * 1000 :: Word64 + let expTime + -- Currently we treat overflows by clamping to maxBound. If humanity + -- still exists in 2500 CE we will ned to be a bit more careful here. + -- See #15158. + | (maxBound - now_ns) `quot` 1000 < fromIntegral us = maxBound :: Q.Prio + | otherwise = now_ns + ns + where ns = 1000 * fromIntegral us + return expTime + +-- | Register an action to be performed in the given number of seconds. The +-- returned 'TimeoutKey' can be used to later un-register or update the timeout. +-- The timeout is automatically unregistered when it fires. +-- +-- The 'TimeoutCallback' will not be called more than once. +{-# NOINLINE registerTimeout #-} +registerTimeout :: Manager -> Int -> TimeoutCallback -> IO TimeoutKey +registerTimeout mgr@Manager{..} uSrelTime cb = do + key <- newUnique mgrUniqueSource + if uSrelTime <= 0 then cb + else do + !expTime <- expirationTime mgrClock uSrelTime :: IO Q.Prio + editTimeouts mgr (Q.unsafeInsertNew key expTime cb) + return $ TK key + +-- | Update an active timeout to fire in the given number of seconds (from the +-- time 'updateTimeout' is called), instead of when it was going to fire. +-- This has no effect if the timeout has already fired. +updateTimeout :: Manager -> TimeoutKey -> Seconds -> IO () +updateTimeout mgr (TK key) relTime = do + now <- getTime (mgrClock mgr) + let !expTime = secondsToNanoSeconds $ now + relTime + -- Note: editTimeouts unconditionally wakes the IO Manager + -- but that is not required if the new time is after + -- the current time. + editTimeouts mgr (Q.adjust (const expTime) key) + +-- | Unregister an active timeout. This is a harmless no-op if the timeout is +-- already unregistered or has already fired. +-- +-- Warning: the timeout callback may fire even after +-- 'unregisterTimeout' completes. +unregisterTimeout :: Manager -> TimeoutKey -> IO () +unregisterTimeout mgr (TK key) = do + editTimeouts mgr (Q.delete key) + +-- | Modify an existing timeout. This isn't thread safe and so if the time to +-- elapse the timer was close it may fire anyway. +editTimeouts :: Manager -> TimeoutEdit -> IO () +editTimeouts mgr g = do + atomicModifyIORef' (mgrTimeouts mgr) $ \tq -> (g tq, ()) + interruptSystemManager + +------------------------------------------------------------------------ +-- I/O manager loop + +-- | Call all expired timeouts, and return how much time until the next +-- | expiration. +runExpiredTimeouts :: Manager -> IO (Maybe Seconds) +runExpiredTimeouts Manager{..} = do + now <- getTime mgrClock + (expired, delay) <- atomicModifyIORef' mgrTimeouts (mkTimeout now) + -- Execute timeout callbacks. + mapM_ Q.value expired + when (not threadedIOMgr && not (null expired)) + completeSynchronousRequest + debugIO $ "expired calls: " ++ show (length expired) + return delay + where + mkTimeout :: Seconds -> TimeoutQueue -> + (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Seconds)) + mkTimeout now tq = + let (tq', (expired, sec)) = mkTimeout' (secondsToNanoSeconds now) tq + in (tq', (expired, fmap nanoSecondsToSeconds sec)) + mkTimeout' :: Q.Prio -> TimeoutQueue -> + (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Q.Prio)) + mkTimeout' now tq = + -- Remove timeouts with expiration <= now. + let (expired, tq') = Q.atMost now tq in + -- See how soon the next timeout expires. + case Q.prio `fmap` Q.findMin tq' of + Nothing -> + (tq', (expired, Nothing)) + Just t -> + -- This value will always be positive since the call + -- to 'atMost' above removed any timeouts <= 'now' + let !t' = t - now + in (tq', (expired, Just t')) + +-- | Return the delay argument to pass to GetQueuedCompletionStatus. +-- Return value is in ms +fromTimeout :: Maybe Seconds -> Word32 +fromTimeout Nothing = 120000 +fromTimeout (Just sec) | sec > 120 = 120000 + | sec > 0 = ceiling (sec * 1000) + | otherwise = 0 + +-- | Perform one full evaluation step of the I/O manager's service loop. +-- This means process timeouts and completed completions and calculate the time +-- for the next timeout. +-- +-- The I/O manager is then notified of how long it should block again based on +-- the queued I/O requests and timers. If the I/O manager was given a command +-- to block, shutdown or suspend than that request is honored at the end of the +-- loop. +-- +-- This function can be safely executed multiple times in parallel and is only +-- used by the threaded manager. +step :: Bool -> Manager -> IO (Bool, Maybe Seconds) +step maxDelay mgr@Manager{..} = do + -- Determine how long to wait the next time we block in an alertable state. + delay <- runExpiredTimeouts mgr + let !timer = if maxDelay && delay == Nothing + then #{const INFINITE} + else fromTimeout delay + debugIO $ "next timer: " ++ show timer -- todo: print as hex + if isJust delay + then debugIO $ "I/O manager waiting: delay=" ++ show delay + else debugIO $ "I/O manager pausing: maxDelay=" ++ show maxDelay + + -- Inform the threadpool that a thread is now + -- entering a kernel mode wait and thus is ready for new work. + notifyWaiting mgrThreadPool + + -- To quote Matt Godbolts: + -- There are some unusual edge cases you need to deal with. The + -- GetQueuedCompletionStatus function blocks a thread until there's + -- work for it to do. Based on the return value, the number of bytes + -- and the overlapped structure, there’s a lot of possible "reasons" + -- for the function to have returned. Deciphering all the possible + -- cases: + -- + -- ------------------------------------------------------------------------ + -- Ret value | OVERLAPPED | # of bytes | Description + -- ------------------------------------------------------------------------ + -- zero | NULL | n/a | Call to GetQueuedCompletionStatus + -- failed, and no data was dequeued from the IO port. This usually + -- indicates an error in the parameters to GetQueuedCompletionStatus. + -- + -- zero | non-NULL | n/a | Call to GetQueuedCompletionStatus + -- failed, but data was read or written. The thread must deal with the + -- data (possibly freeing any associated buffers), but there is an error + -- condition on the underlying HANDLE. Usually seen when the other end of + -- a network connection has been forcibly closed but there's still data in + -- the send or receive queue. + -- + -- non-zero | NULL | n/a | This condition doesn't happen due + -- to IO requests, but is useful to use in combination with + -- PostQueuedCompletionStatus as a way of indicating to threads that they + -- should terminate. + -- + -- non-zero | non-NULL | zero | End of file for a file HANDLE, or + -- the connection has been gracefully closed (for network connections). + -- The OVERLAPPED buffer has still been used; and must be deallocated if + -- necessary. + -- + -- non-zero | non-NULL | non-zero | "num bytes" of data have been + -- transferred into the block pointed by the OVERLAPPED structure. The + -- direction of the transfer is dependant on the call made to the IO + -- port, it's up to the user to remember if it was a read or a write + -- (usually by stashing extra data in the OVERLAPPED structure). The + -- thread must deallocate the structure as necessary. + -- + -- The getQueuedCompletionStatusEx call will remove entries queued by the OS + -- and returns the finished ones in mgrOverlappedEntries and the number of + -- entries removed. + n <- FFI.getQueuedCompletionStatusEx mgrIOCP mgrOverlappedEntries timer + debugIO "WinIORunning" + -- If threaded this call informs the threadpool manager that a thread is + -- busy. If all threads are busy and we have not reached the maximum amount + -- of allowed threads then the threadpool manager will spawn a new thread to + -- allow us to scale under load. + notifyRunning mgrThreadPool + processCompletion mgr n delay + +-- | Process the results at the end of an evaluation loop. This function will +-- read all the completions, unblock up all the Haskell threads, clean up the book +-- keeping of the I/O manager. +-- It returns whether there is outstanding work (request or timer) to be +-- done and how long it expects to have to wait till it can take action again. +-- +-- Note that this method can do less work than there are entries in the +-- completion table. This is because some completion entries may have been +-- created due to calls to interruptIOManager which will enqueue a faux +-- completion. +-- +-- NOTE: In Threaded mode things get a bit complicated the operation may have +-- been completed even before we even got around to put the request in the +-- waiting callback table. These events are handled by having a separate queue +-- for orphaned callback instances that the calling thread is supposed to check +-- before adding something to the work queue. +-- +-- Thread safety: This function atomically replaces outstanding events with +-- a pointer to nullReq. This means it's safe (but potentially wastefull) to +-- have two concurrent or parallel invocations on the same array. +processCompletion :: Manager -> Int -> Maybe Seconds -> IO (Bool, Maybe Seconds) +processCompletion Manager{..} n delay = do + -- If some completions are done, we need to process them and call their + -- callbacks. We then remove the callbacks from the bookkeeping and resize + -- the array if required. + when (n > 0) $ do + forM_ [0..(n-1)] $ \idx -> do + oe <- A.unsafeRead mgrOverlappedEntries idx :: IO OVERLAPPED_ENTRY + let lpol = lpOverlapped oe + when (lpol /= nullPtr) $ do + let hs_lpol = castPtr lpol :: Ptr FFI.HASKELL_OVERLAPPED + let ptr_lpol = castPtr (hs_lpol `plusPtr` cdOffset) :: Ptr (Ptr CompletionData) + cdDataCheck <- peek ptr_lpol + debugIO $ " $ checking " ++ show lpol + ++ " -en ptr_lpol: " ++ show ptr_lpol + ++ " offset: " ++ show cdOffset + ++ " cdData: " ++ show cdDataCheck + ++ " at idx " ++ show idx + oldDataPtr <- exchangePtr ptr_lpol nullReq :: IO (Ptr CompletionData) + debugIO $ ":: oldDataPtr " ++ show oldDataPtr + when (oldDataPtr /= nullPtr) $ + do debugIO $ "exchanged: " ++ show oldDataPtr + payload <- peek oldDataPtr :: IO CompletionData + let !cb = cdCallback payload + free oldDataPtr + reqs <- removeRequest + debugIO $ "-1.. " ++ show reqs ++ " requests queued." + status <- FFI.overlappedIOStatus (lpOverlapped oe) + -- TODO: Remap between STATUS_ and ERROR_ instead + -- of re-interpret here. But for now, don't care. + let status' = fromIntegral status + cb status' (dwNumberOfBytesTransferred oe) + 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 + -- removed but the file data not been filled in. + -- TODO: Maybe not needed.. + A.clear mgrOverlappedEntries + + -- Check to see if we received the maximum amount of entries we could + -- this likely indicates a high number of I/O requests have been queued. + -- In which case we should process more at a time. + cap <- A.capacity mgrOverlappedEntries + when (cap == n) $ A.ensureCapacity mgrOverlappedEntries (2*cap) + + -- Keep running if we still have some work queued or + -- if we have a pending delay. + reqs <- outstandingRequests + debugIO $ "outstanding requests: " ++ show reqs + let more = reqs > 0 + debugIO $ "has more: " ++ show more ++ " - removed: " ++ show n + return (more || (isJust delay && threadedIOMgr), delay) + +-- | Entry point for the non-threaded I/O manager to be able to process +-- completed completions. It is mostly a wrapper around processCompletion +-- and invoked by the C thread via the scheduler. +processRemoteCompletion :: IO () +processRemoteCompletion = do +#if defined(DEBUG) || defined(DEBUG_TRACE) + tid <- myThreadId + labelThread tid $ "IOManagerThread-PRC" ++ show tid +#endif + alloca $ \ptr_n -> do + debugIO "processRemoteCompletion :: start ()" + -- First figure out how much work we have to do. + entries <- getOverlappedEntries ptr_n + n <- fromIntegral `fmap` peek ptr_n + -- This call will unmarshal data from the C buffer but pointers inside of + -- this have not been read yet. + _ <- peekArray n entries + mngr <- getSystemManager + let arr = mgrOverlappedEntries mngr + A.unsafeCopyFromBuffer arr entries n + + -- Process timeouts + delay <- runExpiredTimeouts mngr :: IO (Maybe Seconds) + + -- Process available completions + _ <- processCompletion mngr n delay + + num_left <- outstandingRequests + + -- Update and potentially wake up IO Manager + -- This call will unblock the non-threaded I/O manager. After this it is no + -- longer safe to use `entries` nor `completed` as they can now be modified + -- by the C thread. + registerAlertableWait delay num_left False + + debugIO "processRemoteCompletion :: done ()" + return () + +registerAlertableWait :: Maybe Seconds -> Word64 -> Bool -> IO () +registerAlertableWait Nothing num_reqs pending_service = + c_registerAlertableWait False 0 num_reqs pending_service +registerAlertableWait (Just delay) num_reqs pending_service = + c_registerAlertableWait True (secondsToMilliSeconds delay) + num_reqs pending_service + +-- | Event loop for the Threaded I/O manager. The one for the non-threaded +-- I/O manager is in AsyncWinIO.c in the rts. +io_mngr_loop :: HANDLE -> Manager -> IO () +io_mngr_loop _event _mgr + | not threadedIOMgr + = do debugIO "io_mngr_loop:no-op:called in non-threaded case" + return () +io_mngr_loop _event mgr = go False + where + go maxDelay = + do debugIO "io_mngr_loop:WinIORunning" + -- Step will process IO events, or block if none are outstanding. + (more, delay) <- step maxDelay mgr + let !use_max_delay = not (isJust delay || more) + debugIO "I/O manager stepping." + event_id <- c_readIOManagerEvent + exit <- + case event_id of + _ | event_id == io_MANAGER_WAKEUP -> return False + _ | event_id == io_MANAGER_DIE -> return True + 0 -> return False -- spurious wakeup + _ -> do debugIO $ "handling console event: " ++ show (event_id `shiftR` 1) + start_console_handler (event_id `shiftR` 1) + return False + + -- If we have no more work to do, or something from the outside + -- told us to stop then we let the thread die and stop the I/O + -- manager. It will be woken up again when there is more to do. + case () of + _ | exit -> debugIO "I/O manager shutting down." + _ -> go use_max_delay + + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 +io_MANAGER_WAKEUP = #{const IO_MANAGER_WAKEUP} +io_MANAGER_DIE = #{const IO_MANAGER_DIE} + +-- | Wake up a single thread from the I/O Manager's worker queue. This will +-- unblock a thread blocked in `processCompletion` and allows the I/O manager to +-- react accordingly to changes in timers or to process console signals. +-- No-op if the io-manager is already running. +wakeupIOManager :: IO () +wakeupIOManager + = do mngr <- getSystemManager + -- We don't care about the event handle here, only that it exists. + _event <- c_getIOManagerEvent + debugIO "waking up I/O manager." + startIOManagerThread (io_mngr_loop (error "IOManagerEvent used") mngr) + +-- | Returns the signaling event for the IO Manager. +foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_getIOManagerEvent :: IO HANDLE + +-- | Reads one IO Manager event. For WINIO we distinguish: +-- * Shutdown events, sent from the RTS +-- * Console events, sent from the default console handler. +-- * Wakeup events, which are not used by WINIO and will be ignored +foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_readIOManagerEvent :: IO Word32 + +foreign import ccall unsafe "rtsSupportsBoundThreads" threadedIOMgr :: Bool + +-- | Sleep for n ms +foreign import WINDOWS_CCONV unsafe "Sleep" sleepBlock :: Int -> IO () + +-- --------------------------------------------------------------------------- +-- I/O manager event notifications + + +data HandleData = HandleData { + tokenKey :: {-# UNPACK #-} !HandleKey + , tokenEvents :: {-# UNPACK #-} !EventLifetime + , _handleCallback :: !EventCallback + } + +-- | A file handle registration cookie. +data HandleKey = HandleKey { + handleValue :: {-# UNPACK #-} !HANDLE + , handleUnique :: {-# UNPACK #-} !Unique + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) + +-- | Callback invoked on I/O events. +type EventCallback = HandleKey -> Event -> IO () + +registerHandle :: Manager -> EventCallback -> HANDLE -> Event -> Lifetime + -> IO HandleKey +registerHandle (Manager{..}) cb hwnd evs lt = do + u <- newUnique mgrUniqueSource + let reg = HandleKey hwnd u + hwnd' = fromIntegral $ ptrToIntPtr hwnd + el = I.eventLifetime evs lt + !hwdd = HandleData reg el cb + event = EventData evs [(evs, hwdd)] + _ <- withMVar mgrEvntHandlers $ \evts -> do + IT.insertWith mappend hwnd' event evts + wakeupIOManager + return reg + +unregisterHandle :: Manager -> HandleKey -> IO () +unregisterHandle (Manager{..}) key@HandleKey{..} = do + withMVar mgrEvntHandlers $ \evts -> do + let hwnd' = fromIntegral $ ptrToIntPtr handleValue + val <- IT.lookup hwnd' evts + case val of + Nothing -> return () + Just (EventData evs lst) -> do + let cmp (_, a) (_, b) = tokenKey a == tokenKey b + key' = (undefined, HandleData key undefined undefined) + updated = deleteBy cmp key' lst + new_lst = EventData evs updated + _ <- IT.updateWith (\_ -> return new_lst) hwnd' evts + return () + +-- --------------------------------------------------------------------------- +-- debugging + +#if defined(DEBUG) +c_DEBUG_DUMP :: IO Bool +c_DEBUG_DUMP = return True -- scheduler `fmap` getDebugFlags +#endif + +debugIO :: String -> IO () +#if defined(DEBUG_TRACE) +debugIO s = traceEventIO ( "winIO :: " ++ s) +#elif defined(DEBUG) +debugIO s + = do debug <- c_DEBUG_DUMP + if debug + then do tid <- myThreadId + let pref = if threadedIOMgr then "\t" else "" + _ <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++ + showThreadId tid ++ ")\n") $ + \(p, len) -> c_write 2 (castPtr p) (fromIntegral len) + return () + else do return () +#else +debugIO _ = return () +#endif + +-- dbxIO :: String -> IO () +-- dbxIO s = do tid <- myThreadId +-- let pref = if threadedIOMgr then "\t" else "" +-- _ <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++ +-- showThreadId tid ++ ")\n") $ +-- \(p, len) -> c_write 2 (castPtr p) (fromIntegral len) +-- return ()
\ No newline at end of file diff --git a/libraries/base/GHC/Event/Windows/Clock.hs b/libraries/base/GHC/Event/Windows/Clock.hs new file mode 100644 index 0000000000..34728248c0 --- /dev/null +++ b/libraries/base/GHC/Event/Windows/Clock.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +module GHC.Event.Windows.Clock ( + Clock, + Seconds, + getTime, + getClock, + + -- * Specific implementations + queryPerformanceCounter, + getTickCount64 +) where + +import qualified GHC.Event.Windows.FFI as FFI + +import Data.Maybe +import GHC.Base +import GHC.Real + +-- | Monotonic clock +newtype Clock = Clock (IO Seconds) + +type Seconds = Double + +-- | Get the current time, in seconds since some fixed time in the past. +getTime :: Clock -> IO Seconds +getTime (Clock io) = io + +-- | Figure out what time API to use, and return a 'Clock' for accessing it. +getClock :: IO Clock +getClock = tryInOrder + [ queryPerformanceCounter + , fmap Just getTickCount64 + ] + +tryInOrder :: Monad m => [m (Maybe a)] -> m a +tryInOrder (x:xs) = x >>= maybe (tryInOrder xs) return +tryInOrder [] = undefined + +mapJust :: Monad m => m (Maybe a) -> (a -> b) -> m (Maybe b) +mapJust m f = liftM (fmap f) m + +queryPerformanceCounter :: IO (Maybe Clock) +queryPerformanceCounter = + FFI.queryPerformanceFrequency `mapJust` \freq -> + Clock $! do + count <- FFI.queryPerformanceCounter + let !secs = fromIntegral count / fromIntegral freq + return secs + +getTickCount64 :: IO Clock +getTickCount64 = + return $! Clock $! do + msecs <- FFI.getTickCount64 + return $! fromIntegral msecs / 1000 diff --git a/libraries/base/GHC/Event/Windows/ConsoleEvent.hsc b/libraries/base/GHC/Event/Windows/ConsoleEvent.hsc new file mode 100644 index 0000000000..fd6f790d3b --- /dev/null +++ b/libraries/base/GHC/Event/Windows/ConsoleEvent.hsc @@ -0,0 +1,72 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.Windows.ConsoleEvent +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used +-- requests will be routed to different places. +-- +----------------------------------------------------------------------------- + +module GHC.Event.Windows.ConsoleEvent ( + ConsoleEvent (..), + start_console_handler, + toWin32ConsoleEvent, + win32ConsoleHandler +) where + +import GHC.Base +import GHC.Conc.Sync +import GHC.Enum (Enum) +import GHC.IO (unsafePerformIO) +import GHC.MVar +import GHC.Num (Num(..)) +import GHC.Read (Read) +import GHC.Word (Word32) +import GHC.Show (Show) + +#include <windows.h> + +data ConsoleEvent + = ControlC + | Break + | Close + -- these are sent to Services only. + | Logoff + | Shutdown + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Enum -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + ) + +start_console_handler :: Word32 -> IO () +start_console_handler r = + case toWin32ConsoleEvent r of + Just x -> withMVar win32ConsoleHandler $ \handler -> do + _ <- forkIO (handler x) + return () + Nothing -> return () + +toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent +toWin32ConsoleEvent ev = + case ev of + #{const CTRL_C_EVENT } -> Just ControlC + #{const CTRL_BREAK_EVENT } -> Just Break + #{const CTRL_CLOSE_EVENT } -> Just Close + #{const CTRL_LOGOFF_EVENT } -> Just Logoff + #{const CTRL_SHUTDOWN_EVENT } -> Just Shutdown + _ -> Nothing + +win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) +win32ConsoleHandler = + unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler")) diff --git a/libraries/base/GHC/Event/Windows/FFI.hsc b/libraries/base/GHC/Event/Windows/FFI.hsc new file mode 100644 index 0000000000..b9c766c977 --- /dev/null +++ b/libraries/base/GHC/Event/Windows/FFI.hsc @@ -0,0 +1,395 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +------------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.Windows.FFI +-- Copyright : (c) Tamar Christina 2019 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- WinIO Windows API Foreign Function imports +-- +------------------------------------------------------------------------------- + +module GHC.Event.Windows.FFI ( + -- * IOCP + IOCP(..), + CompletionKey, + newIOCP, + associateHandleWithIOCP, + getQueuedCompletionStatusEx, + postQueuedCompletionStatus, + getOverlappedResult, + + -- * Overlapped + OVERLAPPED, + LPOVERLAPPED, + OVERLAPPED_ENTRY(..), + LPOVERLAPPED_ENTRY, + HASKELL_OVERLAPPED, + LPHASKELL_OVERLAPPED, + allocOverlapped, + zeroOverlapped, + pokeOffsetOverlapped, + overlappedIOStatus, + overlappedIONumBytes, + + -- * Cancel pending I/O + cancelIoEx, + cancelIoEx', + + -- * Monotonic time + + -- ** GetTickCount + getTickCount64, + + -- ** QueryPerformanceCounter + queryPerformanceCounter, + queryPerformanceFrequency, + + -- ** Miscellaneous + throwWinErr, + setLastError +) where + +#include <ntstatus.h> +#include <windows.h> +#include "winio_structs.h" + +##include "windows_cconv.h" + +import Data.Maybe +import Foreign +import GHC.Base +import GHC.Num ((*)) +import GHC.Real (fromIntegral) +import GHC.Show +import GHC.Windows +import qualified GHC.Event.Array as A +import qualified GHC.Windows as Win32 +import GHC.IO.Handle.Internals (debugIO) + +------------------------------------------------------------------------ +-- IOCP + +-- | An I/O completion port. +newtype IOCP = IOCP HANDLE + deriving (Eq, Ord, Show) + +type CompletionKey = ULONG_PTR + +-- | This function has two distinct purposes depending on the value of +-- The completion port handle: +-- +-- - When the IOCP port is NULL then the function creates a new I/O completion +-- port. See `newIOCP`. +-- +-- - When The port contains a valid handle then the given handle is +-- associated with he given completion port handle. Once associated it +-- cannot be easily changed. Associating a Handle with a Completion Port +-- allows the I/O manager's worker threads to handle requests to the given +-- handle. +foreign import WINDOWS_CCONV unsafe "windows.h CreateIoCompletionPort" + c_CreateIoCompletionPort :: HANDLE -> IOCP -> ULONG_PTR -> DWORD + -> IO IOCP + +-- | Create a new I/O completion port. +newIOCP :: IO IOCP +newIOCP = failIf (== IOCP nullPtr) "newIOCP" $ + c_CreateIoCompletionPort iNVALID_HANDLE_VALUE (IOCP nullPtr) 0 0 + +-- | Associate a HANDLE with an I/O completion port. +associateHandleWithIOCP :: IOCP -> HANDLE -> CompletionKey -> IO () +associateHandleWithIOCP iocp handle completionKey = + failIf_ (/= iocp) "associateHandleWithIOCP" $ + c_CreateIoCompletionPort handle iocp completionKey 0 + +foreign import WINDOWS_CCONV safe "windows.h GetOverlappedResult" + c_GetOverlappedResult :: HANDLE -> LPOVERLAPPED -> Ptr DWORD -> BOOL + -> IO BOOL + +-- | Get the result of a single overlap operation without the IO manager +getOverlappedResult :: HANDLE -> Ptr OVERLAPPED -> BOOL -> IO (Maybe DWORD) +getOverlappedResult handle lp block + = alloca $ \bytes -> + do res <- c_GetOverlappedResult handle lp bytes block + if res + then fmap Just $ peek bytes + else return Nothing + +foreign import WINDOWS_CCONV safe "windows.h GetQueuedCompletionStatusEx" + c_GetQueuedCompletionStatusEx :: IOCP -> LPOVERLAPPED_ENTRY -> Word32 + -> Ptr ULONG -> DWORD -> BOOL -> IO BOOL + +-- | Note [Completion Ports] +-- When an I/O operation has been queued by an operation +-- (ReadFile/WriteFile/etc) it is placed in a queue that the driver uses when +-- servicing IRQs. This queue has some important properties: +-- +-- 1.) It is not an ordered queue. Requests may be performed out of order as +-- as the OS's native I/O manager may try to re-order requests such that as +-- few random seeks as possible are needed to complete the pending +-- operations. As such do not assume a fixed order between something being +-- queued and dequeued. +-- +-- 2.) Operations may skip the queue entirely. In which case they do not end in +-- in this function. (This is an optimization flag we have turned on. See +-- `openFile`.) +-- +-- 3.) Across this call the specified OVERLAPPED_ENTRY buffer MUST remain live, +-- and the buffer for an I/O operation cannot be freed or moved until +-- `getOverlappedResult` says it's done. The reason is the kernel may not +-- have fully released the buffer, or finished writing to it when this +-- operation returns. Failure to adhere to this will cause your IRQs to be +-- silently dropped and your program will never receive a completion for it. +-- This means that the OVERLAPPED buffer must also remain valid for the +-- duration of the call and as such must be allocated on the unmanaged heap. +-- +-- 4.) When a thread calls this method it is associated with the I/O manager's +-- worker threads pool. You should always use dedicated threads for this +-- since the OS I/O manager will now monitor the threads. If the thread +-- becomes blocked for whatever reason, the Haskell I/O manager will wake up +-- another threads from it's pool to service the remaining results. +-- A new thread will also be woken up from the pool when the previous thread +-- is busy servicing requests and new requests have finished. For this +-- reason the Haskell I/O manager multiplexes I/O operations from N haskell +-- threads into 1 completion port, which is serviced by M native threads in +-- an asynchronous method. This allows it to scale efficiently. +getQueuedCompletionStatusEx :: IOCP + -> A.Array OVERLAPPED_ENTRY + -> DWORD -- ^ Timeout in milliseconds (or + -- 'GHC.Windows.iNFINITE') + -> IO Int +getQueuedCompletionStatusEx iocp arr timeout = + alloca $ \num_removed_ptr ->do + A.unsafeLoad arr $ \oes cap -> do + -- TODO: remove after debugging + fillBytes oes 0 (cap * (sizeOf (undefined :: OVERLAPPED_ENTRY))) + debugIO $ "-- call getQueuedCompletionStatusEx " + -- don't block the call if the rts is not supporting threads. + -- this would block the entire program. + let alertable = False -- not rtsSupportsBoundThreads + ok <- c_GetQueuedCompletionStatusEx iocp oes (fromIntegral cap) + num_removed_ptr timeout alertable + debugIO $ "-- call getQueuedCompletionStatusEx: " ++ show ok + err <- getLastError + nc <- (peek num_removed_ptr) + debugIO $ "-- getQueuedCompletionStatusEx: n=" ++ show nc ++ " ,err=" ++ show err + if ok then fromIntegral `fmap` peek num_removed_ptr + else do debugIO $ "failed getQueuedCompletionStatusEx: " ++ show err + if err == #{const WAIT_TIMEOUT} || alertable then return 0 + else failWith "GetQueuedCompletionStatusEx" err + +overlappedIOStatus :: LPOVERLAPPED -> IO NTSTATUS +overlappedIOStatus lpol = do + status <- #{peek OVERLAPPED, Internal} lpol + -- TODO: Map NTSTATUS to ErrCode? + -- See https://github.com/libuv/libuv/blob/b12624c13693c4d29ca84b3556eadc9e9c0936a4/src/win/winsock.c#L153 + return status +{-# INLINE overlappedIOStatus #-} + +overlappedIONumBytes :: LPOVERLAPPED -> IO ULONG_PTR +overlappedIONumBytes lpol = do + bytes <- #{peek OVERLAPPED, InternalHigh} lpol + return bytes +{-# INLINE overlappedIONumBytes #-} + +foreign import WINDOWS_CCONV unsafe "windows.h PostQueuedCompletionStatus" + c_PostQueuedCompletionStatus :: IOCP -> DWORD -> ULONG_PTR -> LPOVERLAPPED + -> IO BOOL + +-- | Manually post a completion to the specified I/O port. This will wake up +-- a thread waiting `GetQueuedCompletionStatusEx`. +postQueuedCompletionStatus :: IOCP -> DWORD -> CompletionKey -> LPOVERLAPPED + -> IO () +postQueuedCompletionStatus iocp numBytes completionKey lpol = + failIfFalse_ "PostQueuedCompletionStatus" $ + c_PostQueuedCompletionStatus iocp numBytes completionKey lpol + +------------------------------------------------------------------------ +-- Overlapped + +-- | Tag type for @LPOVERLAPPED@. +data OVERLAPPED + +-- | Tag type for the extended version of @OVERLAPPED@ containg some book +-- keeping information. +data HASKELL_OVERLAPPED + +-- | Identifies an I/O operation. Used as the @LPOVERLAPPED@ parameter +-- for overlapped I/O functions (e.g. @ReadFile@, @WSASend@). +type LPOVERLAPPED = Ptr OVERLAPPED + +-- | Pointer to the extended HASKELL_OVERLAPPED function. +type LPHASKELL_OVERLAPPED = Ptr HASKELL_OVERLAPPED + +-- | An array of these is passed to GetQueuedCompletionStatusEx as an output +-- argument. +data OVERLAPPED_ENTRY = OVERLAPPED_ENTRY { + lpCompletionKey :: ULONG_PTR, + lpOverlapped :: LPOVERLAPPED, + dwNumberOfBytesTransferred :: DWORD + } + +type LPOVERLAPPED_ENTRY = Ptr OVERLAPPED_ENTRY + +instance Storable OVERLAPPED_ENTRY where + sizeOf _ = #{size OVERLAPPED_ENTRY} + alignment _ = #{alignment OVERLAPPED_ENTRY} + + peek ptr = do + lpCompletionKey <- #{peek OVERLAPPED_ENTRY, lpCompletionKey} ptr + lpOverlapped <- #{peek OVERLAPPED_ENTRY, lpOverlapped} ptr + dwNumberOfBytesTransferred <- + #{peek OVERLAPPED_ENTRY, dwNumberOfBytesTransferred} ptr + let !oe = OVERLAPPED_ENTRY{..} + return oe + + poke ptr OVERLAPPED_ENTRY{..} = do + #{poke OVERLAPPED_ENTRY, lpCompletionKey} ptr lpCompletionKey + #{poke OVERLAPPED_ENTRY, lpOverlapped} ptr lpOverlapped + #{poke OVERLAPPED_ENTRY, dwNumberOfBytesTransferred} + ptr dwNumberOfBytesTransferred + +-- | Allocate a new +-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms684342%28v=vs.85%29.aspx +-- OVERLAPPED> structure on the unmanaged heap. This also zeros the memory to +-- prevent the values inside the struct to be incorrectlt interpreted as data +-- payload. +-- +-- We extend the overlapped structure with some extra book keeping information +-- such that we don't have to do a lookup on the Haskell side. +-- +-- Future: We can gain some performance here by using a pool instead of calling +-- malloc for each request. A simple block allocator would be very +-- useful here, especially when we implement sockets support. +allocOverlapped :: Word64 -- ^ Offset/OffsetHigh + -> IO (Ptr HASKELL_OVERLAPPED) +allocOverlapped offset = do + lpol <- mallocBytes #{size HASKELL_OVERLAPPED} + zeroOverlapped lpol + pokeOffsetOverlapped (castPtr lpol) offset + return lpol + +-- | Zero-fill an HASKELL_OVERLAPPED structure. +zeroOverlapped :: LPHASKELL_OVERLAPPED -> IO () +zeroOverlapped lpol = fillBytes lpol 0 #{size HASKELL_OVERLAPPED} +{-# INLINE zeroOverlapped #-} + +-- | Set the offset field in an OVERLAPPED structure. +pokeOffsetOverlapped :: LPOVERLAPPED -> Word64 -> IO () +pokeOffsetOverlapped lpol offset = do + let (offsetHigh, offsetLow) = Win32.ddwordToDwords offset + #{poke OVERLAPPED, Offset} lpol offsetLow + #{poke OVERLAPPED, OffsetHigh} lpol offsetHigh +{-# INLINE pokeOffsetOverlapped #-} + +------------------------------------------------------------------------ +-- Cancel pending I/O + +-- | CancelIo shouldn't block, but cancellation happens infrequently, +-- so we might as well be on the safe side. +foreign import WINDOWS_CCONV unsafe "windows.h CancelIoEx" + c_CancelIoEx :: HANDLE -> LPOVERLAPPED -> IO BOOL + +-- | Cancel all pending overlapped I/O for the given file that was initiated by +-- the current OS thread. Cancelling is just a request for cancellation and +-- before the OVERLAPPED struct is freed we must make sure that the IRQ has been +-- removed from the queue. See `getOverlappedResult`. +cancelIoEx :: HANDLE -> LPOVERLAPPED -> IO () +cancelIoEx h o = failIfFalse_ "CancelIoEx" . c_CancelIoEx h $ o + +cancelIoEx' :: HANDLE -> LPOVERLAPPED -> IO Bool +cancelIoEx' = c_CancelIoEx + +------------------------------------------------------------------------ +-- Monotonic time + +foreign import WINDOWS_CCONV "windows.h GetTickCount64" + c_GetTickCount64 :: IO #{type ULONGLONG} + +-- | Call the @GetTickCount64@ function, which returns a monotonic time in +-- milliseconds. +-- +-- Problems: +-- +-- * Low resolution (10 to 16 milliseconds). +-- +-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms724408%28v=vs.85%29.aspx> +getTickCount64 :: IO Word64 +getTickCount64 = c_GetTickCount64 + +-- | Call the @QueryPerformanceCounter@ function. +-- +-- Problems: +-- +-- * Might not be available on some hardware. Use 'queryPerformanceFrequency' +-- to test for availability before calling this function. +-- +-- * On a multiprocessor computer, may produce different results on +-- different processors due to hardware bugs. +-- +-- To get a monotonic time in seconds, divide the result of +-- 'queryPerformanceCounter' by that of 'queryPerformanceFrequency'. +-- +-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644904%28v=vs.85%29.aspx> +queryPerformanceCounter :: IO Int64 +queryPerformanceCounter = + callQP c_QueryPerformanceCounter + >>= maybe (throwGetLastError "QueryPerformanceCounter") return + +-- | Call the @QueryPerformanceFrequency@ function. Return 'Nothing' if the +-- hardware does not provide a high-resolution performance counter. +-- +-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644905%28v=vs.85%29.aspx> +queryPerformanceFrequency :: IO (Maybe Int64) +queryPerformanceFrequency = do + m <- callQP c_QueryPerformanceFrequency + case m of + Nothing -> return Nothing + Just 0 -> return Nothing -- Shouldn't happen; just a safeguard to + -- avoid a zero denominator. + Just freq -> return (Just freq) + +type QPFunc = Ptr Int64 -> IO BOOL + +foreign import WINDOWS_CCONV "Windows.h QueryPerformanceCounter" + c_QueryPerformanceCounter :: QPFunc + +foreign import WINDOWS_CCONV "Windows.h QueryPerformanceFrequency" + c_QueryPerformanceFrequency :: QPFunc + +callQP :: QPFunc -> IO (Maybe Int64) +callQP qpfunc = + allocaBytes #{size LARGE_INTEGER} $ \ptr -> do + ok <- qpfunc ptr + if ok then do + n <- #{peek LARGE_INTEGER, QuadPart} ptr + return (Just n) + else + return Nothing + +------------------------------------------------------------------------ +-- Miscellaneous + +type ULONG_PTR = #type ULONG_PTR + +throwWinErr :: String -> ErrCode -> IO a +throwWinErr loc err = do + c_SetLastError err + Win32.failWith loc err + +setLastError :: ErrCode -> IO () +setLastError = c_SetLastError + +foreign import WINDOWS_CCONV unsafe "windows.h SetLastError" + c_SetLastError :: ErrCode -> IO () diff --git a/libraries/base/GHC/Event/Windows/ManagedThreadPool.hs b/libraries/base/GHC/Event/Windows/ManagedThreadPool.hs new file mode 100644 index 0000000000..94e498b58e --- /dev/null +++ b/libraries/base/GHC/Event/Windows/ManagedThreadPool.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +------------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.Windows.ManagedThreadPool +-- Copyright : (c) Tamar Christina 2019 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- WinIO Windows Managed Thread pool API. This thread pool scales dynamically +-- based on demand. +-- +------------------------------------------------------------------------------- + +module GHC.Event.Windows.ManagedThreadPool + ( ThreadPool(..) + , startThreadPool + , notifyRunning + , notifyWaiting + , monitorThreadPool + ) where + +import Control.Concurrent.MVar +import Data.Maybe +import Foreign +import GHC.Base +import GHC.Num ((-), (+)) +import GHC.Real (fromIntegral) +import qualified GHC.Event.Array as A +import GHC.IO.Handle.Internals (debugIO) +import GHC.Conc.Sync (ThreadId(..)) +import GHC.RTS.Flags + +------------------------------------------------------------------------ +-- Thread spool manager + +type WorkerJob = IO () + +-- | Thread pool manager state +data ThreadPool = ThreadPool + { thrMainThread :: Maybe ThreadId + , thrMaxThreads :: {-# UNPACK #-} !Int + , thrMinThreads :: {-# UNPACK #-} !Int + , thrCurThreads :: {-# UNPACK #-} !Int + , thrCallBack :: WorkerJob + , thrActiveThreads :: MVar Int + , thrMonitor :: MVar () + , thrThreadIds :: {-#UNPACK #-} !(A.Array ThreadId) + } + +startThreadPool :: WorkerJob -> IO ThreadPool +startThreadPool job = do + debugIO "Starting I/O manager threadpool..." + let thrMinThreads = 2 + let thrCurThreads = 0 + let thrCallBack = job + thrMaxThreads <- (fromIntegral . numIoWorkerThreads) `fmap` getMiscFlags + thrActiveThreads <- newMVar 0 + thrMonitor <- newEmptyMVar + thrThreadIds <- undefined -- A.new thrMaxThreads + let thrMainThread = Nothing + + let !pool = ThreadPool{..} + return pool + +monitorThreadPool :: MVar () -> IO () +monitorThreadPool monitor = do + _active <- takeMVar monitor + + return () + +notifyRunning :: Maybe ThreadPool -> IO () +notifyRunning Nothing = return () +notifyRunning (Just pool) = do + modifyMVar_ (thrActiveThreads pool) (\x -> return $ x + 1) + _ <- tryPutMVar (thrMonitor pool) () + return () + +notifyWaiting :: Maybe ThreadPool -> IO () +notifyWaiting Nothing = return () +notifyWaiting (Just pool) = do + modifyMVar_ (thrActiveThreads pool) (\x -> return $ x - 1) + _ <- tryPutMVar (thrMonitor pool) () + return () diff --git a/libraries/base/GHC/Event/Windows/Thread.hs b/libraries/base/GHC/Event/Windows/Thread.hs new file mode 100644 index 0000000000..57faa9de80 --- /dev/null +++ b/libraries/base/GHC/Event/Windows/Thread.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Event.Windows.Thread ( + ensureIOManagerIsRunning, + interruptIOManager, + threadDelay, + registerDelay, +) where + +import GHC.Conc.Sync +import GHC.Base +import GHC.Event.Windows +import GHC.IO +import GHC.IOPort + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning = wakeupIOManager + +interruptIOManager :: IO () +interruptIOManager = interruptSystemManager + +threadDelay :: Int -> IO () +threadDelay usecs = mask_ $ do + m <- newEmptyIOPort + mgr <- getSystemManager + reg <- registerTimeout mgr usecs $ writeIOPort m () >> return () + readIOPort m `onException` unregisterTimeout mgr reg + +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs = do + t <- newTVarIO False + mgr <- getSystemManager + _ <- registerTimeout mgr usecs $ atomically $ writeTVar t True + return t + diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs index 447c574e2b..167bc2a346 100644 --- a/libraries/base/GHC/IO/Buffer.hs +++ b/libraries/base/GHC/IO/Buffer.hs @@ -31,6 +31,8 @@ module GHC.IO.Buffer ( bufferAdd, slideContents, bufferAdjustL, + bufferAddOffset, + bufferAdjustOffset, -- ** Inspecting isEmptyBuffer, @@ -39,6 +41,7 @@ module GHC.IO.Buffer ( isWriteBuffer, bufferElems, bufferAvailable, + bufferOffset, summaryBuffer, -- ** Operating on the raw buffer as a Ptr @@ -68,6 +71,7 @@ import GHC.Ptr import GHC.Word import GHC.Show import GHC.Real +import GHC.List import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Storable @@ -89,6 +93,9 @@ import Foreign.Storable -- broken. In particular, the built-in codecs -- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or -- similar in place of the ow >= os comparisons. +-- +-- Tamar: We need to do this eventually for Windows, as we have to re-encode +-- the text as UTF-16 anyway, so if we can avoid it it would be great. -- --------------------------------------------------------------------------- -- Raw blocks of data @@ -177,13 +184,27 @@ charSize = 4 -- a memory-mapped file and in which case 'bufL' will point to the -- next location to be written, which is not necessarily the beginning -- of the file. +-- +-- On Posix systems the I/O manager has an implicit reliance on doing a file +-- read moving the file pointer. However on Windows async operations the kernel +-- object representing a file does not use the file pointer offset. Logically +-- this makes sense since operations can be performed in any arbitrary order. +-- OVERLAPPED operations don't respect the file pointer offset as their +-- intention is to support arbitrary async reads to anywhere at a much lower +-- level. As such we should explicitly keep track of the file offsets of the +-- target in the buffer. Any operation to seek should also update this entry. +-- +-- In order to keep us sane we try to uphold the invariant that any function +-- being passed a Handle is responsible for updating the handles offset unless +-- other behaviour is documented. data Buffer e = Buffer { - bufRaw :: !(RawBuffer e), - bufState :: BufferState, - bufSize :: !Int, -- in elements, not bytes - bufL :: !Int, -- offset of first item in the buffer - bufR :: !Int -- offset of last item + 1 + bufRaw :: !(RawBuffer e), + bufState :: BufferState, + bufSize :: !Int, -- in elements, not bytes + bufOffset :: !Word64, -- start location for next read/write + bufL :: !Int, -- offset of first item in the buffer + bufR :: !Int -- offset of last item + 1 } #if defined(CHARBUF_UTF16) @@ -237,9 +258,22 @@ bufferAdjustL l buf@Buffer{ bufR=w } bufferAdd :: Int -> Buffer e -> Buffer e bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i } +bufferOffset :: Buffer e -> Word64 +bufferOffset Buffer{ bufOffset=off } = off + +bufferAdjustOffset :: Word64 -> Buffer e -> Buffer e +bufferAdjustOffset offs buf = buf{ bufOffset=offs } + +-- The adjustment to the offset can be 32bit int on 32 platforms. +-- This is fine, we only use this after reading into/writing from +-- the buffer so we will never overflow here. +bufferAddOffset :: Int -> Buffer e -> Buffer e +bufferAddOffset offs buf@Buffer{ bufOffset=w } = + buf{ bufOffset=w+(fromIntegral offs) } + emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e emptyBuffer raw sz state = - Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz } + Buffer{ bufRaw=raw, bufState=state, bufOffset=0, bufR=0, bufL=0, bufSize=sz } newByteBuffer :: Int -> BufferState -> IO (Buffer Word8) newByteBuffer c st = newBuffer c c st @@ -266,9 +300,16 @@ foreign import ccall unsafe "memmove" summaryBuffer :: Buffer a -> String summaryBuffer !buf -- Strict => slightly better code - = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" - --- INVARIANTS on Buffers: + = ppr (show $ bufRaw buf) ++ "@buf" ++ show (bufSize buf) + ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" + ++ " (>=" ++ show (bufOffset buf) ++ ")" + where ppr :: String -> String + ppr ('0':'x':xs) = let p = dropWhile (=='0') xs + in if null p then "0x0" else '0':'x':p + ppr x = x + +-- Note [INVARIANTS on Buffers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- * r <= w -- * if r == w, and the buffer is for reading, then r == 0 && w == 0 -- * a write buffer is never full. If an operation diff --git a/libraries/base/GHC/IO/BufferedIO.hs b/libraries/base/GHC/IO/BufferedIO.hs index cd38cefe07..c6f4cde477 100644 --- a/libraries/base/GHC/IO/BufferedIO.hs +++ b/libraries/base/GHC/IO/BufferedIO.hs @@ -92,9 +92,11 @@ class BufferedIO dev where readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) readBuf dev bbuf = do let bytes = bufferAvailable bbuf + let offset = bufferOffset bbuf res <- withBuffer bbuf $ \ptr -> - RawIO.read dev (ptr `plusPtr` bufR bbuf) bytes - return (res, bbuf{ bufR = bufR bbuf + res }) + RawIO.read dev (ptr `plusPtr` bufR bbuf) offset bytes + let bbuf' = bufferAddOffset res bbuf + return (res, bbuf'{ bufR = bufR bbuf' + res }) -- zero indicates end of file readBufNonBlocking :: RawIO dev => dev -> Buffer Word8 @@ -103,24 +105,30 @@ readBufNonBlocking :: RawIO dev => dev -> Buffer Word8 Buffer Word8) readBufNonBlocking dev bbuf = do let bytes = bufferAvailable bbuf + let offset = bufferOffset bbuf res <- withBuffer bbuf $ \ptr -> - IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) bytes + IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) offset bytes case res of Nothing -> return (Nothing, bbuf) - Just n -> return (Just n, bbuf{ bufR = bufR bbuf + n }) + Just n -> do let bbuf' = bufferAddOffset n bbuf + return (Just n, bbuf'{ bufR = bufR bbuf' + n }) writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Buffer Word8) writeBuf dev bbuf = do let bytes = bufferElems bbuf + let offset = bufferOffset bbuf withBuffer bbuf $ \ptr -> - IODevice.write dev (ptr `plusPtr` bufL bbuf) bytes - return bbuf{ bufL=0, bufR=0 } + IODevice.write dev (ptr `plusPtr` bufL bbuf) offset bytes + let bbuf' = bufferAddOffset bytes bbuf + return bbuf'{ bufL=0, bufR=0 } -- XXX ToDo writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) writeBufNonBlocking dev bbuf = do let bytes = bufferElems bbuf + let offset = bufferOffset bbuf res <- withBuffer bbuf $ \ptr -> - IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) bytes - return (res, bufferAdjustL (bufL bbuf + res) bbuf) + IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) offset bytes + let bbuf' = bufferAddOffset bytes bbuf + return (res, bufferAdjustL (bufL bbuf + res) bbuf') diff --git a/libraries/base/GHC/IO/Device.hs b/libraries/base/GHC/IO/Device.hs index 024ff7bbbb..0f244ae626 100644 --- a/libraries/base/GHC/IO/Device.hs +++ b/libraries/base/GHC/IO/Device.hs @@ -34,26 +34,29 @@ import GHC.IO import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation ) -- | A low-level I/O provider where the data is bytes in memory. +-- The Word64 offsets currently have no effect on POSIX system or consoles +-- where the implicit behaviour of the C runtime is assume to move the file +-- pointer on every read/write without needing an explicit seek. class RawIO a where - -- | Read up to the specified number of bytes, returning the number - -- of bytes actually read. This function should only block if there - -- is no data available. If there is not enough data available, - -- then the function should just return the available data. A return - -- value of zero indicates that the end of the data stream (e.g. end + -- | Read up to the specified number of bytes starting from a specified + -- offset, returning the number of bytes actually read. This function + -- should only block if there is no data available. If there is not enough + -- data available, then the function should just return the available data. + -- A return value of zero indicates that the end of the data stream (e.g. end -- of file) has been reached. - read :: a -> Ptr Word8 -> Int -> IO Int + read :: a -> Ptr Word8 -> Word64 -> Int -> IO Int - -- | Read up to the specified number of bytes, returning the number - -- of bytes actually read, or 'Nothing' if the end of the stream has - -- been reached. - readNonBlocking :: a -> Ptr Word8 -> Int -> IO (Maybe Int) + -- | Read up to the specified number of bytes starting from a specified + -- offset, returning the number of bytes actually read, or 'Nothing' if + -- the end of the stream has been reached. + readNonBlocking :: a -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int) - -- | Write the specified number of bytes. - write :: a -> Ptr Word8 -> Int -> IO () + -- | Write the specified number of bytes starting at a given offset. + write :: a -> Ptr Word8 -> Word64 -> Int -> IO () - -- | Write up to the specified number of bytes without blocking. Returns - -- the actual number of bytes written. - writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int + -- | Write up to the specified number of bytes without blocking starting at a + -- given offset. Returns the actual number of bytes written. + writeNonBlocking :: a -> Ptr Word8 -> Word64 -> Int -> IO Int -- | I/O operations required for implementing a 'System.IO.Handle'. @@ -78,7 +81,7 @@ class IODevice a where isSeekable _ = return False -- | seek to the specified position in the data. - seek :: a -> SeekMode -> Integer -> IO () + seek :: a -> SeekMode -> Integer -> IO Integer seek _ _ _ = ioe_unsupportedOperation -- | return the current position in the data. diff --git a/libraries/base/GHC/IO/Encoding/CodePage.hs b/libraries/base/GHC/IO/Encoding/CodePage.hs index 42980b59bc..ef03e985fa 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage.hs @@ -5,7 +5,8 @@ module GHC.IO.Encoding.CodePage( #if defined(mingw32_HOST_OS) codePageEncoding, mkCodePageEncoding, - localeEncoding, mkLocaleEncoding + localeEncoding, mkLocaleEncoding, CodePage, + getCurrentCodePage #endif ) where @@ -32,19 +33,15 @@ import GHC.IO.Encoding.UTF8 (mkUTF8) import GHC.IO.Encoding.UTF16 (mkUTF16le, mkUTF16be) import GHC.IO.Encoding.UTF32 (mkUTF32le, mkUTF32be) -#if defined(mingw32_HOST_OS) -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif -#endif +import GHC.Windows (DWORD) + +#include "windows_cconv.h" + +type CodePage = DWORD -- note CodePage = UInt which might not work on Win64. But the Win32 package -- also has this issue. -getCurrentCodePage :: IO Word32 +getCurrentCodePage :: IO CodePage getCurrentCodePage = do conCP <- getConsoleCP if conCP > 0 diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs index 9c2dc0e85c..41bc8d0f07 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs @@ -27,7 +27,7 @@ import GHC.IO.Encoding.UTF16 import GHC.Num import GHC.Show import GHC.Real -import GHC.Windows +import GHC.Windows hiding (LPCSTR) import GHC.ForeignPtr (castForeignPtr) import System.Posix.Internals @@ -41,15 +41,7 @@ debugIO s | c_DEBUG_DUMP = puts s | otherwise = return () - -#if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - +#include "windows_cconv.h" type LPCSTR = Ptr Word8 @@ -188,10 +180,10 @@ saner code ibuf obuf = do else return (why, bufL ibuf' - bufL ibuf, ibuf', obuf') byteView :: Buffer CWchar -> Buffer Word8 -byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = bufSize * 2, bufL = bufL * 2, bufR = bufR * 2 } +byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = bufSize * 2, bufOffset = bufOffset, bufL = bufL * 2, bufR = bufR * 2 } cwcharView :: Buffer Word8 -> Buffer CWchar -cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufL = half bufL, bufR = half bufR } +cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufOffset = bufOffset, bufL = half bufL, bufR = half bufR } where half x = case x `divMod` 2 of (y, 0) -> y _ -> errorWithoutStackTrace "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes" diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index ad9b11564a..4245bf0b26 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -6,7 +6,6 @@ {-# OPTIONS_GHC -Wno-identities #-} -- Whether there are identities depends on the platform {-# OPTIONS_HADDOCK not-home #-} - ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.FD @@ -46,6 +45,7 @@ import GHC.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Windows import Data.Bool +import GHC.IO.SubSystem ((<!>)) #endif import Foreign @@ -101,29 +101,37 @@ fdIsSocket fd = fdIsSocket_ fd /= 0 instance Show FD where show fd = show (fdFD fd) +{-# INLINE ifSupported #-} +ifSupported :: String -> a -> a +#if defined(mingw32_HOST_OS) +ifSupported s a = a <!> (error $ "FD:" ++ s ++ " not supported") +#else +ifSupported _ = id +#endif + -- | @since 4.1.0.0 instance GHC.IO.Device.RawIO FD where - read = fdRead - readNonBlocking = fdReadNonBlocking - write = fdWrite - writeNonBlocking = fdWriteNonBlocking + read = ifSupported "fdRead" fdRead + readNonBlocking = ifSupported "fdReadNonBlocking" fdReadNonBlocking + write = ifSupported "fdWrite" fdWrite + writeNonBlocking = ifSupported "fdWriteNonBlocking" fdWriteNonBlocking -- | @since 4.1.0.0 instance GHC.IO.Device.IODevice FD where - ready = ready - close = close - isTerminal = isTerminal - isSeekable = isSeekable - seek = seek - tell = tell - getSize = getSize - setSize = setSize - setEcho = setEcho - getEcho = getEcho - setRaw = setRaw - devType = devType - dup = dup - dup2 = dup2 + ready = ifSupported "ready" ready + close = ifSupported "close" close + isTerminal = ifSupported "isTerm" isTerminal + isSeekable = ifSupported "isSeek" isSeekable + seek = ifSupported "seek" seek + tell = ifSupported "tell" tell + getSize = ifSupported "getSize" getSize + setSize = ifSupported "setSize" setSize + setEcho = ifSupported "setEcho" setEcho + getEcho = ifSupported "getEcho" getEcho + setRaw = ifSupported "setRaw" setRaw + devType = ifSupported "devType" devType + dup = ifSupported "dup" dup + dup2 = ifSupported "dup2" dup2 -- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is -- taken from the value of BUFSIZ on the current platform. This value @@ -134,11 +142,11 @@ dEFAULT_FD_BUFFER_SIZE = 8192 -- | @since 4.1.0.0 instance BufferedIO FD where - newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state - fillReadBuffer fd buf = readBuf' fd buf - fillReadBuffer0 fd buf = readBufNonBlocking fd buf - flushWriteBuffer fd buf = writeBuf' fd buf - flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf + newBuffer _dev state = ifSupported "newBuf" $ newByteBuffer dEFAULT_FD_BUFFER_SIZE state + fillReadBuffer fd buf = ifSupported "readBuf" $ readBuf' fd buf + fillReadBuffer0 fd buf = ifSupported "readBufNonBlock" $ readBufNonBlocking fd buf + flushWriteBuffer fd buf = ifSupported "writeBuf" $ writeBuf' fd buf + flushWriteBuffer0 fd buf = ifSupported "writeBufNonBlock" $ writeBufNonBlocking fd buf readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8) readBuf' fd buf = do @@ -256,8 +264,10 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do RegularFile -> do -- On Windows we need an additional call to get a unique device id -- and inode, since fstat just returns 0 for both. + -- See also Note [RTS File locking] (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino - r <- lockFile fd unique_dev unique_ino (fromBool write) + r <- lockFile (fromIntegral fd) unique_dev unique_ino + (fromBool write) when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing Nothing) @@ -335,7 +345,7 @@ close fd = closeFdWith closer (fromIntegral (fdFD fd)) release :: FD -> IO () -release fd = do _ <- unlockFile (fdFD fd) +release fd = do _ <- unlockFile (fromIntegral $ fdFD fd) return () #if defined(mingw32_HOST_OS) @@ -348,10 +358,10 @@ isSeekable fd = do t <- devType fd return (t == RegularFile || t == RawDevice) -seek :: FD -> SeekMode -> Integer -> IO () -seek fd mode off = do - throwErrnoIfMinus1Retry_ "seek" $ - c_lseek (fdFD fd) (fromIntegral off) seektype +seek :: FD -> SeekMode -> Integer -> IO Integer +seek fd mode off = fromIntegral `fmap` + (throwErrnoIfMinus1Retry "seek" $ + c_lseek (fdFD fd) (fromIntegral off) seektype) where seektype :: CInt seektype = case mode of @@ -436,14 +446,14 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw) -- ----------------------------------------------------------------------------- -- Reading and Writing -fdRead :: FD -> Ptr Word8 -> Int -> IO Int -fdRead fd ptr bytes +fdRead :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int +fdRead fd ptr _offset bytes = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral $ clampReadSize bytes) ; return (fromIntegral r) } -fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int) -fdReadNonBlocking fd ptr bytes = do +fdReadNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int) +fdReadNonBlocking fd ptr _offset bytes = do r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 0 (fromIntegral $ clampReadSize bytes) case fromIntegral r of @@ -451,18 +461,18 @@ fdReadNonBlocking fd ptr bytes = do n -> return (Just n) -fdWrite :: FD -> Ptr Word8 -> Int -> IO () -fdWrite fd ptr bytes = do +fdWrite :: FD -> Ptr Word8 -> Word64 -> Int -> IO () +fdWrite fd ptr _offset bytes = do res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral $ clampWriteSize bytes) let res' = fromIntegral res if res' < bytes - then fdWrite fd (ptr `plusPtr` res') (bytes - res') + then fdWrite fd (ptr `plusPtr` res') (_offset + fromIntegral res') (bytes - res') else return () -- XXX ToDo: this isn't non-blocking -fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int -fdWriteNonBlocking fd ptr bytes = do +fdWriteNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int +fdWriteNonBlocking fd ptr _offset bytes = do res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0 (fromIntegral $ clampWriteSize bytes) return (fromIntegral res) @@ -688,10 +698,10 @@ throwErrnoIfMinus1RetryOnBlock loc f on_block = -- Locking/unlocking foreign import ccall unsafe "lockFile" - lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt + lockFile :: Word64 -> Word64 -> Word64 -> CInt -> IO CInt foreign import ccall unsafe "unlockFile" - unlockFile :: CInt -> IO CInt + unlockFile :: Word64 -> IO CInt #if defined(mingw32_HOST_OS) foreign import ccall unsafe "get_unique_file_info" diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs index a847bcffca..f62acc1510 100644 --- a/libraries/base/GHC/IO/Handle.hs +++ b/libraries/base/GHC/IO/Handle.hs @@ -56,7 +56,8 @@ import GHC.IO.Encoding import GHC.IO.Buffer import GHC.IO.BufferedIO ( BufferedIO ) import GHC.IO.Device as IODevice -import GHC.IO.Handle.FD +import GHC.IO.StdHandles +import GHC.IO.SubSystem import GHC.IO.Handle.Lock import GHC.IO.Handle.Types import GHC.IO.Handle.Internals @@ -120,10 +121,12 @@ hFileSize handle = SemiClosedHandle -> ioe_semiclosedHandle _ -> do flushWriteBuffer handle_ r <- IODevice.getSize dev + debugIO $ "hFileSize: " ++ show r ++ " " ++ show handle if r /= -1 - then return r - else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing Nothing) + then return r + else ioException (IOError Nothing InappropriateType "hFileSize" + "not a regular file" Nothing Nothing) + -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. @@ -234,10 +237,11 @@ hSetBuffering handle mode = case mode of #if !defined(mingw32_HOST_OS) -- 'raw' mode under win32 is a bit too specialised (and troublesome - -- for most common uses), so simply disable its use here. + -- for most common uses), so simply disable its use here when not using + -- WinIO. NoBuffering -> IODevice.setRaw haDevice True #else - NoBuffering -> return () + NoBuffering -> return () <!> IODevice.setRaw haDevice True #endif _ -> IODevice.setRaw haDevice False @@ -402,22 +406,36 @@ hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do debugIO ("hSeek " ++ show (mode,offset)) - buf <- readIORef haCharBuffer + cbuf <- readIORef haCharBuffer + bbuf <- readIORef haByteBuffer + debugIO $ "hSeek - bbuf:" ++ summaryBuffer bbuf + debugIO $ "hSeek - cbuf:" ++ summaryBuffer cbuf - if isWriteBuffer buf + if isWriteBuffer cbuf then do flushWriteBuffer handle_ - IODevice.seek haDevice mode offset + new_offset <- IODevice.seek haDevice mode offset + -- buffer has been updated, need to re-read it + bbuf1 <- readIORef haByteBuffer + let bbuf2 = bbuf1{ bufOffset = fromIntegral new_offset } + debugIO $ "hSeek - seek:: " ++ show offset ++ + " - " ++ show new_offset + debugIO $ "hSeek - wr flush bbuf1:" ++ summaryBuffer bbuf2 + writeIORef haByteBuffer bbuf2 else do - let r = bufL buf; w = bufR buf + let r = bufL cbuf; w = bufR cbuf if mode == RelativeSeek && isNothing haDecoder && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset } + then writeIORef haCharBuffer cbuf{ bufL = r + fromIntegral offset } else do flushCharReadBuffer handle_ flushByteReadBuffer handle_ - IODevice.seek haDevice mode offset + -- read the updated values + bbuf2 <- readIORef haByteBuffer + new_offset <- IODevice.seek haDevice mode offset + debugIO $ "hSeek after: " ++ show new_offset + writeIORef haByteBuffer bbuf2{ bufOffset = fromIntegral new_offset } -- | Computation 'hTell' @hdl@ returns the current position of the @@ -433,13 +451,18 @@ hTell :: Handle -> IO Integer hTell handle = wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do - posn <- IODevice.tell haDevice + -- TODO: Guard these on Windows + posn <- if ioSubSystem == IoNative + then (fromIntegral . bufOffset) `fmap` readIORef haByteBuffer + else IODevice.tell haDevice -- we can't tell the real byte offset if there are buffered -- Chars, so must flush first: flushCharBuffer handle_ bbuf <- readIORef haByteBuffer + debugIO ("hTell bbuf (elems=" ++ show (bufferElems bbuf) ++ ")" + ++ summaryBuffer bbuf) let real_posn | isWriteBuffer bbuf = posn + fromIntegral (bufferElems bbuf) @@ -448,7 +471,7 @@ hTell handle = cbuf <- readIORef haCharBuffer debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn)) debugIO (" cbuf: " ++ summaryBuffer cbuf ++ - " bbuf: " ++ summaryBuffer bbuf) + " bbuf: " ++ summaryBuffer bbuf) return real_posn @@ -647,7 +670,7 @@ dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do dupHandle_ dev filepath other_side h_ mb_finalizer -dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev +dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev -> FilePath -> Maybe (MVar Handle__) -> Handle__ diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs index c0b7e35a11..120ae0ea66 100644 --- a/libraries/base/GHC/IO/Handle/Internals.hs +++ b/libraries/base/GHC/IO/Handle/Internals.hs @@ -51,7 +51,7 @@ module GHC.IO.Handle.Internals ( HandleFinalizer, handleFinalizer, - debugIO, + debugIO, traceIO ) where import GHC.IO @@ -62,7 +62,8 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO (BufferedIO) import GHC.IO.Exception -import GHC.IO.Device (IODevice, SeekMode(..)) +import GHC.IO.Device (IODevice, RawIO, SeekMode(..)) +import GHC.IO.SubSystem ((<!>), isWindowsNativeIO) import qualified GHC.IO.Device as IODevice import qualified GHC.IO.BufferedIO as Buffered @@ -93,8 +94,10 @@ newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle newFileHandle filepath mb_finalizer hc = do m <- newMVar hc case mb_finalizer of - Just finalizer -> addMVarFinalizer m (finalizer filepath m) - Nothing -> return () + Just finalizer -> do debugIO $ "Registering finalizer: " ++ show filepath + addMVarFinalizer m (finalizer filepath m) + Nothing -> do debugIO $ "No finalizer: " ++ show filepath + return () return (FileHandle filepath m) -- --------------------------------------------------------------------------- @@ -222,6 +225,11 @@ augmentIOError ioe@IOError{ ioe_filename = fp } fun h -- --------------------------------------------------------------------------- -- Wrapper for write operations. +-- If we already have a writeable handle just run the action. +-- If we have a read only handle we throw an exception. +-- If we have a read/write handle in read mode we: +-- * Seek to the unread (from the users PoV) position and +-- change the handles buffer to a write buffer. wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantWritableHandle fun h@(FileHandle _ m) act = wantWritableHandle' fun h m act @@ -253,13 +261,15 @@ checkWritableHandle act h_@Handle__{..} buf' <- Buffered.emptyWriteBuffer haDevice buf writeIORef haByteBuffer buf' act h_ - _other -> act h_ + AppendHandle -> act h_ + WriteHandle -> act h_ -- --------------------------------------------------------------------------- -- Wrapper for read operations. wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a -wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act) +wantReadableHandle fun h act = + withHandle fun h (checkReadableHandle act) wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle_ fun h@(FileHandle _ m) act @@ -504,11 +514,13 @@ flushByteWriteBuffer h_@Handle__{..} = do bbuf <- readIORef haByteBuffer when (not (isEmptyBuffer bbuf)) $ do bbuf' <- Buffered.flushWriteBuffer haDevice bbuf + debugIO ("flushByteWriteBuffer: bbuf=" ++ summaryBuffer bbuf') writeIORef haByteBuffer bbuf' -- write the contents of the CharBuffer to the Handle__. -- The data will be encoded and pushed to the byte buffer, -- flushing if the buffer becomes full. +-- Data is written to the handles current buffer offset. writeCharBuffer :: Handle__ -> CharBuffer -> IO () writeCharBuffer h_@Handle__{..} !cbuf = do -- @@ -536,6 +548,7 @@ writeCharBuffer h_@Handle__{..} !cbuf = do then do bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf' writeIORef haByteBuffer bbuf'' + debugIO ("writeCharBuffer after flushing: cbuf=" ++ summaryBuffer bbuf'') else writeIORef haByteBuffer bbuf' @@ -583,8 +596,12 @@ flushCharReadBuffer Handle__{..} = do (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0 cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 } - debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++ - " cbuf=" ++ summaryBuffer cbuf1) + -- We should not need to update the offset here. The bytebuffer contains the + -- offset for the next read after it's used up. But this function only flushes + -- the char buffer. + -- let bbuf2 = bbuf1 -- {bufOffset = bufOffset bbuf1 - fromIntegral (bufL bbuf1)} + -- debugIO ("finished, bbuf=" ++ summaryBuffer bbuf2 ++ + -- " cbuf=" ++ summaryBuffer cbuf1) writeIORef haByteBuffer bbuf1 @@ -604,30 +621,51 @@ flushByteReadBuffer h_@Handle__{..} = do when (not seekable) $ ioe_cannotFlushNotSeekable let seek = negate (bufR bbuf - bufL bbuf) + let offset = bufOffset bbuf - fromIntegral (bufR bbuf - bufL bbuf) debugIO ("flushByteReadBuffer: new file offset = " ++ show seek) - IODevice.seek haDevice RelativeSeek (fromIntegral seek) + debugIO ("flushByteReadBuffer: " ++ summaryBuffer bbuf) + + let mIOSeek = IODevice.seek haDevice RelativeSeek (fromIntegral seek) + -- win-io doesn't need this, but it allows us to error out on invalid offsets + let winIOSeek = IODevice.seek haDevice AbsoluteSeek (fromIntegral offset) + + _ <- mIOSeek <!> winIOSeek -- execute one of these two seek functions - writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 } + writeIORef haByteBuffer bbuf{ bufL=0, bufR=0, bufOffset=offset } -- ---------------------------------------------------------------------------- -- Making Handles -mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev - -> FilePath - -> HandleType - -> Bool -- buffered? - -> Maybe TextEncoding - -> NewlineMode - -> Maybe HandleFinalizer - -> Maybe (MVar Handle__) - -> IO Handle - -mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do +{- Note [Making offsets for append] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The WINIO subysstem keeps track of offsets for handles + on the Haskell side of things instead of letting the OS + handle it. This requires us to establish the correct offset + for a handle on creation. This is usually zero but slightly + more tedious for append modes. There we fall back on IODevice + functionality to establish the size of the file and then set + the offset accordingly. This is only required for WINIO. +-} + +mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> HandleType + -> Bool -- buffered? + -> Maybe TextEncoding + -> NewlineMode + -> Maybe HandleFinalizer + -> Maybe (MVar Handle__) + -> IO Handle +mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do - let buf_state = initBufferState ha_type - bbuf <- Buffered.newBuffer dev buf_state + let !buf_state = initBufferState ha_type + !bbuf_no_offset <- (Buffered.newBuffer dev buf_state) + !buf_offset <- initHandleOffset + let !bbuf = bbuf_no_offset { bufOffset = buf_offset} + bbufref <- newIORef bbuf last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf) @@ -636,6 +674,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do else mkUnBuffer buf_state spares <- newIORef BufferListNil + debugIO $ "making handle for " ++ filepath newFileHandle filepath finalizer (Handle__ { haDevice = dev, haType = ha_type, @@ -651,9 +690,17 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do haOutputNL = outputNL nl, haOtherSide = other_side }) + where + -- See Note [Making offsets for append] + initHandleOffset + | isAppendHandleType ha_type + , isWindowsNativeIO = do + size <- IODevice.getSize dev + return (fromIntegral size :: Word64) + | otherwise = return 0 -- | makes a new 'Handle' -mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev) +mkFileHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev -- ^ the underlying IO device, which must support -- 'IODevice', 'BufferedIO' and 'Typeable' -> FilePath @@ -674,7 +721,7 @@ mkFileHandle dev filepath iomode mb_codec tr_newlines = do -- | like 'mkFileHandle', except that a 'Handle' is created with two -- independent buffers, one for reading and one for writing. Used for -- full-duplex streams, such as network sockets. -mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev +mkDuplexHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle mkDuplexHandle dev filepath mb_codec tr_newlines = do @@ -806,6 +853,7 @@ hLookAhead_ handle_@Handle__{..} = do -- debugging debugIO :: String -> IO () +-- debugIO s = traceEventIO s debugIO s | c_DEBUG_DUMP = do _ <- withCStringLen (s ++ "\n") $ @@ -813,6 +861,13 @@ debugIO s return () | otherwise = return () +-- For development, like debugIO but always on. +traceIO :: String -> IO () +traceIO s = do + _ <- withCStringLen (s ++ "\n") $ + \(p, len) -> c_write 1 (castPtr p) (fromIntegral len) + return () + -- ---------------------------------------------------------------------------- -- Text input/output @@ -840,7 +895,9 @@ readTextDevice h_@Handle__{..} cbuf = do bbuf1 <- if not (isEmptyBuffer bbuf0) then return bbuf0 else do + debugIO $ "readBuf at " ++ show (bufferOffset bbuf0) (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0 + debugIO $ "readBuf after " ++ show (bufferOffset bbuf1) if r == 0 then ioe_EOF else do -- raise EOF return bbuf1 diff --git a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc index 1118e523ec..f1e54125bb 100644 --- a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc +++ b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc @@ -13,32 +13,60 @@ module GHC.IO.Handle.Lock.Windows where import GHC.Base () -- Make implicit dependency known to build system #else -#if defined(i386_HOST_ARCH) -## define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -## define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - +##include <windows_cconv.h> #include <windows.h> import Data.Bits import Data.Function +import GHC.IO.Handle.Windows (handleToHANDLE) import Foreign.C.Error import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import GHC.Base +import qualified GHC.Event.Windows as Mgr +import GHC.Event.Windows (LPOVERLAPPED, withOverlapped) import GHC.IO.FD import GHC.IO.Handle.FD import GHC.IO.Handle.Types (Handle) import GHC.IO.Handle.Lock.Common (LockMode(..)) -import GHC.Ptr +import GHC.IO.SubSystem import GHC.Windows lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do +lockImpl = lockImplPOSIX <!> lockImplWinIO + +lockImplWinIO :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImplWinIO h ctx mode block = do + wh <- handleToHANDLE h + fix $ \retry -> + do retcode <- Mgr.withException ctx $ + withOverlapped ctx wh 0 (startCB wh) completionCB + case () of + _ | retcode == #{const ERROR_OPERATION_ABORTED} -> retry + | retcode == #{const ERROR_SUCCESS} -> return True + | retcode == #{const ERROR_LOCK_VIOLATION} && not block + -> return False + | otherwise -> failWith ctx retcode + where + cmode = case mode of + SharedLock -> 0 + ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} + flags = if block + then cmode + else cmode .|. #{const LOCKFILE_FAIL_IMMEDIATELY} + + startCB wh lpOverlapped = do + ret <- c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE} + lpOverlapped + return $ Mgr.CbNone ret + + completionCB err _dwBytes + | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0 + | otherwise = Mgr.ioFailed err + +lockImplPOSIX :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImplPOSIX h ctx mode block = do FD{fdFD = fd} <- handleToFd h wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do @@ -49,12 +77,13 @@ lockImpl h ctx mode block = do -- "locking a region that goes beyond the current end-of-file position is -- not an error", hence we pass maximum value as the number of bytes to -- lock. - fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd >>= \case + fix $ \retry -> c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE} + ovrlpd >>= \case True -> return True False -> getLastError >>= \err -> if | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False - | err == #{const ERROR_OPERATION_ABORTED} -> retry - | otherwise -> failWith ctx err + | err == #{const ERROR_OPERATION_ABORTED} -> retry + | otherwise -> failWith ctx err where sizeof_OVERLAPPED = #{size OVERLAPPED} @@ -63,12 +92,31 @@ lockImpl h ctx mode block = do ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} unlockImpl :: Handle -> IO () -unlockImpl h = do +unlockImpl = unlockImplPOSIX <!> unlockImplWinIO + +unlockImplWinIO :: Handle -> IO () +unlockImplWinIO h = do + wh <- handleToHANDLE h + _ <- Mgr.withException "unlockImpl" $ + withOverlapped "unlockImpl" wh 0 (startCB wh) completionCB + return () + where + startCB wh lpOverlapped = do + ret <- c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE} + lpOverlapped + return $ Mgr.CbNone ret + + completionCB err _dwBytes + | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0 + | otherwise = Mgr.ioFailed err + +unlockImplPOSIX :: Handle -> IO () +unlockImplPOSIX h = do FD{fdFD = fd} <- handleToFd h wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do fillBytes ovrlpd 0 sizeof_OVERLAPPED - c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case + c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE} ovrlpd >>= \case True -> return () False -> getLastError >>= failWith "hUnlock" where @@ -80,10 +128,11 @@ foreign import ccall unsafe "_get_osfhandle" -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx foreign import WINDOWS_CCONV interruptible "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED + -> IO BOOL -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx foreign import WINDOWS_CCONV interruptible "UnlockFileEx" - c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL #endif diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index 20a449f39d..6d63bb0d54 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -6,7 +6,6 @@ , NondecreasingIndentation , MagicHash #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_HADDOCK not-home #-} @@ -32,7 +31,6 @@ module GHC.IO.Handle.Text ( ) where import GHC.IO -import GHC.IO.FD import GHC.IO.Buffer import qualified GHC.IO.BufferedIO as Buffered import GHC.IO.Exception @@ -46,7 +44,6 @@ import Foreign import Foreign.C import qualified Control.Exception as Exception -import Data.Typeable import System.IO.Error import Data.Either (Either(..)) import Data.Maybe @@ -578,9 +575,9 @@ hPutcBuffered handle_@Handle__{..} c = do LineBuffering -> True _ -> False - putc buf@Buffer{ bufRaw=raw, bufR=w } c = do + putc buf@Buffer{ bufRaw=raw, bufR=w } c' = do debugIO ("putc: " ++ summaryBuffer buf) - w' <- writeCharBuf raw w c + w' <- writeCharBuf raw w c' return buf{ bufR = w' } -- --------------------------------------------------------------------------- @@ -644,6 +641,7 @@ hPutChars :: Handle -> [Char] -> IO () hPutChars _ [] = return () hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs +-- Buffer offset is always zero. getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) getSpareBuffer Handle__{haCharBuffer=ref, haBuffers=spare_ref, @@ -703,7 +701,6 @@ writeBlocks hdl line_buffered add_nl nl -- -- Write the contents of the buffer 'buf' ('sz' bytes long, containing -- 'count' bytes of data) to handle (handle must be block or line buffered). - commitBuffer :: Handle -- handle to commit to -> RawCharBuffer -> Int -- address and size (in bytes) of buffer @@ -715,9 +712,10 @@ commitBuffer commitBuffer hdl !raw !sz !count flush release = wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release) + ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++ ", handle=" ++ show hdl) - writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, + -- Offset taken from handle + writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, bufOffset=0, bufL=0, bufR=count, bufSize=sz } when flush $ flushByteWriteBuffer h_ @@ -730,6 +728,8 @@ commitBuffer hdl !raw !sz !count flush release = spare_bufs <- readIORef haBuffers writeIORef haBuffers (BufferListCons raw spare_bufs) + -- bb <- readIORef haByteBuffer + -- debugIO ("commitBuffer: buffer=" ++ summaryBuffer bb ++ ", handle=" ++ show hdl) return () -- backwards compatibility; the text package uses this @@ -741,7 +741,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..} ++ ", flush=" ++ show flush ++ ", release=" ++ show release) let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer, - bufL=0, bufR=count, bufSize=sz } + bufL=0, bufR=count, bufSize=sz, bufOffset=0 } writeCharBuffer h_ this_buf @@ -816,63 +816,80 @@ hPutBuf' handle ptr count can_block _line_or_no_buffering -> do flushWriteBuffer h_ return r +-- TODO: Possible optimisation: +-- If we know that `w + count > size`, we should write both the +-- handle buffer and the `ptr` in a single `writev()` syscall. bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int -bufWrite h_@Handle__{..} ptr count can_block = - seq count $ do -- strictness hack - old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } - <- readIORef haByteBuffer +bufWrite h_@Handle__{..} ptr !count can_block = do + -- Get buffer to determine size and free space in buffer + old_buf@Buffer{ bufR=w, bufSize=size } + <- readIORef haByteBuffer - -- TODO: Possible optimisation: - -- If we know that `w + count > size`, we should write both the - -- handle buffer and the `ptr` in a single `writev()` syscall. - - -- Need to buffer and enough room in handle buffer? - -- There's no need to buffer if the data to be written is larger than + -- There's no need to buffer if the incoming data is larger than -- the handle buffer (`count >= size`). - if (count < size && count <= size - w) - -- We need to buffer and there's enough room in the buffer: - -- just copy the data in and update bufR. - then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w) - copyToRawBuffer old_raw w ptr count - let copied_buf = old_buf{ bufR = w + count } - -- If the write filled the buffer completely, we need to flush, - -- to maintain the "INVARIANTS on Buffers" from - -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full". - if (count == size - w) - then do - debugIO "hPutBuf: flushing full buffer after writing" - flushed_buf <- Buffered.flushWriteBuffer haDevice copied_buf - -- TODO: we should do a non-blocking flush here - writeIORef haByteBuffer flushed_buf - else do - writeIORef haByteBuffer copied_buf - return count - - -- else, we have to flush any existing handle buffer data - -- and can then write out the data in `ptr` directly. - else do -- No point flushing when there's nothing in the buffer. - when (w > 0) $ do - debugIO "hPutBuf: flushing first" - flushed_buf <- Buffered.flushWriteBuffer haDevice old_buf - -- TODO: we should do a non-blocking flush here - writeIORef haByteBuffer flushed_buf - -- if we can fit in the buffer, then just loop - if count < size - then bufWrite h_ ptr count can_block - else if can_block - then do writeChunk h_ (castPtr ptr) count - return count - else writeChunkNonBlocking h_ (castPtr ptr) count - -writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO () -writeChunk h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes - | otherwise = error "Todo: hPutBuf" - -writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int -writeChunkNonBlocking h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes - | otherwise = error "Todo: hPutBuf" + -- Check if we can try to buffer the given chunk of data. + b <- if (count < size && count <= size - w) + then bufferChunk h_ old_buf ptr count + else do + -- The given data does not fit into the buffer. + -- Either because it's too large for the buffer + -- or the buffer is too full. Either way we need + -- to flush the buffered data first. + flushed_buf <- flushByteWriteBufferGiven h_ old_buf + if count < size + -- The data is small enough to be buffered. + then bufferChunk h_ flushed_buf ptr count + else do + let offset = bufOffset flushed_buf + !bytes <- if can_block + then do writeChunk h_ (castPtr ptr) offset count + else writeChunkNonBlocking h_ (castPtr ptr) offset count + -- Update buffer with actual bytes written. + writeIORef haByteBuffer $! bufferAddOffset bytes flushed_buf + return bytes + debugIO "hPutBuf: done" + return b + +-- Flush the given buffer via the handle, return the flushed buffer +flushByteWriteBufferGiven :: Handle__ -> Buffer Word8 -> IO (Buffer Word8) +flushByteWriteBufferGiven h_@Handle__{..} bbuf = do + if (not (isEmptyBuffer bbuf)) + then do + bbuf' <- Buffered.flushWriteBuffer haDevice bbuf + debugIO ("flushByteWriteBufferGiven: bbuf=" ++ summaryBuffer bbuf') + writeIORef haByteBuffer bbuf' + return bbuf' + else + return bbuf + +-- Fill buffer and return bytes buffered/written. +-- Flushes buffer if it's full after adding the data. +bufferChunk :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> IO Int +bufferChunk h_@Handle__{..} old_buf@Buffer{ bufRaw=raw, bufR=w, bufSize=size } ptr !count = do + debugIO ("hPutBuf: copying to buffer, w=" ++ show w) + copyToRawBuffer raw w ptr count + let copied_buf = old_buf{ bufR = w + count } + -- If the write filled the buffer completely, we need to flush, + -- to maintain the "INVARIANTS on Buffers" from + -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full". + if isFullBuffer copied_buf + then do + -- TODO: we should do a non-blocking flush here + debugIO "hPutBuf: flushing full buffer after writing" + _ <- flushByteWriteBufferGiven h_ copied_buf + return () + else do + writeIORef haByteBuffer copied_buf + return count + +writeChunk :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int +writeChunk h_@Handle__{..} ptr offset bytes + = do RawIO.write haDevice ptr offset bytes + return bytes + +writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int +writeChunkNonBlocking h_@Handle__{..} ptr offset bytes + = RawIO.writeNonBlocking haDevice ptr offset bytes -- --------------------------------------------------------------------------- -- hGetBuf @@ -898,12 +915,16 @@ hGetBuf h !ptr count | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do - flushCharReadBuffer h_ - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + debugIO $ ":: hGetBuf - " ++ show h ++ " - " ++ show count + flushCharReadBuffer h_ + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer - if isEmptyBuffer buf - then bufReadEmpty h_ buf (castPtr ptr) 0 count - else bufReadNonEmpty h_ buf (castPtr ptr) 0 count + debugIO ("hGetBuf: " ++ summaryBuffer buf) + res <- if isEmptyBuffer buf + then bufReadEmpty h_ buf (castPtr ptr) 0 count + else bufReadNonEmpty h_ buf (castPtr ptr) 0 count + debugIO "** hGetBuf done." + return res -- small reads go through the buffer, large reads are satisfied by -- taking data first from the buffer and then direct from the file @@ -911,9 +932,14 @@ hGetBuf h !ptr count bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int bufReadNonEmpty h_@Handle__{..} + -- w for width, r for ... read ptr? buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } ptr !so_far !count = do + debugIO ":: bufReadNonEmpty" + -- We use < instead of <= because for count == avail + -- we need to reset bufL and bufR to zero. + -- See also: INVARIANTS on Buffers let avail = w - r if (count < avail) then do @@ -929,30 +955,47 @@ bufReadNonEmpty h_@Handle__{..} so_far' = so_far + avail ptr' = ptr `plusPtr` avail - if remaining == 0 + debugIO ("bufReadNonEmpty: " ++ summaryBuffer buf' ++ " s:" ++ show so_far' ++ " r:" ++ show remaining) + b <- if remaining == 0 then return so_far' else bufReadEmpty h_ buf' ptr' so_far' remaining + debugIO ":: bufReadNonEmpty - done" + return b - +-- We want to read more data, but the buffer is empty. (buffL == buffR == 0) +-- See also Note [INVARIANTS on Buffers] in Buffer.hs bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int bufReadEmpty h_@Handle__{..} - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz, bufOffset=bff } ptr so_far count - | count > sz, Just fd <- cast haDevice = loop fd 0 count + | count > sz + = do + bytes_read <- loop haDevice 0 bff count + -- bytes_read includes so_far (content that was in the buffer) + -- but that is already accounted for in the old offset, so don't + -- count it twice. + let buf1 = bufferAddOffset (fromIntegral $ bytes_read - so_far) buf + writeIORef haByteBuffer buf1 + debugIO ("bufReadEmpty1.1: " ++ summaryBuffer buf1 ++ " read:" ++ show bytes_read) + return bytes_read | otherwise = do - (r,buf') <- Buffered.fillReadBuffer haDevice buf - if r == 0 - then return so_far - else do writeIORef haByteBuffer buf' - bufReadNonEmpty h_ buf' ptr so_far count + (r,buf') <- Buffered.fillReadBuffer haDevice buf + writeIORef haByteBuffer buf' + if r == 0 -- end of file reached + then return so_far + else bufReadNonEmpty h_ buf' ptr so_far count where - loop :: FD -> Int -> Int -> IO Int - loop fd off bytes | bytes <= 0 = return (so_far + off) - loop fd off bytes = do - r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes + -- Read @bytes@ byte into ptr. Repeating the read until either zero + -- bytes where read, or we are done reading. + loop :: RawIO.RawIO dev => dev -> Int -> Word64 -> Int -> IO Int + loop dev delta off bytes | bytes <= 0 = return (so_far + delta) + loop dev delta off bytes = do + r <- RawIO.read dev (ptr `plusPtr` delta) off bytes + debugIO $ show ptr ++ " - loop read@" ++ show delta ++ ": " ++ show r + debugIO $ "next:" ++ show (delta + r) ++ " - left:" ++ show (bytes - r) if r == 0 - then return (so_far + off) - else loop fd (off + r) (bytes - r) + then return (so_far + delta) + else loop dev (delta + r) (off + fromIntegral r) (bytes - r) -- --------------------------------------------------------------------------- -- hGetBufSome @@ -984,7 +1027,7 @@ hGetBufSome h !ptr count buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer if isEmptyBuffer buf then case count > sz of -- large read? optimize it with a little special case: - True | Just fd <- haFD h_ -> do RawIO.read fd (castPtr ptr) count + True -> RawIO.read haDevice (castPtr ptr) 0 count _ -> do (r,buf') <- Buffered.fillReadBuffer haDevice buf if r == 0 then return 0 @@ -997,9 +1040,6 @@ hGetBufSome h !ptr count let count' = min count (bufferElems buf) in bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count' -haFD :: Handle__ -> Maybe FD -haFD h_@Handle__{..} = cast haDevice - -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ -- into the buffer @buf@ until either EOF is reached, or -- @count@ 8-bit bytes have been read, or there is no more data available @@ -1034,25 +1074,25 @@ hGetBufNonBlocking h !ptr count bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int bufReadNBEmpty h_@Handle__{..} - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz + , bufOffset=offset } ptr so_far count - | count > sz, - Just fd <- cast haDevice = do - m <- RawIO.readNonBlocking (fd::FD) ptr count + | count > sz = do + m <- RawIO.readNonBlocking haDevice ptr offset count case m of Nothing -> return so_far Just n -> return (so_far + n) | otherwise = do - buf <- readIORef haByteBuffer + -- buf <- readIORef haByteBuffer (r,buf') <- Buffered.fillReadBuffer0 haDevice buf case r of Nothing -> return so_far Just 0 -> return so_far - Just r -> do + Just r' -> do writeIORef haByteBuffer buf' - bufReadNBNonEmpty h_ buf' ptr so_far (min count r) - -- NOTE: new count is min count r + bufReadNBNonEmpty h_ buf' ptr so_far (min count r') + -- NOTE: new count is min count r' -- so we will just copy the contents of the -- buffer in the recursive call, and not -- loop again. @@ -1064,6 +1104,9 @@ bufReadNBNonEmpty h_@Handle__{..} ptr so_far count = do let avail = w - r + -- We use < instead of <= because for count == avail + -- we need to reset bufL and bufR to zero. + -- See also [INVARIANTS on Buffers] in Buffer.hs if (count < avail) then do copyFromRawBuffer ptr raw r count diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs index 6923d252b9..2ab91e9f09 100644 --- a/libraries/base/GHC/IO/Handle/Types.hs +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -26,6 +26,7 @@ module GHC.IO.Handle.Types ( BufferList(..), HandleType(..), isReadableHandleType, isWritableHandleType, isReadWriteHandleType, + isAppendHandleType, BufferMode(..), BufferCodec(..), NewlineMode(..), Newline(..), nativeNewline, @@ -119,13 +120,14 @@ instance Eq Handle where _ == _ = False data Handle__ - = forall dev enc_state dec_state . (IODevice dev, BufferedIO dev, Typeable dev) => + = forall dev enc_state dec_state . (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => Handle__ { haDevice :: !dev, haType :: HandleType, -- type (read/write/append etc.) haByteBuffer :: !(IORef (Buffer Word8)), -- See [note Buffering Implementation] haBufferMode :: BufferMode, haLastDecode :: !(IORef (dec_state, Buffer Word8)), + -- ^ The byte buffer just before we did our last batch of decoding. haCharBuffer :: !(IORef (Buffer CharBufElem)), -- See [note Buffering Implementation] haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers haEncoder :: Maybe (TextEncoder enc_state), @@ -170,6 +172,11 @@ isReadWriteHandleType :: HandleType -> Bool isReadWriteHandleType ReadWriteHandle{} = True isReadWriteHandleType _ = False +isAppendHandleType :: HandleType -> Bool +isAppendHandleType AppendHandle = True +isAppendHandleType _ = False + + -- INVARIANTS on Handles: -- -- * A handle *always* has a buffer, even if it is only 1 character long diff --git a/libraries/base/GHC/IO/Handle/Windows.hs b/libraries/base/GHC/IO/Handle/Windows.hs new file mode 100644 index 0000000000..19efbea3b5 --- /dev/null +++ b/libraries/base/GHC/IO/Handle/Windows.hs @@ -0,0 +1,235 @@ + {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.Windows +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Handle operations implemented by Windows native handles +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.Windows ( + stdin, stdout, stderr, + openFile, openBinaryFile, openFileBlocking, + handleToHANDLE, mkHandleFromHANDLE + ) where + +import Data.Maybe +import Data.Typeable + +import GHC.Base +import GHC.MVar +import GHC.IO +import GHC.IO.BufferedIO hiding (flushWriteBuffer) +import GHC.IO.Encoding +import GHC.IO.Device as IODevice +import GHC.IO.Exception +import GHC.IO.IOMode +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import qualified GHC.IO.Windows.Handle as Win + +-- --------------------------------------------------------------------------- +-- Standard Handles + +-- Three handles are allocated during program initialisation. The first +-- two manage input or output from the Haskell program's standard input +-- or output channel respectively. The third manages output to the +-- standard error channel. These handles are initially open. + +-- | If the std handles are redirected to file handles then WriteConsole etc +-- won't work anymore. When the handle is created test it and if it's a file +-- handle then just convert it to the proper IODevice so WriteFile is used +-- instead. This is done here so it's buffered and only happens once. +mkConsoleHandle :: Win.IoHandle Win.ConsoleHandle + -> FilePath + -> HandleType + -> Bool -- buffered? + -> Maybe TextEncoding + -> NewlineMode + -> Maybe HandleFinalizer + -> Maybe (MVar Handle__) + -> IO Handle +mkConsoleHandle dev filepath ha_type buffered mb_codec nl finalizer other_side + = do isTerm <- IODevice.isTerminal dev + 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 + mb_codec nl finalizer other_side + +-- | A handle managing input from the Haskell program's standard input channel. +stdin :: Handle +{-# NOINLINE stdin #-} +stdin = unsafePerformIO $ do + enc <- getLocaleEncoding + mkConsoleHandle Win.stdin "<stdin>" ReadHandle True (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard output channel. +stdout :: Handle +{-# NOINLINE stdout #-} +stdout = unsafePerformIO $ do + enc <- getLocaleEncoding + mkConsoleHandle Win.stdout "<stdout>" WriteHandle True (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard error channel. +stderr :: Handle +{-# NOINLINE stderr #-} +stderr = unsafePerformIO $ do + enc <- getLocaleEncoding + mkConsoleHandle Win.stderr "<stderr>" WriteHandle + False{-stderr is unbuffered-} (Just enc) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do + h_ <- takeMVar m + flushWriteBuffer h_ + case haType h_ of + ClosedHandle -> return () + _other -> closeTextCodecs h_ + putMVar m (ioe_finalizedHandle fp) + +-- --------------------------------------------------------------------------- +-- Opening and Closing Files + +addFilePathToIOError :: String -> FilePath -> IOException -> IOException +addFilePathToIOError fun fp ioe + = ioe{ ioe_location = fun, ioe_filename = Just fp } + +-- | Computation 'openFile' @file mode@ allocates and returns a new, open +-- handle to manage the file @file@. It manages input if @mode@ +-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', +-- and both input and output if mode is 'ReadWriteMode'. +-- +-- If the file does not exist and it is opened for output, it should be +-- created as a new file. If @mode@ is 'WriteMode' and the file +-- already exists, then it should be truncated to zero length. +-- Some operating systems delete empty files, so there is no guarantee +-- that the file will exist following an 'openFile' with @mode@ +-- 'WriteMode' unless it is subsequently written to successfully. +-- The handle is positioned at the end of the file if @mode@ is +-- 'AppendMode', and otherwise at the beginning (in which case its +-- internal position is 0). +-- The initial buffer mode is implementation-dependent. +-- +-- This operation may fail with: +-- +-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- +-- * 'isDoesNotExistError' if the file does not exist; or +-- +-- * 'isPermissionError' if the user does not have permission to open the file. +-- +-- Note: if you will be working with files containing binary data, you'll want to +-- be using 'openBinaryFile'. +openFile :: FilePath -> IOMode -> IO Handle +openFile fp im = + catchException + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) + +-- | Like 'openFile', but opens the file in ordinary blocking mode. +-- This can be useful for opening a FIFO for writing: if we open in +-- non-blocking mode then the open will fail if there are no readers, +-- whereas a blocking open will block until a reader appear. +-- +-- @since 4.4.0.0 +openFileBlocking :: FilePath -> IOMode -> IO Handle +openFileBlocking fp im = + catchException + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) + (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + +-- | Like 'openFile', but open the file in binary mode. +-- On Windows, reading a file in text mode (which is the default) +-- will translate CRLF to LF, and writing will translate LF to CRLF. +-- This is usually what you want with text files. With binary files +-- this is undesirable; also, as usual under Microsoft operating systems, +-- text mode treats control-Z as EOF. Binary mode turns off all special +-- treatment of end-of-line and end-of-file characters. +-- (See also 'hSetBinaryMode'.) + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile fp m = + catchException + (openFile' fp m True True) + (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + +openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle +openFile' filepath iomode binary non_blocking = do + -- first open the file to get a Win32 handle + (hwnd, hwnd_type) <- Win.openFile filepath iomode non_blocking + + mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding + + -- then use it to make a Handle + mkHandleFromHANDLE hwnd hwnd_type filepath iomode mb_codec + `onException` IODevice.close hwnd + -- NB. don't forget to close the Handle if mkHandleFromHANDLE fails, + -- otherwise this Handle leaks. + +-- --------------------------------------------------------------------------- +-- Converting Windows Handles from/to Handles + +mkHandleFromHANDLE + :: (RawIO dev, IODevice.IODevice dev, BufferedIO dev, Typeable dev) => dev + -> IODeviceType + -> FilePath -- a string describing this Windows handle (e.g. the filename) + -> IOMode + -> Maybe TextEncoding + -> IO Handle + +mkHandleFromHANDLE dev hw_type filepath iomode mb_codec + = do + let nl | isJust mb_codec = nativeNewlineMode + | otherwise = noNewlineTranslation + + case hw_type of + Directory -> + ioException (IOError Nothing InappropriateType "openFile" + "is a directory" Nothing Nothing) + + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteMode <- iomode -> + mkDuplexHandle dev filepath mb_codec nl + + + _other -> mkFileHandle dev filepath iomode mb_codec nl + +-- | Turn an existing Handle into a Win32 HANDLE. This function throws an +-- IOError if the Handle does not reference a HANDLE +handleToHANDLE :: Handle -> IO Win.HANDLE +handleToHANDLE h = case h of + FileHandle _ mv -> do + Handle__{haDevice = dev} <- readMVar mv + case (cast dev :: Maybe (Win.Io Win.NativeHandle)) of + Just hwnd -> return $ Win.toHANDLE hwnd + Nothing -> throwErr "not a file HANDLE" + DuplexHandle{} -> throwErr "not a file handle" + where + throwErr msg = ioException $ IOError (Just h) + InappropriateType "handleToHANDLE" msg Nothing Nothing + +-- --------------------------------------------------------------------------- +-- Are files opened by default in text or binary mode, if the user doesn't +-- specify? The thing is, to the Win32 APIs which are lowerlevel there exist no +-- such thing as binary/text mode. That's strictly a thing of the C library on +-- top of it. So I'm not sure what to do with this. -Tamar + +dEFAULT_OPEN_IN_BINARY_MODE :: Bool +dEFAULT_OPEN_IN_BINARY_MODE = False diff --git a/libraries/base/GHC/IO/StdHandles.hs b/libraries/base/GHC/IO/StdHandles.hs new file mode 100644 index 0000000000..7768c1535c --- /dev/null +++ b/libraries/base/GHC/IO/StdHandles.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.StdHandles +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This model abtracts away the platform specific handles that can be toggled +-- through the RTS. +-- +----------------------------------------------------------------------------- + +module GHC.IO.StdHandles + ( -- std handles + stdin, stdout, stderr, + openFile, openBinaryFile, openFileBlocking + ) where + +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Handle.Types + +import qualified GHC.IO.Handle.FD as POSIX +#if defined(mingw32_HOST_OS) +import GHC.IO.SubSystem +import qualified GHC.IO.Handle.Windows as Win + +stdin :: Handle +stdin = POSIX.stdin <!> Win.stdin + +stdout :: Handle +stdout = POSIX.stdout <!> Win.stdout + +stderr :: Handle +stderr = POSIX.stderr <!> Win.stderr + +openFile :: FilePath -> IOMode -> IO Handle +openFile = POSIX.openFile <!> Win.openFile + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile = POSIX.openBinaryFile <!> Win.openBinaryFile + +openFileBlocking :: FilePath -> IOMode -> IO Handle +openFileBlocking = POSIX.openFileBlocking <!> Win.openFileBlocking + +#else + +stdin :: Handle +stdin = POSIX.stdin + +stdout :: Handle +stdout = POSIX.stdout + +stderr :: Handle +stderr = POSIX.stderr + +openFile :: FilePath -> IOMode -> IO Handle +openFile = POSIX.openFile + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile = POSIX.openBinaryFile + +openFileBlocking :: FilePath -> IOMode -> IO Handle +openFileBlocking = POSIX.openFileBlocking + +#endif diff --git a/libraries/base/GHC/IO/StdHandles.hs-boot b/libraries/base/GHC/IO/StdHandles.hs-boot new file mode 100644 index 0000000000..4aae3ef7a3 --- /dev/null +++ b/libraries/base/GHC/IO/StdHandles.hs-boot @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.StdHandles [boot] +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module GHC.IO.StdHandles where + +import GHC.IO.Handle.Types + +-- used in GHC.Conc, which is below GHC.IO.Handle.FD +stdout :: Handle + diff --git a/libraries/base/GHC/IO/SubSystem.hs b/libraries/base/GHC/IO/SubSystem.hs new file mode 100644 index 0000000000..e26fd9f55a --- /dev/null +++ b/libraries/base/GHC/IO/SubSystem.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.SubSystem +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- The SubSystem control interface. These methods can be used to disambiguate +-- between the two operations. +-- +----------------------------------------------------------------------------- + +module GHC.IO.SubSystem ( + withIoSubSystem, + withIoSubSystem', + whenIoSubSystem, + ioSubSystem, + IoSubSystem(..), + conditional, + (<!>), + isWindowsNativeIO + ) where + +import GHC.Base +import GHC.RTS.Flags + +#if defined(mingw32_HOST_OS) +import GHC.IO.Unsafe +#endif + +infixl 7 <!> + +-- | Conditionally execute an action depending on the configured I/O subsystem. +-- On POSIX systems always execute the first action. +-- On windows execute the second action if WINIO as active, otherwise fall back to +-- the first action. +conditional :: a -> a -> a +#if defined(mingw32_HOST_OS) +conditional posix windows = + case ioSubSystem of + IoPOSIX -> posix + IoNative -> windows +#else +conditional posix _ = posix +#endif + +-- | Infix version of `conditional`. +-- posix <!> windows == conditional posix windows +(<!>) :: a -> a -> a +(<!>) = conditional + +isWindowsNativeIO :: Bool +isWindowsNativeIO = False <!> True + +ioSubSystem :: IoSubSystem +#if defined(mingw32_HOST_OS) +{-# NOINLINE ioSubSystem #-} +ioSubSystem = unsafeDupablePerformIO getIoManagerFlag +#else +ioSubSystem = IoPOSIX +#endif + +withIoSubSystem :: (IoSubSystem -> IO a) -> IO a +withIoSubSystem f = f ioSubSystem + +withIoSubSystem' :: (IoSubSystem -> a) -> a +withIoSubSystem' f = f ioSubSystem + +whenIoSubSystem :: IoSubSystem -> IO () -> IO () +whenIoSubSystem m f = do let sub = ioSubSystem + when (sub == m) f + diff --git a/libraries/base/GHC/IO/Windows/Encoding.hs b/libraries/base/GHC/IO/Windows/Encoding.hs new file mode 100644 index 0000000000..c0ee649662 --- /dev/null +++ b/libraries/base/GHC/IO/Windows/Encoding.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{- | + Module : System.Win32.Encoding + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Enocode/Decode mutibyte charactor using Win32 API. +-} + +module GHC.IO.Windows.Encoding + ( encodeMultiByte + , encodeMultiByteIO + , encodeMultiByteRawIO + , decodeMultiByte + , decodeMultiByteIO + , wideCharToMultiByte + , multiByteToWideChar + , withGhcInternalToUTF16 + , withUTF16ToGhcInternal + ) where + +import Data.Word (Word8, Word16) +import Foreign.C.Types (CInt(..)) +import Foreign.C.String (peekCAStringLen, peekCWStringLen, + withCWStringLen, withCAStringLen, ) +import Foreign.Ptr (nullPtr, Ptr ()) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Unsafe (unsafeLocalState) +import GHC.Windows +import GHC.IO.Encoding.CodePage (CodePage, getCurrentCodePage) +import GHC.IO +import GHC.Base +import GHC.Real + +#include "windows_cconv.h" + +-- | The "System.IO" output functions (e.g. `putStr`) don't +-- automatically convert to multibyte string on Windows, so this +-- function is provided to make the conversion from a Unicode string +-- in the given code page to a proper multibyte string. To get the +-- code page for the console, use `getCurrentCodePage`. +-- +encodeMultiByte :: CodePage -> String -> String +encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp + +{-# INLINE encodeMultiByteIO' #-} +-- | String must not be zero length. +encodeMultiByteIO' :: CodePage -> String -> ((LPCSTR, CInt) -> IO a) -> IO a +encodeMultiByteIO' cp wstr transformer = + withCWStringLen wstr $ \(cwstr,len) -> do + mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + nullPtr 0 + nullPtr nullPtr + -- mbchar' is the length of buffer required + allocaArray (fromIntegral mbchars') $ \mbstr -> do + mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + mbstr mbchars' + nullPtr nullPtr + transformer (mbstr,fromIntegral mbchars) + +-- converts [Char] to UTF-16 +encodeMultiByteIO :: CodePage -> String -> IO String +encodeMultiByteIO _ "" = return "" +encodeMultiByteIO cp s = encodeMultiByteIO' cp s toString + where toString (st,l) = peekCAStringLen (st,fromIntegral l) + +-- converts [Char] to UTF-16 +encodeMultiByteRawIO :: CodePage -> String -> IO (LPCSTR, CInt) +encodeMultiByteRawIO _ "" = return (nullPtr, 0) +encodeMultiByteRawIO cp s = encodeMultiByteIO' cp s toSizedCString + where toSizedCString (st,l) = return (st, fromIntegral l) + +foreign import WINDOWS_CCONV "WideCharToMultiByte" + wideCharToMultiByte + :: CodePage + -> DWORD -- dwFlags, + -> LPCWSTR -- lpWideCharStr + -> CInt -- cchWideChar + -> LPSTR -- lpMultiByteStr + -> CInt -- cbMultiByte + -> LPCSTR -- lpMultiByteStr + -> LPBOOL -- lpbFlags + -> IO CInt + +-- | The `System.IO` input functions (e.g. `getLine`) don't +-- automatically convert to Unicode, so this function is provided to +-- make the conversion from a multibyte string in the given code page +-- to a proper Unicode string. To get the code page for the console, +-- use `getConsoleCP`. +stringToUnicode :: CodePage -> String -> IO String +stringToUnicode _cp "" = return "" + -- MultiByteToWideChar doesn't handle empty strings (#1929) +stringToUnicode cp mbstr = + withCAStringLen mbstr $ \(cstr,len) -> do + wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar + cp + 0 + cstr + (fromIntegral len) + nullPtr 0 + -- wchars is the length of buffer required + allocaArray (fromIntegral wchars) $ \cwstr -> do + wchars' <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar + cp + 0 + cstr + (fromIntegral len) + cwstr wchars + peekCWStringLen (cwstr,fromIntegral wchars') -- converts UTF-16 to [Char] + +foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar" + multiByteToWideChar + :: CodePage + -> DWORD -- dwFlags, + -> LPCSTR -- lpMultiByteStr + -> CInt -- cbMultiByte + -> LPWSTR -- lpWideCharStr + -> CInt -- cchWideChar + -> IO CInt + +decodeMultiByte :: CodePage -> String -> String +decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp + +-- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO` +-- for alias of `stringToUnicode`. +decodeMultiByteIO :: CodePage -> String -> IO String +decodeMultiByteIO = stringToUnicode +{-# INLINE decodeMultiByteIO #-} + +foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar" + multiByteToWideChar' + :: CodePage + -> DWORD -- dwFlags, + -> Ptr Word8 -- lpMultiByteStr + -> CInt -- cbMultiByte + -> Ptr Word16 -- lpWideCharStr + -> CInt -- cchWideChar + -> IO CInt + +-- TODO: GHC is internally UTF-32 which means we have re-encode for +-- Windows which is annoying. Switch to UTF-16 on IoNative +-- being default. +withGhcInternalToUTF16 :: Ptr Word8 -> Int -> ((Ptr Word16, CInt) -> IO a) + -> IO a +withGhcInternalToUTF16 ptr len fn + = do cp <- getCurrentCodePage + wchars <- failIfZero "withGhcInternalToUTF16" $ + multiByteToWideChar' cp 0 ptr (fromIntegral len) nullPtr 0 + -- wchars is the length of buffer required + allocaArray (fromIntegral wchars) $ \cwstr -> do + wchars' <- failIfZero "withGhcInternalToUTF16" $ + multiByteToWideChar' cp 0 ptr (fromIntegral len) cwstr wchars + fn (cwstr, wchars') + +foreign import WINDOWS_CCONV "WideCharToMultiByte" + wideCharToMultiByte' + :: CodePage + -> DWORD -- dwFlags, + -> Ptr Word16 -- lpWideCharStr + -> CInt -- cchWideChar + -> Ptr Word8 -- lpMultiByteStr + -> CInt -- cbMultiByte + -> LPCSTR -- lpMultiByteStr + -> LPBOOL -- lpbFlags + -> IO CInt + +-- TODO: GHC is internally UTF-32 which means we have re-encode for +-- Windows which is annoying. Switch to UTF-16 on IoNative +-- being default. + +-- | Decode a UTF16 buffer into the given buffer in the current code page. +-- The source UTF16 buffer is filled by the function given as argument. +withUTF16ToGhcInternal :: Ptr Word8 -- Buffer to store the encoded string in. + -> Int -- Length of the buffer + -- Function to fill source buffer. + -> ( CInt -- Size of available buffer in bytes + -> Ptr Word16 -- Temporary source buffer. + -> IO CInt -- Actual length of buffer content. + ) + -> IO Int -- Returns number of bytes stored in buffer. +withUTF16ToGhcInternal ptr len fn + = do cp <- getCurrentCodePage + -- Annoyingly the IO system is very UTF-32 oriented and asks for bytes + -- as buffer reads. Problem is we don't know how many bytes we'll end up + -- having as UTF-32 MultiByte encoded UTF-16. So be conservative. We assume + -- that a single byte may expand to atmost 1 Word16. So assume that each + -- byte does and divide the requested number of bytes by two since each + -- Word16 encoded wchar may expand to only two Word8 sequences. + let reqBytes = fromIntegral (len `div` 2) + allocaArray reqBytes $ \w_ptr -> do + w_len <- fn (fromIntegral reqBytes) w_ptr + if w_len == 0 + then return 0 else do + -- Get required length of encoding + mbchars' <- failIfZero "withUTF16ToGhcInternal" $ + wideCharToMultiByte' cp 0 w_ptr + (fromIntegral w_len) nullPtr + 0 nullPtr nullPtr + assert (mbchars' <= (fromIntegral len)) $ do + -- mbchar' is the length of buffer required + mbchars <- failIfZero "withUTF16ToGhcInternal" $ + wideCharToMultiByte' cp 0 w_ptr + (fromIntegral w_len) ptr + mbchars' nullPtr nullPtr + return $ fromIntegral mbchars diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc new file mode 100644 index 0000000000..7b39691181 --- /dev/null +++ b/libraries/base/GHC/IO/Windows/Handle.hsc @@ -0,0 +1,966 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +-- Whether there are identities depends on the platform +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Windows.Handle +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Raw read/write operations on Windows Handles +-- +----------------------------------------------------------------------------- + +module GHC.IO.Windows.Handle + ( -- * Basic Types + NativeHandle(), + ConsoleHandle(), + IoHandle(), + HANDLE, + Io(), + + -- * Utility functions + convertHandle, + toHANDLE, + fromHANDLE, + handleToMode, + optimizeFileAccess, + + -- * Standard Handles + stdin, + stdout, + stderr, + + -- * File utilities + openFile, + openFileAsTemp, + release + ) where + +#include <windows.h> +#include <ntstatus.h> +#include <winnt.h> +##include "windows_cconv.h" + +-- Can't avoid these semantics leaks, they are base constructs +import Data.Bits ((.|.), (.&.), shiftL) +import Data.Functor ((<$>)) +import Data.Typeable + +import GHC.Base +import GHC.Enum +import GHC.Num +import GHC.Real +import GHC.List +import GHC.Word (Word8, Word16, Word64) + +import GHC.IO hiding (mask) +import GHC.IO.Buffer +import GHC.IO.BufferedIO +import qualified GHC.IO.Device +import GHC.IO.Device (SeekMode(..), IODeviceType(..), IODevice(), devType, setSize) +import GHC.IO.Exception +import GHC.IO.IOMode +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 Foreign.Ptr +import Foreign.C +import Foreign.Marshal.Array (pokeArray) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Utils (with, fromBool) +import Foreign.Storable (Storable (..)) +import qualified GHC.Event.Windows as Mgr + +import GHC.Windows (LPVOID, LPDWORD, DWORD, HANDLE, BOOL, LPCTSTR, ULONG, WORD, + UCHAR, failIf, iNVALID_HANDLE_VALUE, failWith, + failIfFalse_, getLastError) +import Text.Show + +-- ----------------------------------------------------------------------------- +-- The Windows IO device handles + +data NativeHandle +data ConsoleHandle + +-- | Bit of a Hack, but we don't want every handle to have a cooked entry +-- but all copies of the handles for which we do want one need to share +-- the same value. +-- 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 + ConsoleHandle :: { getConsoleHandle :: HANDLE + , cookedHandle :: IORef Bool + } -> IoHandle ConsoleHandle + +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 + +-- | @since 4.11.0.0 +instance Show (Io NativeHandle) where + show = show . toHANDLE + +-- | @since 4.11.0.0 +instance Show (Io ConsoleHandle) where + show = show . getConsoleHandle + +-- | @since 4.11.0.0 +instance GHC.IO.Device.RawIO (Io NativeHandle) where + read = hwndRead + readNonBlocking = hwndReadNonBlocking + write = hwndWrite + writeNonBlocking = hwndWriteNonBlocking + +-- | @since 4.11.0.0 +instance GHC.IO.Device.RawIO (Io ConsoleHandle) where + read = consoleRead + readNonBlocking = consoleReadNonBlocking + write = consoleWrite + writeNonBlocking = consoleWriteNonBlocking + +-- | Generalize a way to get and create handles. +class (GHC.IO.Device.RawIO a, IODevice a, BufferedIO a, Typeable a) + => RawHandle a where + toHANDLE :: a -> HANDLE + fromHANDLE :: HANDLE -> a + isLockable :: a -> Bool + setCooked :: a -> Bool -> IO a + isCooked :: a -> IO Bool + +instance RawHandle (Io NativeHandle) where + toHANDLE = getNativeHandle + fromHANDLE = NativeHandle + isLockable _ = True + setCooked = const . return + isCooked _ = return False + +instance RawHandle (Io ConsoleHandle) where + toHANDLE = getConsoleHandle + fromHANDLE h = unsafePerformIO $ ConsoleHandle h <$> newIORef False + isLockable _ = False + setCooked h val = + do writeIORef (cookedHandle h) val + return h + isCooked h = readIORef (cookedHandle h) + +-- ----------------------------------------------------------------------------- +-- The Windows IO device implementation + +-- | @since 4.11.0.0 +instance GHC.IO.Device.IODevice (Io NativeHandle) where + ready = handle_ready + close = handle_close + isTerminal = handle_is_console + isSeekable = handle_is_seekable + seek = handle_seek + tell = handle_tell + getSize = handle_get_size + setSize = handle_set_size + setEcho = handle_set_echo + getEcho = handle_get_echo + setRaw = handle_set_buffering + devType = handle_dev_type + dup = handle_duplicate + +-- | @since 4.11.0.0 +instance GHC.IO.Device.IODevice (Io ConsoleHandle) where + ready = handle_ready + close = handle_close . convertHandle + isTerminal = handle_is_console + isSeekable = handle_is_seekable + seek = handle_console_seek + tell = handle_console_tell + getSize = handle_get_console_size + setSize = handle_set_console_size + setEcho = handle_set_echo + getEcho = handle_get_echo + setRaw = console_set_buffering + devType = handle_dev_type + dup = handle_duplicate + +-- Default sequential read buffer size. +-- for Windows 8k seems to be the optimal +-- buffer size. +dEFAULT_BUFFER_SIZE :: Int +dEFAULT_BUFFER_SIZE = 8192 + +-- | @since 4.11.0.0 +-- See libraries/base/GHC/IO/BufferedIO.hs +instance BufferedIO (Io NativeHandle) where + newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state + fillReadBuffer = readBuf' + fillReadBuffer0 = readBufNonBlocking + flushWriteBuffer = writeBuf' + flushWriteBuffer0 = writeBufNonBlocking + +-- | @since 4.11.0.0 +-- See libraries/base/GHC/IO/BufferedIO.hs +instance BufferedIO (Io ConsoleHandle) where + newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state + fillReadBuffer = readBuf' + fillReadBuffer0 = readBufNonBlocking + flushWriteBuffer = writeBuf' + flushWriteBuffer0 = writeBufNonBlocking + + +readBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Int, Buffer Word8) +readBuf' hnd buf = do + debugIO ("readBuf handle=" ++ show (toHANDLE hnd) ++ " " ++ + summaryBuffer buf ++ "\n") + (r,buf') <- readBuf hnd buf + debugIO ("after: " ++ summaryBuffer buf' ++ "\n") + return (r,buf') + +writeBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Buffer Word8) +writeBuf' hnd buf = do + debugIO ("writeBuf handle=" ++ show (toHANDLE hnd) ++ " " ++ + summaryBuffer buf ++ "\n") + writeBuf hnd buf + +-- ----------------------------------------------------------------------------- +-- Standard I/O handles + +type StdHandleId = DWORD + +#{enum StdHandleId, + , sTD_INPUT_HANDLE = STD_INPUT_HANDLE + , sTD_OUTPUT_HANDLE = STD_OUTPUT_HANDLE + , sTD_ERROR_HANDLE = STD_ERROR_HANDLE +} + +getStdHandle :: StdHandleId -> IO HANDLE +getStdHandle hid = + failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid + +stdin, stdout, stderr :: Io ConsoleHandle +stdin = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_INPUT_HANDLE +stdout = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_OUTPUT_HANDLE +stderr = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_ERROR_HANDLE + +mkConsoleHandle :: HANDLE -> IO (Io ConsoleHandle) +mkConsoleHandle hwnd + = do ref <- newIORef False + return $ ConsoleHandle hwnd ref + +-- ----------------------------------------------------------------------------- +-- Some console internal types to detect EOF. + +-- ASCII Ctrl+D (EOT) character. Typically used by Unix consoles. +-- use for cross platform compatibility and to adhere to the ASCII standard. +acCtrlD :: Int +acCtrlD = 0x04 +-- ASCII Ctrl+Z (SUB) character. Typically used by Windows consoles to denote +-- EOT. Use for compatibility with user expectations. +acCtrlZ :: Int +acCtrlZ = 0x1A + +-- Mask to use to trigger ReadConsole input processing end. +acEotMask :: ULONG +acEotMask = (1 `shiftL` acCtrlD) .|. (1 `shiftL` acCtrlZ) + +-- Structure to hold the control character masks +type PCONSOLE_READCONSOLE_CONTROL = Ptr CONSOLE_READCONSOLE_CONTROL +data CONSOLE_READCONSOLE_CONTROL = CONSOLE_READCONSOLE_CONTROL + { crcNLength :: ULONG + , crcNInitialChars :: ULONG + , crcDwCtrlWakeupMask :: ULONG + , crcDwControlKeyState :: ULONG + } deriving Show + +instance Storable CONSOLE_READCONSOLE_CONTROL where + sizeOf = const #size CONSOLE_READCONSOLE_CONTROL + alignment = const #alignment CONSOLE_READCONSOLE_CONTROL + poke buf crc = do + (#poke CONSOLE_READCONSOLE_CONTROL, nLength) buf + (crcNLength crc) + (#poke CONSOLE_READCONSOLE_CONTROL, nInitialChars) buf + (crcNInitialChars crc) + (#poke CONSOLE_READCONSOLE_CONTROL, dwCtrlWakeupMask) buf + (crcDwCtrlWakeupMask crc) + (#poke CONSOLE_READCONSOLE_CONTROL, dwControlKeyState) buf + (crcDwControlKeyState crc) + + peek buf = do + vNLength <- + (#peek CONSOLE_READCONSOLE_CONTROL, nLength) buf + vNInitialChars <- + (#peek CONSOLE_READCONSOLE_CONTROL, nInitialChars) buf + vDwCtrlWakeupMask <- + (#peek CONSOLE_READCONSOLE_CONTROL, dwCtrlWakeupMask) buf + vDwControlKeyState <- + (#peek CONSOLE_READCONSOLE_CONTROL, dwControlKeyState) buf + return $ CONSOLE_READCONSOLE_CONTROL { + crcNLength = vNLength, + crcNInitialChars = vNInitialChars, + crcDwCtrlWakeupMask = vDwCtrlWakeupMask, + crcDwControlKeyState = vDwControlKeyState + } + +-- Create CONSOLE_READCONSOLE_CONTROL for breaking on control characters +-- specified by acEotMask +eotControl :: CONSOLE_READCONSOLE_CONTROL +eotControl = + CONSOLE_READCONSOLE_CONTROL + { crcNLength = fromIntegral $ + sizeOf (undefined :: CONSOLE_READCONSOLE_CONTROL) + , crcNInitialChars = 0 + , crcDwCtrlWakeupMask = acEotMask + , crcDwControlKeyState = 0 + } + +type PINPUT_RECORD = Ptr () +-- ----------------------------------------------------------------------------- +-- Foreign imports + + +foreign import WINDOWS_CCONV safe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> DWORD -> DWORD -> LPSECURITY_ATTRIBUTES + -> DWORD -> DWORD -> HANDLE + -> IO HANDLE + +foreign import WINDOWS_CCONV safe "windows.h SetFileCompletionNotificationModes" + c_SetFileCompletionNotificationModes :: HANDLE -> UCHAR -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h ReadFile" + c_ReadFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED + -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h WriteFile" + c_WriteFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED + -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h GetStdHandle" + c_GetStdHandle :: StdHandleId -> IO HANDLE + +foreign import ccall safe "__handle_ready" + c_handle_ready :: HANDLE -> BOOL -> CInt -> IO CInt + +foreign import ccall safe "__is_console" + c_is_console :: HANDLE -> IO BOOL + +foreign import ccall safe "__set_console_buffering" + c_set_console_buffering :: HANDLE -> BOOL -> IO BOOL + +foreign import ccall safe "__set_console_echo" + c_set_console_echo :: HANDLE -> BOOL -> IO BOOL + +foreign import ccall safe "__get_console_echo" + c_get_console_echo :: HANDLE -> IO BOOL + +foreign import ccall safe "__close_handle" + c_close_handle :: HANDLE -> IO Bool + +foreign import ccall safe "__handle_type" + c_handle_type :: HANDLE -> IO Int + +foreign import ccall safe "__set_file_pointer" + c_set_file_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL + +foreign import ccall safe "__get_file_pointer" + c_get_file_pointer :: HANDLE -> IO CLong + +foreign import ccall safe "__get_file_size" + c_get_file_size :: HANDLE -> IO CLong + +foreign import ccall safe "__set_file_size" + c_set_file_size :: HANDLE -> CLong -> IO BOOL + +foreign import ccall safe "__duplicate_handle" + c_duplicate_handle :: HANDLE -> Ptr HANDLE -> IO BOOL + +foreign import ccall safe "__set_console_pointer" + c_set_console_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL + +foreign import ccall safe "__get_console_pointer" + c_get_console_pointer :: HANDLE -> IO CLong + +foreign import ccall safe "__get_console_buffer_size" + c_get_console_buffer_size :: HANDLE -> IO CLong + +foreign import ccall safe "__set_console_buffer_size" + c_set_console_buffer_size :: HANDLE -> CLong -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h ReadConsoleW" + c_read_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD + -> PCONSOLE_READCONSOLE_CONTROL -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h WriteConsoleW" + c_write_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD -> Ptr () + -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h ReadConsoleInputW" + c_read_console_input :: HANDLE -> PINPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL + +type LPSECURITY_ATTRIBUTES = LPVOID + +-- ----------------------------------------------------------------------------- +-- Reading and Writing + +-- For this to actually block, the file handle must have +-- been created with FILE_FLAG_OVERLAPPED not set. As an implementation note I +-- 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 + where + startCB outBuf lpOverlapped = do + debugIO ":: hwndRead" + -- See Note [ReadFile/WriteFile]. + ret <- c_ReadFile (toHANDLE hwnd) (castPtr outBuf) + (fromIntegral bytes) nullPtr lpOverlapped + return $ Mgr.CbNone ret + + completionCB err dwBytes + | 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_NO_MORE_ITEMS} = Mgr.ioSuccess 0 + | err == #{const ERROR_MORE_DATA} = Mgr.ioSuccess $ fromIntegral dwBytes + | otherwise = Mgr.ioFailed err + +-- In WinIO we'll never block in the FFI call, so this call is equivalent to +-- hwndRead, Though we may revisit this when implementing sockets and pipes. +-- It still won't block, but may set up extra book keeping so threadWait and +-- threadWrite may work. +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 + return $ ioValue val + where + startCB inputBuf lpOverlapped = do + debugIO ":: hwndReadNonBlocking" + -- See Note [ReadFile/WriteFile]. + ret <- c_ReadFile (toHANDLE hwnd) (castPtr inputBuf) + (fromIntegral bytes) nullPtr lpOverlapped + return $ Mgr.CbNone ret + + completionCB err dwBytes + | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess $ Just $! fromIntegral dwBytes + | err == #{const ERROR_HANDLE_EOF} = Mgr.ioSuccess Nothing + | err == #{const STATUS_END_OF_FILE} = Mgr.ioSuccess Nothing + | err == #{const ERROR_BROKEN_PIPE} = Mgr.ioSuccess Nothing + | err == #{const STATUS_PIPE_BROKEN} = Mgr.ioSuccess Nothing + | err == #{const ERROR_NO_MORE_ITEMS} = Mgr.ioSuccess Nothing + | err == #{const ERROR_MORE_DATA} = Mgr.ioSuccess $ Just $! fromIntegral dwBytes + | otherwise = Mgr.ioFailedAny err + +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 + return () + where + startCB outBuf lpOverlapped = do + debugIO ":: hwndWrite" + -- See Note [ReadFile/WriteFile]. + ret <- c_WriteFile (toHANDLE hwnd) (castPtr outBuf) + (fromIntegral bytes) nullPtr lpOverlapped + return $ Mgr.CbNone ret + + completionCB err dwBytes + | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess $ fromIntegral dwBytes + | err == #{const ERROR_HANDLE_EOF} = Mgr.ioSuccess $ fromIntegral dwBytes + | otherwise = Mgr.ioFailed err + +hwndWriteNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int +hwndWriteNonBlocking hwnd ptr offset bytes + = do val <- withOverlapped "hwndReadNonBlocking" (toHANDLE hwnd) offset + (startCB ptr) completionCB + return $ fromIntegral $ ioValue val + where + startCB :: Ptr a -> LPOVERLAPPED -> IO (Mgr.CbResult a1) + startCB outBuf lpOverlapped = do + debugIO ":: hwndWriteNonBlocking" + -- See Note [ReadFile/WriteFile]. + ret <- c_WriteFile (toHANDLE hwnd) (castPtr outBuf) + (fromIntegral bytes) nullPtr lpOverlapped + return $ Mgr.CbNone ret + + completionCB err dwBytes + | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess $ fromIntegral dwBytes + | err == #{const ERROR_HANDLE_EOF} = Mgr.ioSuccess $ fromIntegral dwBytes + | otherwise = Mgr.ioFailed err + +-- Note [ReadFile/WriteFile] +-- The results of these functions are somewhat different when working in an +-- asynchronous manner. The returning bool has two meaning. +-- +-- True: The operation is done and was completed synchronously. This is +-- possible because of the optimization flags we enable. In this case +-- there won't be a completion event for this call and so we shouldn't +-- queue one up. If we do this request will never terminate. It's also +-- safe to free the OVERLAPPED structure immediately. +-- +-- False: Only indicates that the operation was not completed synchronously, a +-- call to GetLastError () is needed to find out the actual status. If +-- the result is ERROR_IO_PENDING then the operation has been queued on +-- the completion port and we should proceed asynchronously. Any other +-- state is usually an indication that the call failed. +-- +-- NB. reading an EOF will result in ERROR_HANDLE_EOF or STATUS_END_OF_FILE +-- during the checking of the completion results. We need to check for these +-- so we don't incorrectly fail. + + +consoleWrite :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO () +consoleWrite hwnd ptr _offset bytes + = alloca $ \res -> + do failIfFalse_ "GHC.IO.Handle.consoleWrite" $ do + debugIO ":: consoleWrite" + withGhcInternalToUTF16 ptr bytes $ \(w_ptr, w_len) -> do + success <- c_write_console (toHANDLE hwnd) w_ptr + (fromIntegral w_len) res nullPtr + if not success + then return False + else do val <- fromIntegral <$> peek res + return $ val == w_len + +consoleWriteNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int +consoleWriteNonBlocking hwnd ptr _offset bytes + = alloca $ \res -> + do failIfFalse_ "GHC.IO.Handle.consoleWriteNonBlocking" $ do + debugIO ":: consoleWriteNonBlocking" + withGhcInternalToUTF16 ptr bytes $ \(w_ptr, w_len) -> do + c_write_console (toHANDLE hwnd) w_ptr (fromIntegral w_len) + res nullPtr + val <- fromIntegral <$> peek res + return val + +consoleRead :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int +consoleRead hwnd ptr _offset bytes + = withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr -> + alloca $ \res -> do + cooked <- isCooked hwnd + -- Cooked input must be handled differently when the STD handles are + -- attached to a real console handle. For File based handles we can't do + -- proper cooked inputs, but since the actions are async you would get + -- results as soon as available. + -- + -- For console handles We have to use a lower level API then ReadConsole, + -- namely we must use ReadConsoleInput which requires us to process + -- all console message manually. + -- + -- Do note that MSYS2 shells such as bash don't attach to a real handle, + -- and instead have by default a pipe/file based std handles. Which + -- means the cooked behaviour is best when used in a native Windows + -- terminal such as cmd, powershell or ConEmu. + case cooked of + False -> do + debugIO "consoleRead :: un-cooked I/O read." + -- eotControl allows us to handle control characters like EOL + -- without needing a newline, which would sort of defeat the point + -- of an EOL. + res_code <- with eotControl $ \p_eotControl -> + c_read_console (toHANDLE hwnd) w_ptr (fromIntegral reqBytes) res + p_eotControl + + -- Restore a quirk of the POSIX read call, which only returns a fail + -- when the handle is invalid, e.g. closed or not a handle. It how- + -- ever returns 0 when the handle is valid but unreadable, such as + -- passing a handle with no GENERIC_READ permission, like /dev/null + err <- getLastError + when (not res_code) $ + case () of + _ | err == #{const ERROR_INVALID_FUNCTION} -> return () + | otherwise -> failWith "GHC.IO.Handle.consoleRead" err + b_read <- fromIntegral <$> peek res + if b_read /= 1 + then return b_read + else do w_first <- peekElemOff w_ptr 0 + case () of + -- Handle Ctrl+Z which is the actual EOL sequence on + -- 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 + | otherwise -> return b_read + True -> do + debugIO "consoleRead :: cooked I/O read." + -- Input is cooked, don't wait till a line return and consume all + -- characters as they are. Technically this function can handle any + -- console event. Including mouse, window and virtual key events + -- but for now I'm only interested in key presses. + let entries = fromIntegral $ reqBytes `div` (#size INPUT_RECORD) + allocaBytes entries $ \p_inputs -> + readEvent p_inputs entries res w_ptr + + where readEvent p_inputs entries res w_ptr = do + failIfFalse_ "GHC.IO.Handle.consoleRead" $ + c_read_console_input (toHANDLE hwnd) p_inputs + (fromIntegral entries) res + + b_read <- fromIntegral <$> peek res + read <- cobble b_read w_ptr p_inputs + if read > 0 + then return $ fromIntegral read + else readEvent p_inputs entries res w_ptr + + -- Dereference and read console input records. We only read the bare + -- minimum required to know which key/sequences were pressed. To do + -- this and prevent having to fully port the PINPUT_RECORD structure + -- in Haskell we use some GCC builtins to find the correct offsets. + cobble :: Int -> Ptr Word16 -> PINPUT_RECORD -> IO Int + cobble 0 _ _ = do debugIO "cobble: done." + return 0 + cobble n w_ptr p_inputs = + do eventType <- peekByteOff p_inputs 0 :: IO WORD + debugIO $ "cobble: Length=" ++ show n + debugIO $ "cobble: Type=" ++ show eventType + let ni_offset = #size INPUT_RECORD + let event = #{const __builtin_offsetof (INPUT_RECORD, Event)} + let char_offset = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, uChar)} + let btnDown_offset = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, bKeyDown)} + let repeat_offset = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, wRepeatCount)} + let n' = n - 1 + let p_inputs' = p_inputs `plusPtr` ni_offset + btnDown <- peekByteOff p_inputs btnDown_offset + repeated <- fromIntegral <$> (peekByteOff p_inputs repeat_offset :: IO WORD) + debugIO $ "cobble: BtnDown=" ++ show btnDown + -- Handle the key only on button down and not on button up. + if eventType == #{const KEY_EVENT} && btnDown + then do debugIO $ "cobble: read-char." + char <- peekByteOff p_inputs char_offset + let w_ptr' = w_ptr `plusPtr` 1 + debugIO $ "cobble: offset - " ++ show char_offset + debugIO $ "cobble: show > " ++ show char + debugIO $ "cobble: repeat: " ++ show repeated + pokeArray w_ptr $ replicate repeated char + (+1) <$> cobble n' w_ptr' p_inputs' + else do debugIO $ "cobble: skip event." + cobble n' w_ptr p_inputs' + + +consoleReadNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int + -> IO (Maybe Int) +consoleReadNonBlocking hwnd ptr offset bytes + = Just <$> consoleRead hwnd ptr offset bytes + +-- ----------------------------------------------------------------------------- +-- Operations on file handles + +handle_ready :: RawHandle a => a -> Bool -> Int -> IO Bool +handle_ready hwnd write msecs = do + r <- throwErrnoIfMinus1Retry "GHC.IO.Windows.Handle.handle_ready" $ + c_handle_ready (toHANDLE hwnd) write (fromIntegral msecs) + return (toEnum (fromIntegral r)) + +handle_is_console :: RawHandle a => a -> IO Bool +handle_is_console = c_is_console . toHANDLE + +handle_close :: RawHandle a => a -> IO () +handle_close h = do release h + failIfFalse_ "handle_close" $ c_close_handle (toHANDLE h) + +handle_dev_type :: RawHandle a => a -> IO IODeviceType +handle_dev_type hwnd = do _type <- c_handle_type $ toHANDLE hwnd + return $ case _type of + _ | _type == 3 -> Stream + | _type == 5 -> RawDevice + | otherwise -> RegularFile + +handle_is_seekable :: RawHandle a => a -> IO Bool +handle_is_seekable hwnd = do + t <- handle_dev_type hwnd + return (t == RegularFile || t == RawDevice) + +handle_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer +handle_seek hwnd mode off = + with 0 $ \off_rel -> do + failIfFalse_ "GHC.IO.Handle.handle_seek" $ + c_set_file_pointer (toHANDLE hwnd) (fromIntegral off) seektype off_rel + fromIntegral <$> peek off_rel + where + seektype :: DWORD + seektype = case mode of + AbsoluteSeek -> #{const FILE_BEGIN} + RelativeSeek -> #{const FILE_CURRENT} + SeekFromEnd -> #{const FILE_END} + +handle_tell :: RawHandle a => a -> IO Integer +handle_tell hwnd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_tell" $ + c_get_file_pointer (toHANDLE hwnd)) + +handle_set_size :: RawHandle a => a -> Integer -> IO () +handle_set_size hwnd size = + failIfFalse_ "GHC.IO.Handle.handle_set_size" $ + c_set_file_size (toHANDLE hwnd) (fromIntegral size) + +handle_get_size :: RawHandle a => a -> IO Integer +handle_get_size hwnd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_set_size" $ + c_get_file_size (toHANDLE hwnd)) + +handle_set_echo :: RawHandle a => a -> Bool -> IO () +handle_set_echo hwnd value = + failIfFalse_ "GHC.IO.Handle.handle_set_echo" $ + c_set_console_echo (toHANDLE hwnd) value + +handle_get_echo :: RawHandle a => a -> IO Bool +handle_get_echo = c_get_console_echo . toHANDLE + +handle_duplicate :: RawHandle a => a -> IO a +handle_duplicate hwnd = alloca $ \ptr -> do + failIfFalse_ "GHC.IO.Handle.handle_duplicate" $ + c_duplicate_handle (toHANDLE hwnd) ptr + fromHANDLE <$> peek ptr + +console_set_buffering :: Io ConsoleHandle -> Bool -> IO () +console_set_buffering hwnd value = setCooked hwnd value >> return () + +handle_set_buffering :: RawHandle a => a -> Bool -> IO () +handle_set_buffering hwnd value = + failIfFalse_ "GHC.IO.Handle.handle_set_buffering" $ + c_set_console_buffering (toHANDLE hwnd) value + +handle_console_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer +handle_console_seek hwnd mode off = + with 0 $ \loc_ptr -> do + failIfFalse_ "GHC.IO.Handle.handle_console_seek" $ + c_set_console_pointer (toHANDLE hwnd) (fromIntegral off) seektype loc_ptr + fromIntegral <$> peek loc_ptr + where + seektype :: DWORD + seektype = case mode of + AbsoluteSeek -> #{const FILE_BEGIN} + RelativeSeek -> #{const FILE_CURRENT} + SeekFromEnd -> #{const FILE_END} + +handle_console_tell :: RawHandle a => a -> IO Integer +handle_console_tell hwnd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_console_tell" $ + c_get_console_pointer (toHANDLE hwnd)) + +handle_set_console_size :: RawHandle a => a -> Integer -> IO () +handle_set_console_size hwnd size = + failIfFalse_ "GHC.IO.Handle.handle_set_console_size" $ + c_set_console_buffer_size (toHANDLE hwnd) (fromIntegral size) + +handle_get_console_size :: RawHandle a => a -> IO Integer +handle_get_console_size hwnd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_get_console_size" $ + c_get_console_buffer_size (toHANDLE hwnd)) + +-- ----------------------------------------------------------------------------- +-- opening files + +-- | Describes if and which temp file flags to use. +data TempFileOptions = NoTemp | TempNonExcl | TempExcl deriving Eq + +-- | Open a file and make an 'NativeHandle' for it. Truncates the file to zero +-- size when the `IOMode` is `WriteMode`. +openFile + :: FilePath -- ^ file to open + -> IOMode -- ^ mode in which to open the file + -> Bool -- ^ open the file in non-blocking mode? + -> IO (Io NativeHandle, IODeviceType) +openFile filepath iomode non_blocking = openFile' filepath iomode non_blocking NoTemp + +-- | Open a file as a temporary file and make an 'NativeHandle' for it. +-- Truncates the file to zero size when the `IOMode` is `WriteMode`. +openFileAsTemp + :: FilePath -- ^ file to open + -> Bool -- ^ open the file in non-blocking mode? + -> Bool -- ^ Exclusive mode + -> IO (Io NativeHandle, IODeviceType) +openFileAsTemp filepath non_blocking excl + = openFile' filepath ReadWriteMode non_blocking (if excl then TempExcl else TempNonExcl) + +-- | Open a file and make an 'NativeHandle' for it. Truncates the file to zero +-- size when the `IOMode` is `WriteMode`. +openFile' + :: FilePath -- ^ file to open + -> IOMode -- ^ mode in which to open the file + -> Bool -- ^ open the file in non-blocking mode? + -> TempFileOptions + -> IO (Io NativeHandle, IODeviceType) +openFile' filepath iomode non_blocking tmp_opts = + do devicepath <- getDevicePath filepath + h <- createFile devicepath + -- Attach the handle to the I/O manager's CompletionPort. This allows the + -- I/O manager to service requests for this Handle. + Mgr.associateHandle' h + let hwnd = fromHANDLE h + _type <- devType hwnd + + -- Use the rts to enforce any file locking we may need. + let write_lock = iomode /= ReadMode + + case _type of + -- Regular files need to be locked. + -- See also Note [RTS File locking] + RegularFile -> do + optimizeFileAccess h -- Set a few optimization flags on file handles. + (unique_dev, unique_ino) <- getUniqueFileInfo hwnd + r <- lockFile (fromIntegral $ ptrToWordPtr h) unique_dev unique_ino + (fromBool write_lock) + when (r == -1) $ + ioException (IOError Nothing ResourceBusy "openFile" + "file is locked" Nothing Nothing) + + -- I don't see a reason for blocking directories. So unlike the FD + -- implementation I'll allow it. + _ -> return () + + -- We want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. but TRUNCATE_EXISTING would fail if + -- the file didn't exit. So just set the size afterwards. + when (iomode == WriteMode && _type == RegularFile) $ + setSize hwnd 0 + + return (hwnd, _type) + where + flagIf p f2 + | p = f2 + | otherwise = 0 + -- We have to use in-process locking (e.g. use the locking mechanism + -- in the rts) so we're consistent with the linux behavior and the + -- rts knows about the lock. See #4363 for more. + file_share_mode = #{const FILE_SHARE_READ} + .|. #{const FILE_SHARE_DELETE} + -- Don't support shared writing for temp files. + .|. (flagIf (tmp_opts == NoTemp) + #{const FILE_SHARE_WRITE}) + + file_access_mode = + case iomode of + ReadMode -> #{const GENERIC_READ} + WriteMode -> #{const GENERIC_WRITE} + ReadWriteMode -> #{const GENERIC_READ} + .|. #{const GENERIC_WRITE} + AppendMode -> #{const GENERIC_WRITE} + .|. #{const FILE_APPEND_DATA} + + file_open_mode = + case iomode of + ReadMode -> #{const OPEN_EXISTING} -- O_RDONLY + WriteMode -> #{const OPEN_ALWAYS} -- O_CREAT | O_WRONLY | O_TRUNC + ReadWriteMode -> + case tmp_opts of + NoTemp -> #{const OPEN_ALWAYS} -- O_CREAT | O_RDWR + TempNonExcl -> #{const CREATE_ALWAYS} -- O_CREAT | O_RDWR + TempExcl -> #{const CREATE_NEW} -- O_CREAT | O_RDWR | O_EXCL + AppendMode -> #{const OPEN_ALWAYS} -- O_APPEND + + file_create_flags = + if non_blocking + -- On Windows, the choice of whether an operation completes + -- asynchronously or not depends on how the Handle was created + -- and not on the operation called. As in, the behaviour of + -- ReadFile and WriteFile depends on the flags used to open the + -- handle. For WinIO we always use FILE_FLAG_OVERLAPPED, which + -- means we always issue asynchronous file operation using an + -- OVERLAPPED structure. All blocking, if required must be done + -- on the Haskell side by using existing mechanisms such as MVar + -- or IOPorts. + then #{const FILE_FLAG_OVERLAPPED} + -- I beleive most haskell programs do sequential scans, so + -- optimize for the common case. Though ideally, this would + -- be parameterized by openFile. This will absolutely trash + -- the cache on reverse scans. + -- + -- TODO: make a parameter to openFile and specify only for + -- operations we know are sequential. This parameter should + -- be usable by madvise too. + .|. #{const FILE_FLAG_SEQUENTIAL_SCAN} + .|. (flagIf (tmp_opts /= NoTemp) + -- Hold data in cache for as long as possible + #{const FILE_ATTRIBUTE_TEMPORARY} ) + else #{const FILE_ATTRIBUTE_NORMAL} + .|. (flagIf (tmp_opts /= NoTemp) + -- Hold data in cache for as long as possible + #{const FILE_ATTRIBUTE_TEMPORARY} ) + + createFile devicepath = + withCWString devicepath $ \fp -> + failIf (== iNVALID_HANDLE_VALUE) "CreateFile" $ + c_CreateFile fp file_access_mode + file_share_mode + nullPtr + file_open_mode + file_create_flags + nullPtr + +-- Tell the OS that we support skipping the request Queue if the +-- IRQ can be handled immediately, e.g. if the data is in the cache. +optimizeFileAccess :: HANDLE -> IO () +optimizeFileAccess handle = + failIfFalse_ "SetFileCompletionNotificationModes" $ + c_SetFileCompletionNotificationModes 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 hasFlag flag = (flag .&. mask) == flag + case () of + () | hasFlag (#{const FILE_APPEND_DATA}) -> return AppendMode + | hasFlag (#{const GENERIC_WRITE} .|. #{const GENERIC_READ}) -> return ReadWriteMode + | hasFlag (#{const GENERIC_READ}) -> return ReadMode + | hasFlag (#{const GENERIC_WRITE}) -> return WriteMode + | otherwise -> error "unknown access mask in handleToMode." + +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 + _ <- unlockFile handle + return () + else return () + +-- ----------------------------------------------------------------------------- +-- Locking/unlocking + +foreign import ccall unsafe "lockFile" + lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt + +foreign import ccall unsafe "unlockFile" + unlockFile :: CUIntPtr -> IO CInt + +-- | Returns -1 on error. Otherwise writes two values representing +-- the file into the given ptrs. +foreign import ccall unsafe "get_unique_file_info_hwnd" + c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO () + +-- | getUniqueFileInfo assumes the C call to getUniqueFileInfo +-- succeeds. +getUniqueFileInfo :: RawHandle a => a -> IO (Word64, Word64) +getUniqueFileInfo handle = do + with 0 $ \devptr -> do + with 0 $ \inoptr -> do + c_getUniqueFileInfo (toHANDLE handle) devptr inoptr + liftM2 (,) (peek devptr) (peek inoptr) diff --git a/libraries/base/GHC/IO/Windows/Paths.hs b/libraries/base/GHC/IO/Windows/Paths.hs new file mode 100644 index 0000000000..851dc37508 --- /dev/null +++ b/libraries/base/GHC/IO/Windows/Paths.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +-- Whether there are identities depends on the platform +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Windows.Paths +-- Copyright : (c) The University of Glasgow, 2017 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Windows FilePath handling utility for GHC code. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Windows.Paths + (getDevicePath + ) where + +#include "windows_cconv.h" + +import GHC.Base +import GHC.IO + +import Foreign.C.String +import Foreign.Marshal.Alloc (free) + +foreign import WINDOWS_CCONV safe "__hs_create_device_name" + c_GetDevicePath :: CWString -> IO CWString + +-- | This function converts Windows paths between namespaces. More specifically +-- It converts an explorer style path into a NT or Win32 namespace. +-- This has several caveats but they are caviats that are native to Windows and +-- not POSIX. See +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx. +-- Anything else such as raw device paths we leave untouched. The main benefit +-- of doing any of this is that we can break the MAX_PATH restriction and also +-- access raw handles that we couldn't before. +getDevicePath :: FilePath -> IO FilePath +getDevicePath path + = do str <- withCWString path c_GetDevicePath + newPath <- peekCWString str + free str + return newPath diff --git a/libraries/base/GHC/IOPort.hs b/libraries/base/GHC/IOPort.hs new file mode 100644 index 0000000000..46a553ca51 --- /dev/null +++ b/libraries/base/GHC/IOPort.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IOPort +-- Copyright : (c) Tamar Christina 2019 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IOPort type. This is a facility used by the Windows IO subsystem. +-- We have strict rules with an I/O Port: +-- * writing more than once is an error +-- * reading more than once is an error +-- +-- It gives us the ability to have one thread to block, wait for a result from +-- another thread and then being woken up. *Nothing* more. +-- +-- This type is very much GHC internal. It might be changed or removed without +-- notice in future releases. +-- +----------------------------------------------------------------------------- + +module GHC.IOPort ( + -- * IOPorts + IOPort(..) + , newIOPort + , newEmptyIOPort + , readIOPort + , writeIOPort + , doubleReadException + ) where + +import GHC.Base +import GHC.Exception +import Text.Show + +data IOPortException = IOPortException deriving Show + +instance Exception IOPortException where + displayException IOPortException = "IOPortException" + + +doubleReadException :: SomeException +doubleReadException = toException IOPortException + +data IOPort a = IOPort (IOPort# RealWorld a) +{- ^ +An 'IOPort' is a synchronising variable, used +for communication between concurrent threads, where one of the threads is +controlled by an external state. e.g. by an I/O action that is serviced by the +runtime. It can be thought of as a box, which may be empty or full. + +It is mostly similar to the behavior of 'Control.Concurrent.MVar.MVar' +except 'writeIOPort' doesn't block if the variable is full and the GC +won't forcibly release the lock if it thinks +there's a deadlock. + +The properties of IOPorts are: +* Writing to an empty IOPort will not block. +* Writing to an full IOPort will not block. It might throw an exception. +* Reading from an IOPort for the second time might throw an exception. +* Reading from a full IOPort will not block, return the value and empty the port. +* Reading from an empty IOPort will block until a write. +* Reusing an IOPort (that is, reading or writing twice) is not supported + and might throw an exception. Even if reads and writes are + interleaved. + +This type is very much GHC internal. It might be changed or removed without +notice in future releases. + +-} + +-- | @since 4.1.0.0 +instance Eq (IOPort a) where + (IOPort ioport1#) == (IOPort ioport2#) = + isTrue# (sameIOPort# ioport1# ioport2#) + + + +-- |Create an 'IOPort' which is initially empty. +newEmptyIOPort :: IO (IOPort a) +newEmptyIOPort = IO $ \ s# -> + case newIOPort# s# of + (# s2#, svar# #) -> (# s2#, IOPort svar# #) + +-- |Create an 'IOPort' which contains the supplied value. +newIOPort :: a -> IO (IOPort a) +newIOPort value = + newEmptyIOPort >>= \ ioport -> + writeIOPort ioport value >> + return ioport + +-- |Atomically read the the contents of the 'IOPort'. If the 'IOPort' is +-- currently empty, 'readIOPort' will wait until it is full. After a +-- 'readIOPort', the 'IOPort' is left empty. +-- +-- There is one important property of 'readIOPort': +-- +-- * Only a single threads can be blocked on an 'IOPort'. +-- +readIOPort :: IOPort a -> IO a +readIOPort (IOPort ioport#) = IO $ \ s# -> readIOPort# ioport# s# + +-- |Put a value into an 'IOPort'. If the 'IOPort' is currently full, +-- 'writeIOPort' will throw an exception. +-- +-- There is one important property of 'writeIOPort': +-- +-- * Only a single thread can be blocked on an 'IOPort'. +-- +writeIOPort :: IOPort a -> a -> IO Bool +writeIOPort (IOPort ioport#) x = IO $ \ s# -> + case writeIOPort# ioport# x s# of + (# s, 0# #) -> (# s, False #) + (# s, _ #) -> (# s, True #) + diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index fc863fb3fc..03cd368723 100644 --- a/libraries/base/GHC/RTS/Flags.hsc +++ b/libraries/base/GHC/RTS/Flags.hsc @@ -25,10 +25,12 @@ module GHC.RTS.Flags , TraceFlags (..) , TickyFlags (..) , ParFlags (..) + , IoSubSystem (..) , getRTSFlags , getGCFlags , getConcFlags , getMiscFlags + , getIoManagerFlag , getDebugFlags , getCCFlags , getProfFlags @@ -40,8 +42,7 @@ module GHC.RTS.Flags #include "Rts.h" #include "rts/Flags.h" -import Control.Applicative -import Control.Monad +import Data.Functor ((<$>)) import Foreign import Foreign.C @@ -87,6 +88,32 @@ instance Enum GiveGCStats where toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e) +-- | The I/O SubSystem to use in the program. +-- +-- @since 4.9.0.0 +data IoSubSystem + = IoPOSIX -- ^ Use a POSIX I/O Sub-System + | IoNative -- ^ Use platform native Sub-System. For unix OSes this is the + -- same as IoPOSIX, but on Windows this means use the Windows + -- native APIs for I/O, including IOCP and RIO. + deriving (Eq, Show) + +-- | @since 4.9.0.0 +instance Enum IoSubSystem where + fromEnum IoPOSIX = #{const IO_MNGR_POSIX} + fromEnum IoNative = #{const IO_MNGR_NATIVE} + + toEnum #{const IO_MNGR_POSIX} = IoPOSIX + toEnum #{const IO_MNGR_NATIVE} = IoNative + toEnum e = errorWithoutStackTrace ("invalid enum for IoSubSystem: " ++ show e) + +-- | @since 4.9.0.0 +instance Storable IoSubSystem where + sizeOf = sizeOf . fromEnum + alignment = sizeOf . fromEnum + peek ptr = fmap toEnum $ peek (castPtr ptr) + poke ptr v = poke (castPtr ptr) (fromEnum v) + -- | Parameters of the garbage collector. -- -- @since 4.8.0.0 @@ -148,6 +175,8 @@ data MiscFlags = MiscFlags , linkerAlwaysPic :: Bool , linkerMemBase :: Word -- ^ address to ask the OS for memory for the linker, 0 ==> off + , ioManager :: IoSubSystem + , numIoWorkerThreads :: Word32 } deriving ( Show -- ^ @since 4.8.0.0 , Generic -- ^ @since 4.15.0.0 ) @@ -449,6 +478,7 @@ getConcFlags = do ConcFlags <$> #{peek CONCURRENT_FLAGS, ctxtSwitchTime} ptr <*> #{peek CONCURRENT_FLAGS, ctxtSwitchTicks} ptr +{-# INLINEABLE getMiscFlags #-} getMiscFlags :: IO MiscFlags getMiscFlags = do let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr @@ -470,6 +500,40 @@ getMiscFlags = do <*> (toBool <$> (#{peek MISC_FLAGS, linkerAlwaysPic} ptr :: IO CBool)) <*> #{peek MISC_FLAGS, linkerMemBase} ptr + <*> (toEnum . fromIntegral + <$> (#{peek MISC_FLAGS, ioManager} ptr :: IO Word32)) + <*> (fromIntegral + <$> (#{peek MISC_FLAGS, numIoWorkerThreads} ptr :: IO Word32)) + +{- Note [The need for getIoManagerFlag] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + GHC supports both the new WINIO manager + as well as the old MIO one. In order to + decide which code path to take we often + have to inspect what the user selected at + RTS startup. + + We could use getMiscFlags but then we end up with core containing + reads for all MiscFlags. These won't be eliminated at the core level + even if it's obvious we will only look at the ioManager part of the + ADT. + + We could add a INLINE pragma, but that just means whatever we inline + into is likely to be inlined. So rather than adding a dozen pragmas + we expose a lean way to query this particular flag. It's not satisfying + but it works well enough and allows these checks to be inlined nicely. + +-} + +{-# INLINE getIoManagerFlag #-} +-- | Needed to optimize support for different IO Managers on Windows. +-- See Note [The need for getIoManagerFlag] +getIoManagerFlag :: IO IoSubSystem +getIoManagerFlag = do + let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr + mgrFlag <- (#{peek MISC_FLAGS, ioManager} ptr :: IO Word32) + return $ (toEnum . fromIntegral) mgrFlag getDebugFlags :: IO DebugFlags getDebugFlags = do diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs index bb358a337f..4997d827f5 100644 --- a/libraries/base/GHC/TopHandler.hs +++ b/libraries/base/GHC/TopHandler.hs @@ -40,8 +40,8 @@ import GHC.Base import GHC.Conc hiding (throwTo) import GHC.Real import GHC.IO -import GHC.IO.Handle.FD import GHC.IO.Handle +import GHC.IO.StdHandles import GHC.IO.Exception import GHC.Weak diff --git a/libraries/base/GHC/Windows.hs b/libraries/base/GHC/Windows.hs index 45032d56ac..d8f8bef804 100644 --- a/libraries/base/GHC/Windows.hs +++ b/libraries/base/GHC/Windows.hs @@ -26,11 +26,22 @@ module GHC.Windows ( LPBOOL, BYTE, DWORD, + DDWORD, UINT, + ULONG, ErrCode, HANDLE, LPWSTR, LPTSTR, + LPCTSTR, + LPVOID, + LPDWORD, + LPSTR, + LPCSTR, + LPCWSTR, + WORD, + UCHAR, + NTSTATUS, -- * Constants iNFINITE, @@ -56,39 +67,67 @@ module GHC.Windows ( -- $errno c_maperrno, c_maperrno_func, + + -- * Misc + ddwordToDwords, + dwordsToDdword, + nullHANDLE, ) where +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) import Data.Char import Data.OldList import Data.Maybe import Data.Word +import Data.Int import Foreign.C.Error import Foreign.C.String import Foreign.C.Types import Foreign.Ptr import GHC.Base +import GHC.Enum (maxBound) import GHC.IO import GHC.Num +import GHC.Real (fromIntegral) import System.IO.Error import qualified Numeric -#if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall +#if MIN_VERSION_base(4,7,0) +import Data.Bits (finiteBitSize) #else -# error Unknown mingw32 arch +import Data.Bits (Bits, bitSize) + +finiteBitSize :: (Bits a) => a -> Int +finiteBitSize = bitSize #endif -type BOOL = Bool -type LPBOOL = Ptr BOOL -type BYTE = Word8 -type DWORD = Word32 -type UINT = Word32 -type ErrCode = DWORD -type HANDLE = Ptr () -type LPWSTR = Ptr CWchar +#include "windows_cconv.h" + +type BOOL = Bool +type LPBOOL = Ptr BOOL +type BYTE = Word8 +type DWORD = Word32 +type UINT = Word32 +type ULONG = Word32 +type ErrCode = DWORD +type HANDLE = Ptr () +type LPWSTR = Ptr CWchar +type LPCTSTR = LPTSTR +type LPVOID = Ptr () +type LPDWORD = Ptr DWORD +type LPSTR = Ptr CChar +type LPCSTR = LPSTR +type LPCWSTR = LPWSTR +type WORD = Word16 +type UCHAR = Word8 +type NTSTATUS = Int32 + +nullHANDLE :: HANDLE +nullHANDLE = nullPtr + +-- Not really a basic type, but used in many places +type DDWORD = Word64 -- | Be careful with this. LPTSTR can mean either WCHAR* or CHAR*, depending -- on whether the UNICODE macro is defined in the corresponding C code. @@ -194,3 +233,15 @@ foreign import WINDOWS_CCONV unsafe "windows.h LocalFree" -- | Get the last system error produced in the current thread. foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" getLastError :: IO ErrCode + +---------------------------------------------------------------- +-- Misc helpers +---------------------------------------------------------------- + +ddwordToDwords :: DDWORD -> (DWORD,DWORD) +ddwordToDwords n = + (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD)) + ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD))) + +dwordsToDdword:: (DWORD,DWORD) -> DDWORD +dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi) diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index a4d4ec4e67..03e0e06319 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -232,6 +232,12 @@ import Foreign.C.String import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Storable +import GHC.IO.SubSystem +import GHC.IO.Windows.Handle (openFileAsTemp) +import GHC.IO.Handle.Windows (mkHandleFromHANDLE) +import GHC.IO.Device as IODevice +import GHC.Real (fromIntegral) +import Foreign.Marshal.Utils (new) #endif import Foreign.C.Types import System.Posix.Internals @@ -245,13 +251,14 @@ import GHC.IORef import GHC.Num import GHC.IO hiding ( bracket, onException ) import GHC.IO.IOMode -import GHC.IO.Handle.FD import qualified GHC.IO.FD as FD import GHC.IO.Handle +import qualified GHC.IO.Handle.FD as POSIX import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn ) import GHC.IO.Exception ( userError ) import GHC.IO.Encoding import Text.Read +import GHC.IO.StdHandles import GHC.Show import GHC.MVar @@ -529,13 +536,29 @@ openTempFile' loc tmp_dir template binary mode -- beginning with '.' as the second component. _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" #if defined(mingw32_HOST_OS) - findTempName = do + findTempName = findTempNamePosix <!> findTempNameWinIO + + findTempNameWinIO = do + let label = if null prefix then "ghc" else prefix + withCWString tmp_dir $ \c_tmp_dir -> + withCWString label $ \c_template -> + withCWString suffix $ \c_suffix -> do + c_ptr <- new nullPtr + res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix + c_ptr + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do c_p <- peek c_ptr + filename <- peekCWString c_p + free c_p + handleResultsWinIO filename ((fromIntegral mode .&. o_EXCL) == o_EXCL) + + findTempNamePosix = do let label = if null prefix then "ghc" else prefix withCWString tmp_dir $ \c_tmp_dir -> withCWString label $ \c_template -> withCWString suffix $ \c_suffix -> - -- NOTE: revisit this when new I/O manager in place and use a UUID - -- based one when we are no longer MAX_PATH bound. allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 c_str @@ -543,9 +566,9 @@ openTempFile' loc tmp_dir template binary mode then do errno <- getErrno ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) else do filename <- peekCWString c_str - handleResults filename + handleResultsPosix filename - handleResults filename = do + handleResultsPosix filename = do let oflags1 = rw_flags .|. o_EXCL binary_flags | binary = o_BINARY @@ -561,14 +584,26 @@ openTempFile' loc tmp_dir template binary mode True{-is_nonblock-} enc <- getLocaleEncoding - h <- mkHandleFromFD fD fd_type filename ReadWriteMode + h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode False{-set non-block-} (Just enc) return (filename, h) + handleResultsWinIO filename excl = do + (hwnd, hwnd_type) <- openFileAsTemp filename True excl + mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding + + -- then use it to make a Handle + h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec + `onException` IODevice.close hwnd + return (filename, h) + foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool +foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo + :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool + pathSeparator :: String -> Bool pathSeparator template = any (\x-> x == '/' || x == '\\') template @@ -588,7 +623,7 @@ output_flags = std_flags True{-is_nonblock-} enc <- getLocaleEncoding - h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc) + h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc) return (filepath, h) diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs index df2c0f055a..1c41dc2ca2 100644 --- a/libraries/base/System/Timeout.hs +++ b/libraries/base/System/Timeout.hs @@ -15,7 +15,7 @@ -- Attach a timeout event to arbitrary 'IO' computations. -- ------------------------------------------------------------------------------- - +-- TODO: Inspect is still suitable. module System.Timeout ( Timeout, timeout ) where #if !defined(mingw32_HOST_OS) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 33eccf214f..4a7fe6e133 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -37,6 +37,7 @@ extra-source-files: include/ieee-flpt.h include/md5.h include/fs.h + include/winio_structs.h install-sh source-repository head @@ -200,6 +201,7 @@ Library GHC.Enum GHC.Environment GHC.Err + GHC.Event.TimeOut GHC.Exception GHC.Exception.Type GHC.ExecutionStack @@ -238,6 +240,8 @@ Library GHC.IO.Handle.Types GHC.IO.IOMode GHC.IO.Unsafe + GHC.IO.StdHandles + GHC.IO.SubSystem GHC.IOArray GHC.IORef GHC.Int @@ -304,6 +308,8 @@ Library Type.Reflection Type.Reflection.Unsafe Unsafe.Coerce + -- TODO: remove + GHC.IOPort reexported-modules: GHC.Num.Integer @@ -324,6 +330,8 @@ Library GHC.IO.Handle.Lock.NoOp GHC.IO.Handle.Lock.Windows GHC.StaticPtr.Internal + GHC.Event.Internal.Types + -- GHC.IOPort -- TODO: hide again after debug System.Environment.ExecutablePath System.CPUTime.Utils @@ -332,8 +340,6 @@ Library cbits/PrelIOUtils.c cbits/SetEnv.c cbits/WCsubst.c - cbits/Win32Utils.c - cbits/consUtils.c cbits/iconv.c cbits/inputReady.c cbits/md5.c @@ -363,14 +369,50 @@ Library -- mingwex and mingw32. the __math_err symbol is defined in -- mingw32 which is required by mingwex. -- shlwapi: provides PathFileExistsW - extra-libraries: wsock32, user32, shell32, msvcrt, mingw32, mingwex, shlwapi + -- 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, 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 + -- If we're compiling on windows, enforce that we only support Windows 7+ + -- Adding this here means it doesn't have to be done in individual .c files + -- and also centralizes the versioning. + cpp-options: -D_WIN32_WINNT=0x06010000 + cc-options: -D_WIN32_WINNT=0x06010000 exposed-modules: GHC.IO.Encoding.CodePage.API GHC.IO.Encoding.CodePage.Table GHC.Conc.Windows + GHC.Conc.WinIO + GHC.Conc.POSIX + GHC.Conc.POSIX.Const GHC.Windows + GHC.Event.Windows + GHC.Event.Windows.Clock + GHC.Event.Windows.ConsoleEvent + GHC.Event.Windows.FFI + GHC.Event.Windows.ManagedThreadPool + GHC.Event.Windows.Thread + GHC.IO.Handle.Windows + GHC.IO.Windows.Handle + GHC.IO.Windows.Encoding + GHC.IO.Windows.Paths other-modules: + GHC.Event.Arr + GHC.Event.Array + GHC.Event.IntTable + GHC.Event.PSQ + GHC.Event.Unique System.CPUTime.Windows + c-sources: + cbits/Win32Utils.c + cbits/consUtils.c + cbits/IOutils.c + else exposed-modules: GHC.Event diff --git a/libraries/base/cbits/IOutils.c b/libraries/base/cbits/IOutils.c new file mode 100644 index 0000000000..8d3ae35588 --- /dev/null +++ b/libraries/base/cbits/IOutils.c @@ -0,0 +1,484 @@ +/* + * (c) The GHC Team 2017-2018. + * + * I/O Utility functions for Windows. + */ + +#include <stdbool.h> +#include <stdint.h> +#include <winsock2.h> +#include <windows.h> +#include <io.h> +#include <math.h> + +/* Import some functions defined in base. */ +extern void maperrno(void); + +/* Enum of Handle type. */ +typedef +enum HandleType + { + TYPE_CHAR, // 0 + TYPE_DISK, // 1 + TYPE_PIPE, // 2 + TYPE_SOCKET, // 3 + TYPE_REMOTE, // 4 + TYPE_RAW, // 5 + TYPE_UNKNOWN // 6 + } HANDLE_TYPE; + +/* + * handleReady(hwnd) checks to see whether input is available on the file + * handle 'hwnd'. Input meaning 'can I safely read at least a + * *character* from this file object without blocking?' + */ +int +__handle_ready(HANDLE hFile, bool write, int msecs) +{ + DWORD handleType = GetFileType (hFile); + + DWORD rc; + DWORD avail; + + switch (handleType) + { + case FILE_TYPE_CHAR: + { + INPUT_RECORD buf[1]; + DWORD count; + + /* A Console Handle will appear to be ready + (WaitForSingleObject() returned WAIT_OBJECT_0) when + it has events in its input buffer, but these events might + not be keyboard events, so when we read from the Handle the + read() will block. So here we try to discard non-keyboard + events from a console handle's input buffer and then try + the WaitForSingleObject() again. + Phyx: I'm worried that we're discarding events someone else may need. */ + while (true) // keep trying until we find a real key event + { + rc = WaitForSingleObject( hFile, msecs ); + switch (rc) + { + case WAIT_TIMEOUT: + return false; + case WAIT_OBJECT_0: + break; + default: + /* WAIT_FAILED */ + maperrno(); + return -1; + } + + while (true) // discard non-key events + { + /* I wonder if we can do better by grabbing a list of + input records at a time by using PeekConsoleInput. */ + rc = PeekConsoleInput(hFile, buf, 1, &count); + if (rc == 0) { + rc = GetLastError(); + if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) + return true; + else { + maperrno(); + return -1; + } + } + + if (count == 0) + break; /* no more events => wait again. */ + + /* discard console events that are not "key down", because + these will also be discarded by ReadFile(). */ + if (buf[0].EventType == KEY_EVENT && + buf[0].Event.KeyEvent.bKeyDown && + buf[0].Event.KeyEvent.uChar.AsciiChar != '\0') + return true; /* it's a proper keypress. */ + else + { + /* it's a non-key event, a key up event, or a + non-character key (e.g. shift). discard it. */ + rc = ReadConsoleInput(hFile, buf, 1, &count); + if (rc == 0) { + rc = GetLastError(); + if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) + return true; + else { + maperrno(); + return -1; + } + } + } + } + } + } + case FILE_TYPE_DISK: + /* assume that disk files are always ready. */ + return true; + + case FILE_TYPE_PIPE: + { + // Try to see if this is a socket + //------------------------- + // Create new event + WSAEVENT newEvent = WSACreateEvent(); + + //------------------------- + // Associate event types FD_WRITE or FD_READ + // with the listening socket and NewEvent + rc = WSAEventSelect((SOCKET)hFile, newEvent, write ? FD_WRITE : FD_READ); + + if (rc == WSAENOTSOCK) + { + CloseHandle (newEvent); + + // WaitForMultipleObjects() doesn't work for pipes (it + // always returns WAIT_OBJECT_0 even when no data is + // available). If the HANDLE is a pipe, therefore, we try + // PeekNamedPipe: + // + rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL ); + if (rc != 0) + return avail != 0; + else { + rc = GetLastError(); + if (rc == ERROR_BROKEN_PIPE) + return true; // this is probably what we want + + if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) { + maperrno(); + return -1; + } + } + /* PeekNamedPipe didn't work - fall through to the general case */ + } + else if (rc != 0) + { + CloseHandle (newEvent); + // It seems to be a socket but can't determine the state. + // Maybe not initialized. Either way, we know enough. + return false; + } + + // Wait for the socket event to trigger. + rc = WaitForSingleObject( newEvent, msecs ); + CloseHandle (newEvent); + + /* 1 => Input ready, 0 => not ready, -1 => error */ + switch (rc) + { + case WAIT_TIMEOUT: + return false; + case WAIT_OBJECT_0: + return true; + default: + { + /* WAIT_FAILED */ + maperrno(); + return -1; + } + } + } + default: + rc = WaitForSingleObject( hFile, msecs ); + + /* 1 => Input ready, 0 => not ready, -1 => error */ + switch (rc) + { + case WAIT_TIMEOUT: + return false; + case WAIT_OBJECT_0: + return true; + default: + { + /* WAIT_FAILED */ + maperrno(); + return -1; + } + } + } +} + +bool +__is_console(HANDLE hFile) +{ + /* Broken handle can't be terminal */ + if (hFile == INVALID_HANDLE_VALUE) + return false; + + DWORD handleType = GetFileType (hFile); + + /* TTY must be a character device */ + if (handleType == FILE_TYPE_CHAR) + return true; + + DWORD st; + /* GetConsoleMode appears to fail when it's not a TTY. In + particular, it's what most of our terminal functions + assume works, so if it doesn't work for all intents + and purposes we're not dealing with a terminal. */ + if (!GetConsoleMode(hFile, &st)) { + /* Clear the error buffer before returning. */ + SetLastError (ERROR_SUCCESS); + return false; + } + + return true; +} + +#if !defined(ENABLE_VIRTUAL_TERMINAL_INPUT) +#define ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 +#endif + +bool +__set_console_buffering(HANDLE hFile, bool cooked) +{ + if (hFile == INVALID_HANDLE_VALUE) { + return false; + } + + DWORD st; + if (!GetConsoleMode(hFile, &st)) { + return false; + } + + /* According to GetConsoleMode() docs, it is not possible to + leave ECHO_INPUT enabled without also having LINE_INPUT, + so we have to turn both off here. + We toggle ENABLE_VIRTUAL_TERMINAL_INPUT to enable us to receive + virtual keyboard keys in ReadConsole. */ + DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT; + DWORD enabled = (st & ~flgs) | ENABLE_VIRTUAL_TERMINAL_INPUT; + DWORD disabled = (st | ENABLE_LINE_INPUT) & ~ENABLE_VIRTUAL_TERMINAL_INPUT; + + + return SetConsoleMode(hFile, cooked ? enabled : disabled); +} + +bool +__set_console_echo(HANDLE hFile, bool on) +{ + DWORD st; + DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT; + + if (hFile == INVALID_HANDLE_VALUE) { + return false; + } + + return GetConsoleMode(hFile, &st) && + SetConsoleMode(hFile, ( on ? (st | flgs) : (st & ~flgs))); +} + +bool +__get_console_echo(HANDLE hFile) +{ + DWORD st; + + if (hFile == INVALID_HANDLE_VALUE) { + return false; + } + + return GetConsoleMode(hFile, &st) && + (st & ENABLE_ECHO_INPUT) == ENABLE_ECHO_INPUT; +} + +bool +__flush_input_console(HANDLE hFile) +{ + if ( hFile == INVALID_HANDLE_VALUE ) + return false; + + /* If the 'handle' isn't connected to a console; treat the flush + * operation as a NOP. + */ + DWORD unused; + if ( !GetConsoleMode(hFile, &unused) && + GetLastError() == ERROR_INVALID_HANDLE ) { + return false; + } + + if ( FlushConsoleInputBuffer(hFile) ) + return true; + + maperrno(); + return false; +} + +HANDLE_TYPE +__handle_type (HANDLE hFile) +{ + DWORD handleType = GetFileType (hFile); + switch (handleType) + { + case FILE_TYPE_PIPE: + { + WSAEVENT newEvent = WSACreateEvent(); + DWORD rc = WSAEventSelect((SOCKET)hFile, newEvent, FD_CLOSE); + CloseHandle (newEvent); + if (rc == WSAENOTSOCK) + return TYPE_SOCKET; + else + return TYPE_PIPE; + } + case FILE_TYPE_CHAR: + return TYPE_CHAR; + case FILE_TYPE_DISK: + return TYPE_DISK; + case FILE_TYPE_REMOTE: + return TYPE_REMOTE; + case FILE_TYPE_UNKNOWN: + default: + return TYPE_UNKNOWN; + } +} + +bool +__close_handle (HANDLE hFile) +{ + switch (__handle_type (hFile)) + { + case TYPE_SOCKET: + return closesocket ((SOCKET)hFile) == 0; + default: + return CloseHandle (hFile); + } +} + +bool __set_file_pointer (HANDLE hFile, int64_t pos, DWORD moveMethod, + int64_t* outPos) +{ + LARGE_INTEGER ret; + LARGE_INTEGER li; + li.QuadPart = pos; + bool success = SetFilePointerEx (hFile, li, &ret, moveMethod) + != INVALID_SET_FILE_POINTER; + *outPos = ret.QuadPart; + return success; +} + +int64_t __get_file_pointer (HANDLE hFile) +{ + LARGE_INTEGER ret; + LARGE_INTEGER pos; + pos.QuadPart = 0; + if (SetFilePointerEx(hFile, pos, &ret, FILE_CURRENT) + == INVALID_SET_FILE_POINTER) + return -1; + + return ret.QuadPart; +} + +int64_t __get_file_size (HANDLE hFile) +{ + /* Broken handle can't do stat. */ + if (hFile == INVALID_HANDLE_VALUE) + return false; + + switch (GetFileType (hFile)) + { + case FILE_TYPE_CHAR: + case FILE_TYPE_DISK: + break; + default: + return -1; + } + + LARGE_INTEGER ret; + if (!GetFileSizeEx(hFile, &ret)) + return -1; + + return ret.QuadPart; +} + +bool __set_file_size (HANDLE hFile, int64_t size) +{ + LARGE_INTEGER li; + li.QuadPart = size; + if(!SetFilePointerEx (hFile, li, NULL, FILE_BEGIN)) + return false; + + return SetEndOfFile (hFile); +} + +bool __duplicate_handle (HANDLE hFile, HANDLE* hFileDup) +{ + switch (__handle_type (hFile)) + { + case TYPE_SOCKET: + // should use WSADuplicateSocket + return false; + default: + return DuplicateHandle(GetCurrentProcess(), + hFile, + GetCurrentProcess(), + hFileDup, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + } +} + +bool __set_console_pointer (HANDLE hFile, int64_t pos, DWORD moveMethod, + int64_t* outPos) +{ + CONSOLE_SCREEN_BUFFER_INFO info; + if(!GetConsoleScreenBufferInfo (hFile, &info)) + return false; + + COORD point; + switch (moveMethod) + { + case FILE_END: + { + int64_t end = info.dwSize.X * info.dwSize.Y; + pos = end + pos; + point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X }; + break; + } + case FILE_CURRENT: + { + int64_t current = (info.dwCursorPosition.Y * info.dwSize.X) + + info.dwCursorPosition.X; + pos = current + pos; + point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X }; + break; + } + case FILE_BEGIN: + default: + point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X }; + break; + } + + *outPos = pos; + return SetConsoleCursorPosition (hFile, point); +} + +int64_t __get_console_pointer (HANDLE hFile) +{ + CONSOLE_SCREEN_BUFFER_INFO info; + if(!GetConsoleScreenBufferInfo (hFile, &info)) + return -1; + + return (info.dwCursorPosition.Y * info.dwSize.X) + info.dwCursorPosition.X; +} + +int64_t __get_console_buffer_size (HANDLE hFile) +{ + CONSOLE_SCREEN_BUFFER_INFO ret; + if (!GetConsoleScreenBufferInfo(hFile, &ret)) + return -1; + + return ret.dwSize.X * ret.dwSize.Y; +} + +bool __set_console_buffer_size (HANDLE hFile, int64_t size) +{ + CONSOLE_SCREEN_BUFFER_INFO ret; + if (!GetConsoleScreenBufferInfo(hFile, &ret)) + return false; + + COORD sz = {ret.dwSize.X, (int)ceil(size / ret.dwSize.X)}; + return SetConsoleScreenBufferSize (hFile, sz); +} + + diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c index 886c277b5c..f3dec0d98d 100644 --- a/libraries/base/cbits/Win32Utils.c +++ b/libraries/base/cbits/Win32Utils.c @@ -5,14 +5,21 @@ ------------------------------------------------------------------------- */ #if defined(_WIN32) +/* Use Mingw's C99 print functions. */ +#define __USE_MINGW_ANSI_STDIO 1 +/* Using Secure APIs */ +#define MINGW_HAS_SECURE_API 1 #include "HsBase.h" #include <stdbool.h> #include <stdint.h> -/* Using Secure APIs */ -#define MINGW_HAS_SECURE_API 1 #include <wchar.h> #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 codes and errno values */ @@ -131,9 +138,8 @@ LPWSTR base_getErrorMessage(DWORD err) return what; } -int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) +int get_unique_file_info_hwnd(HANDLE h, HsWord64 *dev, HsWord64 *ino) { - HANDLE h = (HANDLE)_get_osfhandle(fd); BY_HANDLE_FILE_INFORMATION info; if (GetFileInformationByHandle(h, &info)) @@ -148,12 +154,100 @@ int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) return -1; } +int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) +{ + HANDLE h = (HANDLE)_get_osfhandle(fd); + return get_unique_file_info_hwnd (h, dev, ino); +} + BOOL file_exists(LPCTSTR path) { DWORD r = GetFileAttributes(path); return r != INVALID_FILE_ATTRIBUTES; } +/* If true then caller needs to free tempFileName. */ +bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix, + wchar_t* suffix, wchar_t** tempFileName) +{ + *tempFileName = NULL; + int retry = 5; + bool success = false; + while (retry-- > 0 && !success) + { + GUID guid; + ZeroMemory (&guid, sizeof (guid)); + if (CoCreateGuid (&guid) != S_OK) + goto fail; + + RPC_WSTR guidStr; + if (UuidToStringW ((UUID*)&guid, &guidStr) != S_OK) + goto fail; + + /* We can't create a device path here since this path escapes the compiler + so instead return a normal path and have openFile deal with it. */ + wchar_t* devName = malloc (sizeof (wchar_t) * wcslen (pathName)); + wcscpy (devName, pathName); + int len = wcslen (devName) + wcslen (suffix) + wcslen (prefix) + + wcslen (guidStr) + 3; + *tempFileName = malloc (len * sizeof (wchar_t)); + if (*tempFileName == NULL) + goto fail; + + /* Only add a slash if path didn't already end in one, otherwise we create + an invalid path. */ + bool slashed = devName[wcslen(devName)-1] == '\\'; + wchar_t* sep = slashed ? L"" : L"\\"; + if (-1 == swprintf_s (*tempFileName, len, L"%ls%ls%ls-%ls%ls", + devName, sep, prefix, guidStr, suffix)) + goto fail; + + free (devName); + RpcStringFreeW (&guidStr); + /* This should never happen because GUIDs are unique. But in case hell + froze over let's check anyway. */ + DWORD dwAttrib = GetFileAttributesW (*tempFileName); + success = (dwAttrib == INVALID_FILE_ATTRIBUTES + || (dwAttrib & FILE_ATTRIBUTE_DIRECTORY)); + if (!success) + free (*tempFileName); + } + + return success; + +fail: + if (*tempFileName != NULL) { + free (*tempFileName); + } + maperrno(); + 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/libraries/base/cbits/consUtils.c b/libraries/base/cbits/consUtils.c index 0c9202d0c9..ac5d3ea75a 100644 --- a/libraries/base/cbits/consUtils.c +++ b/libraries/base/cbits/consUtils.c @@ -1,4 +1,4 @@ -/* +/* * (c) The University of Glasgow 2002 * * Win32 Console API support @@ -46,7 +46,7 @@ set_console_buffering__(int fd, int cooked) leave ECHO_INPUT enabled without also having LINE_INPUT, so we have to turn both off here. */ DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT; - + if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) { if ( GetConsoleMode(h,&st) && SetConsoleMode(h, cooked ? (st | ENABLE_LINE_INPUT) : st & ~flgs) ) { @@ -62,9 +62,9 @@ set_console_echo__(int fd, int on) HANDLE h; DWORD st; DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT; - + if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) { - if ( GetConsoleMode(h,&st) && + if ( GetConsoleMode(h,&st) && SetConsoleMode(h,( on ? (st | flgs) : (st & ~ENABLE_ECHO_INPUT))) ) { return 0; } @@ -77,7 +77,7 @@ get_console_echo__(int fd) { HANDLE h; DWORD st; - + if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) { if ( GetConsoleMode(h,&st) ) { return (st & ENABLE_ECHO_INPUT ? 1 : 0); @@ -86,26 +86,4 @@ get_console_echo__(int fd) return -1; } -int -flush_input_console__(int fd) -{ - HANDLE h = (HANDLE)_get_osfhandle(fd); - - if ( h != INVALID_HANDLE_VALUE ) { - /* If the 'fd' isn't connected to a console; treat the flush - * operation as a NOP. - */ - DWORD unused; - if ( !GetConsoleMode(h,&unused) && - GetLastError() == ERROR_INVALID_HANDLE ) { - return 0; - } - if ( FlushConsoleInputBuffer(h) ) { - return 0; - } - } - /* ToDo: translate GetLastError() into something errno-friendly */ - return -1; -} - #endif /* defined(_WIN32) || ... */ diff --git a/libraries/base/include/alignment.h b/libraries/base/include/alignment.h new file mode 100644 index 0000000000..cb2f7da35f --- /dev/null +++ b/libraries/base/include/alignment.h @@ -0,0 +1,3 @@ +#if __GLASGOW_HASKELL__ < 711 +#define hsc_alignment(t ) hsc_printf ( "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__)); +#endif diff --git a/libraries/base/include/consUtils.h b/libraries/base/include/consUtils.h index 3536593f3c..db5fc8eaef 100644 --- a/libraries/base/include/consUtils.h +++ b/libraries/base/include/consUtils.h @@ -1,4 +1,4 @@ -/* +/* * (c) The University of Glasgow, 2000-2002 * * Win32 Console API helpers. @@ -9,4 +9,3 @@ extern int is_console__(int fd); extern int set_console_buffering__(int fd, int cooked); extern int set_console_echo__(int fd, int on); extern int get_console_echo__(int fd); -extern int flush_input_console__ (int fd); diff --git a/libraries/base/include/windows_cconv.h b/libraries/base/include/windows_cconv.h new file mode 100644 index 0000000000..4fa84071c8 --- /dev/null +++ b/libraries/base/include/windows_cconv.h @@ -0,0 +1,12 @@ +#if !defined(__WINDOWS_CCONV_H) +#define __WINDOWS_CCONV_H + +#if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +#elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +#else +# error Unknown mingw32 arch +#endif + +#endif diff --git a/libraries/base/include/winio_structs.h b/libraries/base/include/winio_structs.h new file mode 100644 index 0000000000..da9dab05b7 --- /dev/null +++ b/libraries/base/include/winio_structs.h @@ -0,0 +1,40 @@ +/* + * (c) Tamar Christina, 2019. + * + * Structures supporting the IOCP based I/O Manager or Windows. + */ + +#include <Windows.h> +#include <stdint.h> + +#if defined(_WIN64) +# define ALIGNMENT __attribute__ ((aligned (8))) +#elif defined(_WIN32) +# define ALIGNMENT __attribute__ ((aligned (8))) +#else +# error "unknown environment, can't determine alignment" +#endif + +/* Completion data structure. Must be kept in sync with that in + GHC.Event.Windows or horrible things happen. */ +typedef struct _CompletionData { + /* The Handle to the object for which the I/O operation is in progress. */ + HWND cdHandle; + /* Handle to the callback routine to call to notify that an operation has + finished. This value is opaque as it shouldn't be accessible + outside the Haskell world. */ + uintptr_t cdCallback; +} CompletionData, *LPCompletionData; + +/* The Windows API Requires an OVERLAPPED struct for asynchronous access, + however if we pad the structure we can give extra book keeping information + without needing to look these up later. Do not modify this struct unless + you know what you're doing. */ +typedef struct _HASKELL_OVERLAPPED { + /* Windows OVERLAPPED structure. NOTE: MUST BE FIRST element. */ + OVERLAPPED hoOverlapped; + /* Pointer to additional payload in Haskell land. This will contain a + foreign pointer. We only use atomic operations to access this field in + order to correctly handle multiple threads using it. */ + LPCompletionData hoData ALIGNMENT; +} HASKELL_OVERLAPPED; diff --git a/libraries/base/tests/Concurrent/ThreadDelay001.hs b/libraries/base/tests/Concurrent/ThreadDelay001.hs index 3b0f806e22..fb4385be31 100644 --- a/libraries/base/tests/Concurrent/ThreadDelay001.hs +++ b/libraries/base/tests/Concurrent/ThreadDelay001.hs @@ -1,22 +1,39 @@ - +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} -- Test that threadDelay actually sleeps for (at least) as long as we -- ask it +-- On windows the resolution of getCurrentTime is far too low to avoid +-- false positives for this test. So we use the internal method from +-- GHC.Event.Windows.Clock instead. + module Main (main) where import Control.Concurrent import Control.Monad import Data.Time - +#if defined(mingw32_HOST_OS) +import GHC.Event.Windows.Clock +#endif main :: IO () main = mapM_ delay (0 : take 7 (iterate (*5) 100)) delay :: Int -> IO () delay n = do +#if defined(mingw32_HOST_OS) + !sec_start <- getClock >>= getTime + threadDelay n + !sec_end <- getClock >>= getTime + + let diff = sec_end - sec_start + when (diff * 1000000 < fromIntegral n) $ do + putStrLn "threadDelay returned early" + print(sec_start, sec_end, n, diff*1000000) + +#else tS <- getCurrentTime threadDelay n tE <- getCurrentTime - let req = fromIntegral n * 10 ^ (6 :: Int) obs = floor (diffUTCTime tE tS * 10 ^ (12 :: Int)) diff = obs - req @@ -24,4 +41,4 @@ delay n = do diff' = fromIntegral diff / 10 ^ (12 :: Int) when (obs < req) $ print (tS, tE, req, obs, diff, diff') - +#endif diff --git a/libraries/base/tests/IO/T4144.hs b/libraries/base/tests/IO/T4144.hs index 329601ca38..1fc16c0f07 100644 --- a/libraries/base/tests/IO/T4144.hs +++ b/libraries/base/tests/IO/T4144.hs @@ -46,15 +46,21 @@ remaining (BSIODevice bs mPos) sizeBS :: BSIODevice -> Int sizeBS (BSIODevice bs _) = B.length bs -seekBS :: BSIODevice -> SeekMode -> Int -> IO () -seekBS dev AbsoluteSeek pos +seekBS :: BSIODevice -> SeekMode -> Int -> IO Integer +seekBS dev@(BSIODevice _ mPos) mode pos + = do seekBS' dev mode pos + maybe 0 fromIntegral <$> tryReadMVar mPos + + +seekBS' :: BSIODevice -> SeekMode -> Int -> IO () +seekBS' dev AbsoluteSeek pos | pos < 0 = error "Cannot seek to a negative position!" | pos > sizeBS dev = error "Cannot seek past end of handle!" | otherwise = case dev of BSIODevice _ mPos -> modifyMVar_ mPos $ \_ -> return pos -seekBS dev SeekFromEnd pos = seekBS dev AbsoluteSeek (sizeBS dev - pos) -seekBS dev RelativeSeek pos +seekBS' dev SeekFromEnd pos = seekBS' dev AbsoluteSeek (sizeBS dev - pos) +seekBS' dev RelativeSeek pos = case dev of BSIODevice _bs mPos -> modifyMVar_ mPos $ \curPos -> @@ -69,12 +75,12 @@ tellBS (BSIODevice _ mPos) = readMVar mPos dupBS :: BSIODevice -> IO BSIODevice dupBS (BSIODevice bs mPos) = BSIODevice bs <$> (readMVar mPos >>= newMVar) -readBS :: BSIODevice -> Ptr Word8 -> Int -> IO Int -readBS dev@(BSIODevice bs mPos) buff amount +readBS :: BSIODevice -> Ptr Word8 -> Word64 -> Int -> IO Int +readBS dev@(BSIODevice bs mPos) buff offset amount = do rem <- remaining dev if amount > rem - then readBS dev buff rem + then readBS dev buff offset rem else B.unsafeUseAsCString bs $ \ptr -> do memcpy buff (castPtr ptr) (fromIntegral amount) @@ -91,7 +97,7 @@ instance BufferedIO BSIODevice where instance RawIO BSIODevice where read = readBS - readNonBlocking dev buff n = Just `liftM` readBS dev buff n + readNonBlocking dev buff offset n = Just `liftM` readBS dev buff offset n instance IODevice BSIODevice where ready _ True _ = return False -- read only @@ -112,3 +118,4 @@ instance IODevice BSIODevice where main = bsHandle "test" "<fake file>" >>= Data.ByteString.Char8.hGetContents >>= print + diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T index 0ba27f1b42..f03f6a01f1 100644 --- a/libraries/base/tests/IO/all.T +++ b/libraries/base/tests/IO/all.T @@ -16,8 +16,8 @@ test('hFileSize001', normal, compile_and_run, ['']) test('hFileSize002', [omit_ways(['ghci'])], compile_and_run, ['']) test('hFlush001', [], compile_and_run, ['']) -test('hGetBuffering001', - [omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')], +test('hGetBuffering001', + [omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')], compile_and_run, ['']) test('hGetContentsS001', normal, compile_and_run, ['']) @@ -47,7 +47,7 @@ test('hSeek004', [], compile_and_run, ['-cpp']) test('hSetBuffering002', set_stdin('hSetBuffering002.hs'), compile_and_run, ['']) test('hSetBuffering003', - [omit_ways(['ghci']), set_stdin('hSetBuffering003.hs')], + [omit_ways(['ghci']), set_stdin('hSetBuffering003.hs')], compile_and_run, ['']) test('hSetBuffering004', set_stdin('hSetBuffering004.hs'), compile_and_run, ['']) @@ -68,6 +68,7 @@ test('openFile005', [], compile_and_run, ['']) test('openFile006', [], compile_and_run, ['']) test('openFile007', [], compile_and_run, ['']) test('openFile008', cmd_prefix('ulimit -n 2048; '), compile_and_run, ['']) +test('openFile009', [], compile_and_run, ['']) test('putStr001', normal, compile_and_run, ['']) test('readFile001', [], compile_and_run, ['']) @@ -86,7 +87,8 @@ test('hGetBuf001', compile_and_run, ['-package unix']) # As discussed in #16819, this test is racy in a threaded environment. -test('hDuplicateTo001', [omit_ways(concurrent_ways)], compile_and_run, ['']) +test('hDuplicateTo001', [omit_ways(concurrent_ways), + when(opsys('mingw32'), skip)], compile_and_run, ['']) test('countReaders001', [], compile_and_run, ['']) @@ -130,7 +132,10 @@ test('T4144', normal, compile_and_run, ['']) test('encodingerror001', normal, compile_and_run, ['']) -test('T4808', [fragile_for(16909, concurrent_ways), exit_code(1)], compile_and_run, ['']) +# Requires use of the FD interface which is not supported under WINIO +test('T4808', [when(opsys('mingw32'), skip) + ,fragile_for(16909, concurrent_ways), exit_code(1)] + , compile_and_run, ['']) test('T4895', normal, compile_and_run, ['']) test('T7853', normal, compile_and_run, ['']) # Tests ability to perform >32-bit IO operations diff --git a/libraries/base/tests/IO/hClose002.stdout-mingw32 b/libraries/base/tests/IO/hClose002.stdout-mingw32 new file mode 100644 index 0000000000..e05b87a7eb --- /dev/null +++ b/libraries/base/tests/IO/hClose002.stdout-mingw32 @@ -0,0 +1,4 @@ +Left hClose002.tmp: hClose: invalid argument (The handle is invalid.) +Right () +Right () +Right () diff --git a/libraries/base/tests/IO/openFile002.stderr-mingw32 b/libraries/base/tests/IO/openFile002.stderr-mingw32 new file mode 100644 index 0000000000..a75cc496f4 --- /dev/null +++ b/libraries/base/tests/IO/openFile002.stderr-mingw32 @@ -0,0 +1 @@ +openFile002.exe: nonexistent: openFile: does not exist (The system cannot find the file specified.) diff --git a/libraries/base/tests/IO/openFile002.stderr-mingw32-2 b/libraries/base/tests/IO/openFile002.stderr-mingw32-2 new file mode 100644 index 0000000000..b011f34146 --- /dev/null +++ b/libraries/base/tests/IO/openFile002.stderr-mingw32-2 @@ -0,0 +1 @@ +openFile002: nonexistent: openFile: does not exist (No such file or directory) diff --git a/libraries/base/tests/IO/openFile003.stdout-mingw32 b/libraries/base/tests/IO/openFile003.stdout-mingw32 index 77ad0a860a..b808fccc3f 100644 --- a/libraries/base/tests/IO/openFile003.stdout-mingw32 +++ b/libraries/base/tests/IO/openFile003.stdout-mingw32 @@ -1,4 +1,4 @@ -Left openFile003Dir: openFile: permission denied (Permission denied) -Left openFile003Dir: openFile: permission denied (Permission denied) -Left openFile003Dir: openFile: permission denied (Permission denied) -Left openFile003Dir: openFile: permission denied (Permission denied) +Left openFile003Dir: openFile: permission denied (Access is denied.) +Left openFile003Dir: openFile: permission denied (Access is denied.) +Left openFile003Dir: openFile: permission denied (Access is denied.) +Left openFile003Dir: openFile: permission denied (Access is denied.) diff --git a/libraries/base/tests/IO/openFile009.hs b/libraries/base/tests/IO/openFile009.hs new file mode 100644 index 0000000000..b3aa8c9f9b --- /dev/null +++ b/libraries/base/tests/IO/openFile009.hs @@ -0,0 +1,19 @@ +import System.IO +import System.Cmd +import System.FilePath +import Text.Printf +import System.Directory +import Control.Monad + +testfile = "openFile009_testfile" + +-- Make sure opening with append doesn't truncate files. +main = do + h <- openFile testfile WriteMode + hPutStr h "Hello" + hClose h + h <- openFile testfile AppendMode + hPutStr h " World!" + hClose h + s <- readFile testfile + putStrLn s diff --git a/libraries/base/tests/IO/openFile009.stdout b/libraries/base/tests/IO/openFile009.stdout new file mode 100644 index 0000000000..980a0d5f19 --- /dev/null +++ b/libraries/base/tests/IO/openFile009.stdout @@ -0,0 +1 @@ +Hello World! diff --git a/libraries/base/tests/Numeric/all.T b/libraries/base/tests/Numeric/all.T index 74d4c06514..0d6d0728d1 100644 --- a/libraries/base/tests/Numeric/all.T +++ b/libraries/base/tests/Numeric/all.T @@ -11,7 +11,7 @@ test('num008', normal, compile_and_run, ['']) test('num009', [ when(fast(), skip) # , when(wordsize(32), expect_broken(15062)) , when(platform('powerpc64le-unknown-linux'), expect_broken(13634))], - compile_and_run, [opts]) + compile_and_run, ['']) test('num010', when(platform('i386-apple-darwin'), expect_broken_for(7043, ['ghci'])), compile_and_run, diff --git a/libraries/base/tests/tempfiles.stdout-mingw32 b/libraries/base/tests/tempfiles.stdout-mingw32 deleted file mode 100644 index 5d7b23db0e..0000000000 --- a/libraries/base/tests/tempfiles.stdout-mingw32 +++ /dev/null @@ -1,12 +0,0 @@ -.no_prefix.hs -True -False -no_suffix -True -False -one_suffix.hs -True -False -two_suffixes.hs.blah -True -False diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index bb9d440b37..8a959fc2a0 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -229,7 +229,15 @@ data GenClosure b } -- | An @MVar#@, with a queue of thread state objects blocking on them - | MVarClosure + | MVarClosure + { info :: !StgInfoTable + , queueHead :: !b -- ^ Pointer to head of queue + , queueTail :: !b -- ^ Pointer to tail of queue + , value :: !b -- ^ Pointer to closure + } + + -- | An @IOPort#@, with a queue of thread state objects blocking on them + | IOPortClosure { info :: !StgInfoTable , queueHead :: !b -- ^ Pointer to head of queue , queueTail :: !b -- ^ Pointer to tail of queue @@ -340,6 +348,7 @@ allClosures (MutArrClosure {..}) = mccPayload allClosures (SmallMutArrClosure {..}) = mccPayload allClosures (MutVarClosure {..}) = [var] allClosures (MVarClosure {..}) = [queueHead,queueTail,value] +allClosures (IOPortClosure {..}) = [queueHead,queueTail,value] allClosures (FunClosure {..}) = ptrArgs allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer, link] diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index e68b09c944..bca9225023 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.1 +cabal-version: 2.2 name: ghc-prim version: 0.7.0 -- NOTE: Don't forget to update ./changelog.md diff --git a/libraries/haskeline b/libraries/haskeline -Subproject d3885e4bc1dfe6b06829871361bf9330414fc9e +Subproject 5f16b76168f13c6413413386efc44fb1152048d diff --git a/libraries/process b/libraries/process -Subproject 8f4ecebb6578a179a6c04074cb06600683e2e50 +Subproject cb1d1a6ead68f0e1b209277e79ec608980e9ac8 diff --git a/rts/FileLock.c b/rts/FileLock.c index 351d2a58f7..4509de1a42 100644 --- a/rts/FileLock.c +++ b/rts/FileLock.c @@ -25,10 +25,10 @@ typedef struct { // Two hash tables. The first maps objects (device/inode pairs) to // Lock objects containing the number of active readers or writers. The -// second maps file descriptors to lock objects, so that we can unlock -// by FD without needing to fstat() again. +// second maps file descriptors or file handles to lock objects, so that we can +// unlock by FD or HANDLE without needing to fstat() again. static HashTable *obj_hash; -static HashTable *fd_hash; +static HashTable *key_hash; #if defined(THREADED_RTS) static Mutex file_lock_mutex; @@ -53,7 +53,7 @@ void initFileLocking(void) { obj_hash = allocHashTable(); - fd_hash = allocHashTable(); /* ordinary word-based table */ + key_hash = allocHashTable(); /* ordinary word-based table */ #if defined(THREADED_RTS) initMutex(&file_lock_mutex); #endif @@ -69,14 +69,14 @@ void freeFileLocking(void) { freeHashTable(obj_hash, freeLock); - freeHashTable(fd_hash, NULL); + freeHashTable(key_hash, NULL); #if defined(THREADED_RTS) closeMutex(&file_lock_mutex); #endif } int -lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) +lockFile(StgWord64 id, StgWord64 dev, StgWord64 ino, int for_writing) { Lock key, *lock; @@ -94,7 +94,7 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) lock->inode = ino; lock->readers = for_writing ? -1 : 1; insertHashTable_(obj_hash, (StgWord)lock, (void *)lock, hashLock); - insertHashTable(fd_hash, fd, lock); + insertHashTable(key_hash, id, lock); RELEASE_LOCK(&file_lock_mutex); return 0; } @@ -105,7 +105,7 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) RELEASE_LOCK(&file_lock_mutex); return -1; } - insertHashTable(fd_hash, fd, lock); + insertHashTable(key_hash, id, lock); lock->readers++; RELEASE_LOCK(&file_lock_mutex); return 0; @@ -113,15 +113,15 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) } int -unlockFile(int fd) +unlockFile(StgWord64 id) { Lock *lock; ACQUIRE_LOCK(&file_lock_mutex); - lock = lookupHashTable(fd_hash, fd); + lock = lookupHashTable(key_hash, id); if (lock == NULL) { - // errorBelch("unlockFile: fd %d not found", fd); + // errorBelch("unlockFile: key %d not found", key); // This is normal: we didn't know when calling unlockFile // whether this FD referred to a locked file or not. RELEASE_LOCK(&file_lock_mutex); @@ -138,7 +138,7 @@ unlockFile(int fd) removeHashTable_(obj_hash, (StgWord)lock, NULL, hashLock, cmpLocks); stgFree(lock); } - removeHashTable(fd_hash, fd, NULL); + removeHashTable(key_hash, id, NULL); RELEASE_LOCK(&file_lock_mutex); return 0; diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 1c1de089dc..b8df323c8b 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -17,8 +17,8 @@ #if defined(__PIC__) import pthread_mutex_unlock; #endif -import EnterCriticalSection; -import LeaveCriticalSection; +import AcquireSRWLockExclusive; +import ReleaseSRWLockExclusives; /* Stack/Heap Check Failure * ------------------------ diff --git a/rts/Linker.c b/rts/Linker.c index 443de6a356..4b551f0073 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1681,12 +1681,10 @@ int ocTryLoad (ObjectCode* oc) { are to be loaded by this call. This call is intended to have no side-effects when a non-duplicate - symbol is re-inserted. A symbol is only a duplicate if the object file - it is defined in has had it's relocations resolved. A resolved object - file means the symbols inside it are required. + symbol is re-inserted. - The symbol address is not used to distinguish symbols. Duplicate symbols - are distinguished by name, oc and attributes (weak symbols etc). + We set the Address to NULL since that is not used to distinguish + symbols. Duplicate symbols are distinguished by name and oc. */ int x; Symbol_t symbol; diff --git a/rts/Prelude.h b/rts/Prelude.h index c6971677af..d2511b2fc3 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -43,6 +43,7 @@ PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure); PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactFunction_closure); PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactPinned_closure); PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactMutable_closure); +PRELUDE_CLOSURE(base_GHCziIOPort_doubleReadException_closure); PRELUDE_CLOSURE(base_ControlziExceptionziBase_nonTermination_closure); PRELUDE_CLOSURE(base_ControlziExceptionziBase_nestedAtomically_closure); PRELUDE_CLOSURE(base_GHCziEventziThread_blockedOnBadFD_closure); @@ -52,8 +53,12 @@ PRELUDE_CLOSURE(base_GHCziExceptionziType_overflowException_closure); PRELUDE_CLOSURE(base_GHCziConcziSync_runSparks_closure); PRELUDE_CLOSURE(base_GHCziConcziIO_ensureIOManagerIsRunning_closure); +PRELUDE_CLOSURE(base_GHCziConcziIO_interruptIOManager_closure); PRELUDE_CLOSURE(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure); PRELUDE_CLOSURE(base_GHCziConcziSignal_runHandlersPtr_closure); +#if defined(mingw32_HOST_OS) +PRELUDE_CLOSURE(base_GHCziEventziWindows_processRemoteCompletion_closure); +#endif PRELUDE_CLOSURE(base_GHCziTopHandler_flushStdHandles_closure); PRELUDE_CLOSURE(base_GHCziTopHandler_runMainIO_closure); @@ -85,8 +90,12 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define runSparks_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSync_runSparks_closure) #define ensureIOManagerIsRunning_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ensureIOManagerIsRunning_closure) +#define interruptIOManager_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_interruptIOManager_closure) #define ioManagerCapabilitiesChanged_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure) #define runHandlersPtr_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSignal_runHandlersPtr_closure) +#if defined(mingw32_HOST_OS) +#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(base_GHCziEventziWindows_processRemoteCompletion_closure) +#endif #define flushStdHandles_closure DLL_IMPORT_DATA_REF(base_GHCziTopHandler_flushStdHandles_closure) #define runMainIO_closure DLL_IMPORT_DATA_REF(base_GHCziTopHandler_runMainIO_closure) @@ -101,6 +110,8 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define cannotCompactMutable_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_cannotCompactMutable_closure) #define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure) #define nestedAtomically_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure) +#define doubleReadException DLL_IMPORT_DATA_REF(base_GHCziIOPort_doubleReadException_closure) + #define blockedOnBadFD_closure DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure) #define Czh_con_info DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_Czh_con_info) diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 1fd746edf6..1aa001c953 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -31,8 +31,10 @@ import pthread_mutex_unlock; #endif import CLOSURE base_ControlziExceptionziBase_nestedAtomically_closure; import CLOSURE base_GHCziIOziException_heapOverflow_closure; -import EnterCriticalSection; -import LeaveCriticalSection; +import CLOSURE base_GHCziIOziException_blockedIndefinitelyOnMVar_closure; +import CLOSURE base_GHCziIOPort_doubleReadException_closure; +import AcquireSRWLockExclusive; +import ReleaseSRWLockExclusive; import CLOSURE ghczmprim_GHCziTypes_False_closure; #if defined(PROFILING) import CLOSURE CCS_MAIN; @@ -1593,6 +1595,7 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); // Write barrier before we make the new MVAR_TSO_QUEUE // visible to other cores. + // See Note [Heap memory barriers] prim_write_barrier; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1761,6 +1764,7 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + //See Note [Heap memory barriers] prim_write_barrier; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1943,6 +1947,7 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) */ if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { + // Add MVar to mutable list if (info == stg_MVAR_CLEAN_info) { ccall dirty_MVAR(BaseReg "ptr", mvar "ptr", StgMVar_value(mvar)); } @@ -1960,6 +1965,7 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + //See Note [Heap memory barriers] prim_write_barrier; StgTSO__link(CurrentTSO) = q; @@ -1998,6 +2004,240 @@ stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ ) } /* ----------------------------------------------------------------------------- + * IOPort primitives + * + * readIOPort & writeIOPort work as follows. Firstly, an important invariant: + * + * Only one read and one write is allowed for an IOPort. + * Reading or writing to the same port twice will throw an exception. + * + * readIOPort: + * IOPort empty : then add ourselves to the blocking queue + * IOPort full : remove the value from the IOPort, and + * blocking queue empty : return + * blocking queue non-empty : perform the only blocked + * writeIOPort from the queue, and + * wake up the thread + * (IOPort is now empty) + * + * writeIOPort is just the dual of the above algorithm. + * + * How do we "perform a writeIOPort"? Well, By storing the value and prt on the + * stack, same way we do with MVars. Semantically the operations mutate the + * stack the same way so we will re-use the logic and datastructures for MVars + * for IOPort. See stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c + * for the stack layout, and the PerformPut and PerformTake macros below. We + * also re-use the closure types MVAR_CLEAN/_DIRTY for IOPort. + * + * The remaining caveats of MVar thus also apply for an IOPort. The main + * crucial difference between an MVar and IOPort is that the scheduler will not + * be allowed to interrupt a blocked IOPort just because it thinks there's a + * deadlock. This is especially crucial for the non-threaded runtime. + * + * To avoid double reads/writes we set only the head to a MVarTSOQueue when + * a reader queues up on a port. + * We set the tail to the port itself upon reading. We can do this + * since there can only be one reader/writer for the port. In contrast to MVars + * which do need to keep a list of blocked threads. + * + * This means IOPorts have these valid states and transitions: + * + ┌─────────┐ + │ Empty │ head == tail == value == END_TSO_QUEUE + ├─────────┤ + │ │ + write │ │ read + v v + value != END_TSO_QUEUE ┌─────────┐ ┌─────────┐ value == END_TSO_QUEUE + head == END_TSO_QUEUE │ full │ │ reading │ head == queue with single reader + tail == END_TSO_QUEUE └─────────┘ └─────────┘ tail == END_TSO_QUEUE + │ │ + read │ │ write + │ │ + v v + ┌──────────┐ value != END_TSO_QUEUE + │ Used │ head == END_TSO_QUEUE + └──────────┘ tail == ioport + + * + * -------------------------------------------------------------------------- */ + + +stg_readIOPortzh ( P_ ioport /* :: IOPort a */ ) +{ + W_ val, info, tso, q; + + LOCK_CLOSURE(ioport, info); + + /* If the Port is empty, put ourselves on the blocked readers + * list and wait until we're woken up. + */ + if (StgMVar_value(ioport) == stg_END_TSO_QUEUE_closure) { + + // There is or was already another reader, throw exception. + if (StgMVar_head(ioport) != stg_END_TSO_QUEUE_closure || + StgMVar_tail(ioport) != stg_END_TSO_QUEUE_closure) { + unlockClosure(ioport, info); + jump stg_raiseIOzh(base_GHCziIOPort_doubleReadException_closure); + } + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", ioport "ptr", StgMVar_value(ioport)); + } + + ALLOC_PRIM_WITH_CUSTOM_FAILURE + (SIZEOF_StgMVarTSOQueue, + unlockClosure(ioport, stg_MVAR_DIRTY_info); + GC_PRIM_P(stg_readIOPortzh, ioport)); + + q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1); + + // link = stg_END_TSO_QUEUE_closure since we check that + // there is no other reader above. + StgMVarTSOQueue_link(q) = stg_END_TSO_QUEUE_closure; + StgMVarTSOQueue_tso(q) = CurrentTSO; + + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + //See Note [Heap memory barriers] + prim_write_barrier; + + StgMVar_head(ioport) = q; + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = ioport; + StgTSO_why_blocked(CurrentTSO) = BlockedOnIOCompletion::I16; + + //Unlocks the closure as well + jump stg_block_readmvar(ioport); + + } + + //This way we can check of there has been a read already. + //Upon reading we set tail to indicate the port is now closed. + if (StgMVar_tail(ioport) == stg_END_TSO_QUEUE_closure) { + StgMVar_tail(ioport) = ioport; + StgMVar_head(ioport) = stg_END_TSO_QUEUE_closure; + } else { + //Or another thread has read already: Throw an exception. + unlockClosure(ioport, info); + jump stg_raiseIOzh(base_GHCziIOPort_doubleReadException_closure); + } + + val = StgMVar_value(ioport); + + unlockClosure(ioport, info); + return (val); +} + +stg_writeIOPortzh ( P_ ioport, /* :: IOPort a */ + P_ val, /* :: a */ ) +{ + W_ info, tso, q; + + LOCK_CLOSURE(ioport, info); + + /* If there is already a value in the port, then raise an exception + as it's the second write. + Correct usages of IOPort should never have a second + write. */ + if (StgMVar_value(ioport) != stg_END_TSO_QUEUE_closure) { + unlockClosure(ioport, info); + jump stg_raiseIOzh(base_GHCziIOPort_doubleReadException_closure); + return (0); + } + + // We are going to mutate the closure, make sure its current pointers + // are marked. + if (info == stg_MVAR_CLEAN_info) { + ccall update_MVAR(BaseReg "ptr", ioport "ptr", StgMVar_value(ioport) "ptr"); + } + + q = StgMVar_head(ioport); +loop: + if (q == stg_END_TSO_QUEUE_closure) { + /* No takes, the IOPort is now full. */ + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", ioport "ptr"); + } + StgMVar_value(ioport) = val; + + unlockClosure(ioport, stg_MVAR_DIRTY_info); + return (1); + } + //Possibly IND added by removeFromMVarBlockedQueue + if (StgHeader_info(q) == stg_IND_info || + StgHeader_info(q) == stg_MSG_NULL_info) { + q = StgInd_indirectee(q); + goto loop; + } + + // There is a readIOPort waiting: wake it up + tso = StgMVarTSOQueue_tso(q); + + // Assert no read has happened yet. + ASSERT(StgMVar_tail(ioport) == stg_END_TSO_QUEUE_closure); + // And there is only one reader queued up. + ASSERT(StgMVarTSOQueue_link(q) == stg_END_TSO_QUEUE_closure); + + // We perform the read here, so set tail/head accordingly. + StgMVar_head(ioport) = stg_END_TSO_QUEUE_closure; + StgMVar_tail(ioport) = ioport; + + // In contrast to MVars we do not need to move on to the + // next element in the waiting list here, as there can only ever + // be one thread blocked on a port. + + ASSERT(StgTSO_block_info(tso) == ioport); + // save why_blocked here, because waking up the thread destroys + // this information + W_ why_blocked; + why_blocked = TO_W_(StgTSO_why_blocked(tso)); + + // actually perform the takeMVar + W_ stack; + stack = StgTSO_stackobj(tso); + PerformTake(stack, val); + + // indicate that the operation has now completed. + StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; + + if (TO_W_(StgStack_dirty(stack)) == 0) { + ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); + } + + ccall tryWakeupThread(MyCapability() "ptr", tso); + + // For MVars we loop here, waking up all readers. + // IOPorts however can only have on reader. So we are done + // at this point. + + //Either there was no reader queued, or he must have been + //blocked on BlockedOnIOCompletion + ASSERT(why_blocked == BlockedOnIOCompletion); + + unlockClosure(ioport, info); + return (1); +} +/* ----------------------------------------------------------------------------- + IOPort primitives + -------------------------------------------------------------------------- */ + +stg_newIOPortzh ( gcptr init ) +{ + W_ ioport; + + ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newIOPortzh); + + ioport = Hp - SIZEOF_StgMVar + WDS(1); + SET_HDR(ioport, stg_MVAR_DIRTY_info,CCCS); + // MVARs start dirty: generation 0 has no mutable list + StgMVar_head(ioport) = stg_END_TSO_QUEUE_closure; + StgMVar_tail(ioport) = stg_END_TSO_QUEUE_closure; + StgMVar_value(ioport) = stg_END_TSO_QUEUE_closure; + + return (ioport); +} + +/* ----------------------------------------------------------------------------- Stable pointer primitives ------------------------------------------------------------------------- */ diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index e8a6a81747..719c05435d 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -174,11 +174,11 @@ throwToSelf (Capability *cap, StgTSO *tso, StgClosure *exception) - or it is masking exceptions (TSO_BLOCKEX) - Currently, if the target is BlockedOnMVar, BlockedOnSTM, or - BlockedOnBlackHole then we acquire ownership of the TSO by locking - its parent container (e.g. the MVar) and then raise the exception. - We might change these cases to be more message-passing-like in the - future. + Currently, if the target is BlockedOnMVar, BlockedOnSTM, + BlockedOnIOCompletion or BlockedOnBlackHole then we acquire ownership of the + TSO by locking its parent container (e.g. the MVar) and then raise the + exception. We might change these cases to be more message-passing-like in + the future. Returns: @@ -343,6 +343,7 @@ check_target: case BlockedOnMVar: case BlockedOnMVarRead: + case BlockedOnIOCompletion: { /* To establish ownership of this TSO, we need to acquire a @@ -367,7 +368,9 @@ check_target: // we have the MVar, let's check whether the thread // is still blocked on the same MVar. - if ((target->why_blocked != BlockedOnMVar && target->why_blocked != BlockedOnMVarRead) + if ((target->why_blocked != BlockedOnMVar + && target->why_blocked != BlockedOnMVarRead + && target->why_blocked != BlockedOnIOCompletion) || (StgMVar *)target->block_info.closure != mvar) { unlockClosure((StgClosure *)mvar, info); goto retry; @@ -679,6 +682,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) case BlockedOnMVar: case BlockedOnMVarRead: + case BlockedOnIOCompletion: removeFromMVarBlockedQueue(tso); goto done; diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 6180f42e39..3963e6d0d5 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -35,6 +35,7 @@ #endif #include <fs_rts.h> +#include <stdbool.h> // Flag Structure RTS_FLAGS RtsFlags; @@ -254,6 +255,16 @@ void initRtsFlagsDefaults(void) RtsFlags.MiscFlags.internalCounters = false; RtsFlags.MiscFlags.linkerAlwaysPic = DEFAULT_LINKER_ALWAYS_PIC; RtsFlags.MiscFlags.linkerMemBase = 0; +#if defined(DEFAULT_NATIVE_IO_MANAGER) + RtsFlags.MiscFlags.ioManager = IO_MNGR_NATIVE; +#else + RtsFlags.MiscFlags.ioManager = IO_MNGR_POSIX; +#endif +#if defined(THREADED_RTS) && defined(mingw32_HOST_OS) + RtsFlags.MiscFlags.numIoWorkerThreads = getNumberOfProcessors(); +#else + RtsFlags.MiscFlags.numIoWorkerThreads = 1; +#endif #if defined(THREADED_RTS) RtsFlags.ParFlags.nCapabilities = 1; @@ -474,7 +485,14 @@ usage_text[] = { " fatal error. When symbols are available an attempt will be", " made to resolve addresses to names. (default: yes)", #endif +" --io-manager=<native|posix>", +" The I/O manager subsystem to use. (default: posix)", #if defined(THREADED_RTS) +#if defined(mingw32_HOST_OS) +" --io-manager-threads=<num>", +" The number of worker threads to use in the native I/O manager to", +" handle completion events. (defualt: num cores)", +#endif " -e<n> Maximum number of outstanding local sparks (default: 4096)", #endif #if defined(x86_64_HOST_ARCH) @@ -933,6 +951,16 @@ error = true; OPTION_SAFE; RtsFlags.MiscFlags.internalCounters = true; } + else if (strequal("io-manager=native", + &rts_argv[arg][2])) { + OPTION_UNSAFE; + RtsFlags.MiscFlags.ioManager = IO_MNGR_NATIVE; + } + else if (strequal("io-manager=posix", + &rts_argv[arg][2])) { + OPTION_UNSAFE; + RtsFlags.MiscFlags.ioManager = IO_MNGR_POSIX; + } else if (strequal("info", &rts_argv[arg][2])) { OPTION_SAFE; @@ -945,6 +973,31 @@ error = true; RtsFlags.GcFlags.useNonmoving = true; } #if defined(THREADED_RTS) +#if defined(mingw32_HOST_OS) + else if (!strncmp("io-manager-threads", + &rts_argv[arg][2], 18)) { + OPTION_SAFE; + uint32_t num; + if (rts_argv[arg][20] == '=') { + num = (StgWord)strtol(rts_argv[arg]+21, + (char **) NULL, 10); + } else { + errorBelch("%s: Expected number of threads to use.", + rts_argv[arg]); + error = true; + break; + } + + if (num < 1) { + errorBelch("%s: Expected number of threads to be at least 1.", + rts_argv[arg]); + error = true; + break; + } + + RtsFlags.MiscFlags.numIoWorkerThreads = num; + } +#endif else if (!strncmp("numa", &rts_argv[arg][2], 4)) { if (!osBuiltWithNumaSupport()) { errorBelch("%s: This GHC build was compiled without NUMA support.", @@ -2460,3 +2513,16 @@ built in the -debug, -eventlog, -prof ways. And even if they do, the damage should be limited to DOS, information disclosure and writing files like <progname>.eventlog, not arbitrary files. */ + +/* ---------------------------------------------------------------------------- + Helper utilities to query state. + ------------------------------------------------------------------------- */ + +bool is_io_mng_native_p (void) +{ +#if defined(mingw32_HOST_OS) + return RtsFlags.MiscFlags.ioManager == IO_MNGR_NATIVE; +#else + return false; +#endif +} diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h index c36c64a63b..bfcc43af42 100644 --- a/rts/RtsFlags.h +++ b/rts/RtsFlags.h @@ -10,6 +10,7 @@ #pragma once #include "BeginPrivate.h" +#include <stdbool.h> /* Routines that operate-on/to-do-with RTS flags: */ @@ -21,6 +22,7 @@ char** getUTF8Args(int* argc); void initRtsFlagsDefaults (void); void setupRtsFlags (int *argc, char *argv[], RtsConfig rtsConfig); void freeRtsArgs (void); +bool is_io_mng_native_p (void); extern RtsConfig rtsConfig; diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index f73d0bd742..a52c02190e 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -46,11 +46,13 @@ #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) -#include "win32/AsyncIO.h" +#include "win32/AsyncMIO.h" +#include "win32/AsyncWinIO.h" #endif #if defined(mingw32_HOST_OS) #include <fenv.h> +#include <windows.h> #else #include "posix/TTY.h" #endif @@ -120,6 +122,21 @@ void fpreset(void) { _fpreset(); } #endif + +/* Set the console's CodePage to UTF-8 if using the new I/O manager and the CP + is still the default one. */ +static void +initConsoleCP (void) +{ + /* Check if the codepage is still the system default ANSI codepage. */ + if (GetConsoleCP () == GetOEMCP ()) { + if (! SetConsoleCP (CP_UTF8)) + errorBelch ("Unable to set console CodePage, Unicode output may be " + "garbled.\n"); + else + IF_DEBUG (scheduler, debugBelch ("Codepage set to UTF-8.\n")); + } +} #endif /* ----------------------------------------------------------------------------- @@ -220,6 +237,12 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) #endif /* DEBUG */ } + /* Initialize console Codepage. */ +#if defined(mingw32_HOST_OS) + if (is_io_mng_native_p()) + initConsoleCP(); +#endif + /* Initialise the stats department, phase 1 */ initStats1(); @@ -277,10 +300,13 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) getStablePtr((StgPtr)nestedAtomically_closure); getStablePtr((StgPtr)runSparks_closure); getStablePtr((StgPtr)ensureIOManagerIsRunning_closure); + getStablePtr((StgPtr)interruptIOManager_closure); getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure); #if !defined(mingw32_HOST_OS) getStablePtr((StgPtr)blockedOnBadFD_closure); getStablePtr((StgPtr)runHandlersPtr_closure); +#else + getStablePtr((StgPtr)processRemoteCompletion_closure); #endif // Initialize the top-level handler system @@ -316,7 +342,10 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) - startupAsyncIO(); + if (is_io_mng_native_p()) + startupAsyncWinIO(); + else + startupAsyncIO(); #endif x86_init_fpu(); @@ -498,7 +527,10 @@ hs_exit_(bool wait_foreign) #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) - shutdownAsyncIO(wait_foreign); + if (is_io_mng_native_p()) + shutdownAsyncWinIO(wait_foreign); + else + shutdownAsyncIO(wait_foreign); #endif /* free hash table storage */ diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index ff32932ea9..6432cbdcdd 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -26,6 +26,7 @@ #include <io.h> #include <windows.h> #include <shfolder.h> /* SHGetFolderPathW */ +#include "win32/AsyncWinIO.h" #endif #if defined(openbsd_HOST_OS) @@ -142,11 +143,15 @@ /* see Note [Symbols for MinGW's printf] */ \ SymI_HasProto(_lock_file) \ SymI_HasProto(_unlock_file) \ + SymI_HasProto(__mingw_vsnwprintf) \ + /* ^^ Need to figure out why this is needed. */ \ /* See Note [_iob_func symbol] */ \ RTS_WIN64_ONLY(SymI_HasProto_redirect( \ __imp___acrt_iob_func, __rts_iob_func, true)) \ RTS_WIN32_ONLY(SymI_HasProto_redirect( \ - __imp____acrt_iob_func, __rts_iob_func, true)) + __imp____acrt_iob_func, __rts_iob_func, true)) \ + SymI_HasProto(__mingw_vsnwprintf) + /* ^^ Need to figure out why this is needed. */ #define RTS_MINGW_COMPAT_SYMBOLS \ SymI_HasProto_deprecated(access) \ @@ -337,11 +342,15 @@ SymI_HasProto(blockUserSignals) \ SymI_HasProto(unblockUserSignals) #else -#define RTS_USER_SIGNALS_SYMBOLS \ - SymI_HasProto(ioManagerWakeup) \ - SymI_HasProto(sendIOManagerEvent) \ - SymI_HasProto(readIOManagerEvent) \ - SymI_HasProto(getIOManagerEvent) \ +#define RTS_USER_SIGNALS_SYMBOLS \ + SymI_HasProto(registerIOCPHandle) \ + SymI_HasProto(getOverlappedEntries) \ + SymI_HasProto(completeSynchronousRequest) \ + SymI_HasProto(registerAlertableWait) \ + SymI_HasProto(ioManagerWakeup) \ + SymI_HasProto(sendIOManagerEvent) \ + SymI_HasProto(readIOManagerEvent) \ + SymI_HasProto(getIOManagerEvent) \ SymI_HasProto(console_handler) #endif @@ -706,6 +715,9 @@ SymI_HasProto(stg_newMVarzh) \ SymI_HasProto(stg_newMutVarzh) \ SymI_HasProto(stg_newTVarzh) \ + SymI_HasProto(stg_readIOPortzh) \ + SymI_HasProto(stg_writeIOPortzh) \ + SymI_HasProto(stg_newIOPortzh) \ SymI_HasProto(stg_noDuplicatezh) \ SymI_HasProto(stg_atomicModifyMutVar2zh) \ SymI_HasProto(stg_atomicModifyMutVarzuzh) \ diff --git a/rts/Schedule.c b/rts/Schedule.c index ce1a1fc060..6b10326859 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -34,6 +34,7 @@ #include "AwaitEvent.h" #if defined(mingw32_HOST_OS) #include "win32/IOManager.h" +#include "win32/AsyncWinIO.h" #endif #include "Trace.h" #include "RaiseAsync.h" @@ -198,6 +199,7 @@ schedule (Capability *initialCapability, Task *task) bool ready_to_gc; cap = initialCapability; + t = NULL; // Pre-condition: this task owns initialCapability. // The sched_mutex is *NOT* held @@ -301,8 +303,13 @@ schedule (Capability *initialCapability, Task *task) // Additionally, it is not fatal for the // threaded RTS to reach here with no threads to run. // + // Since IOPorts have no deadlock avoidance guarantees you may also reach + // this point when blocked on an IO Port. If this is the case the only + // thing that could unblock it is an I/O event. + // // win32: might be here due to awaitEvent() being abandoned - // as a result of a console event having been delivered. + // as a result of a console event having been delivered or as a result of + // waiting on an async I/O to complete with WinIO. #if defined(THREADED_RTS) scheduleYield(&cap,task); @@ -310,9 +317,16 @@ schedule (Capability *initialCapability, Task *task) if (emptyRunQueue(cap)) continue; // look for work again #endif -#if !defined(THREADED_RTS) && !defined(mingw32_HOST_OS) +#if !defined(THREADED_RTS) if ( emptyRunQueue(cap) ) { +#if defined(mingw32_HOST_OS) + /* Notify the I/O manager that we have nothing to do. If there are + any outstanding I/O requests we'll block here. If there are not + then this is a user error and we will abort soon. */ + awaitEvent (emptyRunQueue(cap)); +#else ASSERT(sched_state >= SCHED_INTERRUPTING); +#endif } #endif @@ -622,6 +636,9 @@ schedulePreLoop(void) static void scheduleFindWork (Capability **pcap) { +#if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) + queueIOThread(); +#endif scheduleStartSignalHandlers(*pcap); scheduleProcessInbox(pcap); @@ -928,6 +945,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task) */ if (recent_activity != ACTIVITY_INACTIVE) return; #endif + if (task->incall->tso && task->incall->tso->why_blocked == BlockedOnIOCompletion) return; debugTrace(DEBUG_sched, "deadlocked, forcing major GC..."); @@ -980,6 +998,10 @@ scheduleDetectDeadlock (Capability **pcap, Task *task) throwToSingleThreaded(cap, task->incall->tso, (StgClosure *)nonTermination_closure); return; + case BlockedOnIOCompletion: + /* We're blocked waiting for an external I/O call, let's just + chill for a bit. */ + return; default: barf("deadlock: main thread blocked in a strange way"); } @@ -2555,6 +2577,14 @@ scheduleThread(Capability *cap, StgTSO *tso) } void +scheduleThreadNow(Capability *cap, StgTSO *tso) +{ + // The thread goes at the *beginning* of the run-queue, + // in order to execute it as soon as possible. + pushOnRunQueue(cap,tso); +} + +void scheduleThreadOn(Capability *cap, StgWord cpu USED_IF_THREADS, StgTSO *tso) { tso->flags |= TSO_LOCKED; // we requested explicit affinity; don't @@ -2676,9 +2706,10 @@ initScheduler(void) sched_state = SCHED_RUNNING; recent_activity = ACTIVITY_YES; -#if defined(THREADED_RTS) + /* Initialise the mutex and condition variables used by * the scheduler. */ +#if defined(THREADED_RTS) initMutex(&sched_mutex); initMutex(&sync_finished_mutex); initCondition(&sync_finished_cond); @@ -3164,6 +3195,11 @@ resurrectThreads (StgTSO *threads) throwToSingleThreaded(cap, tso, (StgClosure *)blockedIndefinitelyOnSTM_closure); break; + case BlockedOnIOCompletion: + /* I/O Ports may not be reachable by the GC as they may be getting + * notified by the RTS. As such this call should be treated as if + * it is masking the exception. */ + continue; case NotBlocked: /* This might happen if the thread was blocked on a black hole * belonging to a thread that we've just woken up (raiseAsync diff --git a/rts/Schedule.h b/rts/Schedule.h index 2d8d813464..a550a6763a 100644 --- a/rts/Schedule.h +++ b/rts/Schedule.h @@ -27,6 +27,10 @@ void markScheduler (evac_fn evac, void *user); // Place a new thread on the run queue of the current Capability void scheduleThread (Capability *cap, StgTSO *tso); +// Place a new thread on the run queue of the current Capability +// at the front of the queue. +void scheduleThreadNow (Capability *cap, StgTSO *tso); + // Place a new thread on the run queue of a specified Capability // (cap is the currently owned Capability, cpu is the number of // the desired Capability). @@ -176,7 +180,7 @@ pushOnRunQueue (Capability *cap, StgTSO *tso) INLINE_HEADER StgTSO * popRunQueue (Capability *cap) { - ASSERT(cap->n_run_queue != 0); + ASSERT(cap->n_run_queue > 0); StgTSO *t = cap->run_queue_hd; ASSERT(t != END_TSO_QUEUE); cap->run_queue_hd = t->_link; diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 4293dfb787..7a8f20dded 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -15,8 +15,8 @@ import pthread_mutex_lock; import ghczmprim_GHCziTypes_Czh_info; import ghczmprim_GHCziTypes_Izh_info; -import EnterCriticalSection; -import LeaveCriticalSection; +import AcquireSRWLockExclusive; +import ReleaseSRWLockExclusive; /* ---------------------------------------------------------------------------- Stack underflow diff --git a/rts/Threads.c b/rts/Threads.c index 22d58bb48b..54c703963e 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -288,6 +288,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) switch (tso->why_blocked) { + case BlockedOnIOCompletion: case BlockedOnMVar: case BlockedOnMVarRead: { @@ -868,12 +869,16 @@ printThreadBlockage(StgTSO *tso) debugBelch("is blocked until %ld", (long)(tso->block_info.target)); break; #endif + break; case BlockedOnMVar: debugBelch("is blocked on an MVar @ %p", tso->block_info.closure); break; case BlockedOnMVarRead: debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure); break; + case BlockedOnIOCompletion: + debugBelch("is blocked on I/O Completion port @ %p", tso->block_info.closure); + break; case BlockedOnBlackHole: debugBelch("is blocked on a black hole %p", ((StgBlockingQueue*)tso->block_info.bh->bh)); diff --git a/rts/Trace.c b/rts/Trace.c index b35be3c1e7..6d77cc1254 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -22,6 +22,7 @@ #include "Threads.h" #include "Printer.h" #include "RtsFlags.h" +#include "ThreadLabels.h" #if defined(HAVE_UNISTD_H) #include <unistd.h> @@ -164,6 +165,7 @@ static char *thread_stop_reasons[] = { [6 + BlockedOnSTM] = "blocked on STM", [6 + BlockedOnDoProc] = "blocked on asyncDoProc", [6 + BlockedOnCCall] = "blocked on a foreign call", + [6 + BlockedOnIOCompletion] = "blocked on I/O Completion port", [6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)", [6 + BlockedOnMsgThrowTo] = "blocked on throwTo", [6 + ThreadMigrating] = "migrating" @@ -179,45 +181,50 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, ACQUIRE_LOCK(&trace_utx); tracePreface(); + char *threadLabel = (char *)lookupThreadLabel(tso->id); + if(!threadLabel) + { + threadLabel = ""; + } switch (tag) { case EVENT_CREATE_THREAD: // (cap, thread) - debugBelch("cap %d: created thread %" FMT_Word "\n", - cap->no, (W_)tso->id); + debugBelch("cap %d: created thread %" FMT_Word "[\"%s\"]" "\n", + cap->no, (W_)tso->id, threadLabel); break; case EVENT_RUN_THREAD: // (cap, thread) - debugBelch("cap %d: running thread %" FMT_Word " (%s)\n", - cap->no, (W_)tso->id, what_next_strs[tso->what_next]); + debugBelch("cap %d: running thread %" FMT_Word "[\"%s\"]"" (%s)\n", + cap->no, (W_)tso->id, threadLabel, what_next_strs[tso->what_next]); break; case EVENT_THREAD_RUNNABLE: // (cap, thread) - debugBelch("cap %d: thread %" FMT_Word " appended to run queue\n", - cap->no, (W_)tso->id); + debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]"" appended to run queue\n", + cap->no, (W_)tso->id, threadLabel); break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - debugBelch("cap %d: thread %" FMT_Word " migrating to cap %d\n", - cap->no, (W_)tso->id, (int)info1); + debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " migrating to cap %d\n", + cap->no, (W_)tso->id, threadLabel, (int)info1); break; case EVENT_THREAD_WAKEUP: // (cap, thread, info1_cap) - debugBelch("cap %d: waking up thread %" FMT_Word " on cap %d\n", - cap->no, (W_)tso->id, (int)info1); + debugBelch("cap %d: waking up thread %" FMT_Word "[\"%s\"]" " on cap %d\n", + cap->no, (W_)tso->id, threadLabel, (int)info1); break; case EVENT_STOP_THREAD: // (cap, thread, status) if (info1 == 6 + BlockedOnBlackHole) { - debugBelch("cap %d: thread %" FMT_Word " stopped (blocked on black hole owned by thread %lu)\n", - cap->no, (W_)tso->id, (long)info2); + debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " stopped (blocked on black hole owned by thread %lu)\n", + cap->no, (W_)tso->id, threadLabel, (long)info2); } else if (info1 == StackOverflow) { - debugBelch("cap %d: thead %" FMT_Word + debugBelch("cap %d: thead %" FMT_Word "[\"%s\"]" " stopped (stack overflow, size %lu)\n", - cap->no, (W_)tso->id, (long)info2); + cap->no, (W_)tso->id, threadLabel, (long)info2); } else { - debugBelch("cap %d: thread %" FMT_Word " stopped (%s)\n", - cap->no, (W_)tso->id, thread_stop_reasons[info1]); + debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " stopped (%s)\n", + cap->no, (W_)tso->id, threadLabel, thread_stop_reasons[info1]); } break; default: - debugBelch("cap %d: thread %" FMT_Word ": event %d\n\n", - cap->no, (W_)tso->id, tag); + debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" ": event %d\n\n", + cap->no, (W_)tso->id, threadLabel, tag); break; } diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c index 8bf58c11ee..636737aa0f 100644 --- a/rts/TraverseHeap.c +++ b/rts/TraverseHeap.c @@ -1250,6 +1250,7 @@ inner_loop: traversePushClosure(ts, (StgClosure *) tso->trec, c, child_data); if ( tso->why_blocked == BlockedOnMVar || tso->why_blocked == BlockedOnMVarRead + || tso->why_blocked == BlockedOnIOCompletion || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo ) { diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index e3597cd73c..11e8a5e0b6 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -1484,6 +1484,7 @@ void printAndClearEventBuf (EventsBuf *ebuf) "printAndClearEventLog: could not flush event log\n" ); resetEventsBuf(ebuf); + flushEventLog(); return; } diff --git a/rts/eventlog/EventLogWriter.c b/rts/eventlog/EventLogWriter.c index 5387f932eb..047c211db4 100644 --- a/rts/eventlog/EventLogWriter.c +++ b/rts/eventlog/EventLogWriter.c @@ -122,6 +122,8 @@ writeEventLogFile(void *eventlog, size_t eventlog_size) begin += written; } release_event_log_lock(); + + flushEventLogFile (); return true; } diff --git a/rts/ghc.mk b/rts/ghc.mk index 7e7747b485..32c49d9099 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -22,7 +22,7 @@ rts_VERSION = 1.0 # Minimum supported Windows version. # These numbers can be found at: # https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx -# If we're compiling on windows, enforce that we only support Vista SP1+ +# If we're compiling on windows, enforce that we only support Windows 7+ # Adding this here means it doesn't have to be done in individual .c files # and also centralizes the versioning. rts_WINVER = 0x06010000 @@ -205,7 +205,7 @@ rts_dist_$1_CC_OPTS += -DRtsWay=\"rts_$1\" # Adding this here means it doesn't have to be done in individual .c files # and also centralizes the versioning. ifeq "$$(TargetOS_CPP)" "mingw32" -rts_dist_$1_CC_OPTS += -DWINVER=$(rts_WINVER) +rts_dist_$1_CC_OPTS += -D_WIN32_WINNT=$(rts_WINVER) endif ifneq "$$(UseSystemLibFFI)" "YES" diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c index f494eee567..6585c36bf0 100644 --- a/rts/linker/PEi386.c +++ b/rts/linker/PEi386.c @@ -2060,7 +2060,6 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl) sym = lookupSymbolInDLLs(lbl); return sym; // might be NULL if not found } else { -#if defined(mingw32_HOST_OS) // If Windows, perform initialization of uninitialized // Symbols from the C runtime which was loaded above. // We do this on lookup to prevent the hit when @@ -2093,7 +2092,6 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl) clearImportSymbol (pinfo->owner, lbl); return pinfo->value; } -#endif return loadSymbol(lbl, pinfo); } } diff --git a/rts/package.conf.in b/rts/package.conf.in index 45866a1ecd..8b7390865b 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -97,6 +97,7 @@ ld-options: , "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure" , "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure" , "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure" + , "-Wl,-u,_base_GHCziIOPort_doubleReadException_closure" , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" @@ -105,8 +106,12 @@ ld-options: , "-Wl,-u,_base_GHCziExceptionziType_overflowException_closure" , "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" , "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" , "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" , "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" +#if defined(mingw32_HOST_OS) + , "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" +#endif , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" , "-Wl,-u,_base_GHCziTopHandler_runMainIO_closure" , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" @@ -206,6 +211,7 @@ ld-options: , "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure" , "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure" , "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure" + , "-Wl,-u,base_GHCziIOPort_doubleReadException_closure" , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" @@ -214,8 +220,12 @@ ld-options: , "-Wl,-u,base_GHCziExceptionziType_overflowException_closure" , "-Wl,-u,base_GHCziConcziSync_runSparks_closure" , "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" , "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" , "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" +#if defined(mingw32_HOST_OS) + , "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" +#endif , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" , "-Wl,-u,base_GHCziTopHandler_runMainIO_closure" , "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index 7895ae26f5..1a1eb30611 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -97,6 +97,15 @@ library dbghelp -- for process information psapi + -- TODO: Hadrian will use this cabal file, so drop WINVER from Hadrian's configs. + -- Minimum supported Windows version. + -- These numbers can be found at: + -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx + -- If we're compiling on windows, enforce that we only support Windows 7+ + -- Adding this here means it doesn't have to be done in individual .c files + -- and also centralizes the versioning. + cpp-options: -D_WIN32_WINNT=0x06010000 + cc-options: -D_WIN32_WINNT=0x06010000 if flag(need-pthread) -- for pthread_getthreadid_np, pthread_create, ... extra-libraries: pthread @@ -218,11 +227,13 @@ library "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure" "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure" "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure" + "-Wl,-u,_base_GHCziIOPort_doubleReadException_closure" "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" @@ -297,11 +308,13 @@ library "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure" "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure" "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure" + "-Wl,-u,base_GHCziIOPort_doubleReadException_closure" "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" "-Wl,-u,base_GHCziConcziSync_runSparks_closure" "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" @@ -358,6 +371,17 @@ library -- This symbol is useful in gdb, but not referred to anywhere, -- so we need to force it to be included in the binary. ld-options: "-Wl,-u,findPtr" + -- This symbol is useful in gdb, but not referred to anywhere, + -- so we need to force it to be included in the binary. + "-Wl,-u,findPtr" + + if os(windows) + if flag(leading-underscore) + ld-options: + "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" + else + ld-options: + "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" if os(osx) ld-options: "-Wl,-search_paths_first" @@ -489,7 +513,8 @@ library -- I wish we had wildcards..., this would be: -- *.c hooks/**/*.c sm/**/*.c eventlog/**/*.c linker/**/*.c if os(windows) - c-sources: win32/AsyncIO.c + c-sources: win32/AsyncMIO.c + win32/AsyncWinIO.c win32/AwaitEvent.c win32/ConsoleHandler.c win32/GetEnv.c diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 5031c535a1..b1250b77e0 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -461,6 +461,7 @@ thread_TSO (StgTSO *tso) || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo + || tso->why_blocked == BlockedOnIOCompletion || tso->why_blocked == NotBlocked ) { thread_(&tso->block_info.closure); diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index ea64483418..c09e28c0aa 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -32,11 +32,13 @@ #include "sm/NonMoving.h" #include "sm/NonMovingMark.h" #include "Profiling.h" // prof_arena +#include "HeapAlloc.h" /* ----------------------------------------------------------------------------- Forward decls. -------------------------------------------------------------------------- */ +int isHeapAlloced ( StgPtr p); static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t ); static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t ); static void checkClosureShallow ( const StgClosure * ); @@ -46,6 +48,13 @@ static W_ countNonMovingSegments ( struct NonmovingSegment *segs ); static W_ countNonMovingHeap ( struct NonmovingHeap *heap ); /* ----------------------------------------------------------------------------- + Debugging utility. + -------------------------------------------------------------------------- */ + +// the HEAP_ALLOCED macro in function form. Useful for use in GDB or similar. +int isHeapAlloced ( StgPtr p) { return HEAP_ALLOCED(p); } + +/* ----------------------------------------------------------------------------- Check stack sanity -------------------------------------------------------------------------- */ @@ -618,6 +627,7 @@ checkTSO(StgTSO *tso) || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo + || tso->why_blocked == BlockedOnIOCompletion || tso->why_blocked == NotBlocked ) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure)); diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 501d958aae..dd9a96adf8 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -129,6 +129,7 @@ scavengeTSO (StgTSO *tso) || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo + || tso->why_blocked == BlockedOnIOCompletion || tso->why_blocked == NotBlocked ) { evacuate(&tso->block_info.closure); diff --git a/rts/win32/AsyncIO.c b/rts/win32/AsyncMIO.c index 49da79d2dd..5d55f79d74 100644 --- a/rts/win32/AsyncIO.c +++ b/rts/win32/AsyncMIO.c @@ -3,6 +3,9 @@ * Integrating Win32 asynchronous I/O with the GHC RTS. * * (c) sof, 2002-2003. + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #if !defined(THREADED_RTS) @@ -13,7 +16,7 @@ #include <stdio.h> #include "Schedule.h" #include "Capability.h" -#include "win32/AsyncIO.h" +#include "win32/AsyncMIO.h" #include "win32/IOManager.h" /* @@ -46,7 +49,7 @@ typedef struct CompletedReq { #define MAX_REQUESTS 200 -static CRITICAL_SECTION queue_lock; +static Mutex queue_lock; static HANDLE completed_req_event = INVALID_HANDLE_VALUE; static HANDLE abandon_req_wait = INVALID_HANDLE_VALUE; static HANDLE wait_handles[2]; @@ -67,17 +70,16 @@ onIOComplete(unsigned int reqID, dwRes = WaitForSingleObject(completed_table_sema, INFINITE); switch (dwRes) { case WAIT_OBJECT_0: - case WAIT_ABANDONED: break; default: /* Not likely */ fprintf(stderr, - "onIOComplete: failed to grab table semaphore (res=%d, err=%d), " - "dropping request 0x%x\n", reqID, dwRes, GetLastError()); + "onIOComplete: failed to grab table semaphore (res=%d, err=%ld), " + "dropping request 0x%lx\n", reqID, dwRes, GetLastError()); fflush(stderr); return; } - EnterCriticalSection(&queue_lock); + OS_ACQUIRE_LOCK(&queue_lock); if (completed_hw == MAX_REQUESTS) { /* Shouldn't happen */ fprintf(stderr, "onIOComplete: ERROR -- Request table overflow (%d); " @@ -102,7 +104,7 @@ onIOComplete(unsigned int reqID, SetEvent(completed_req_event); } } - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); } unsigned int @@ -112,9 +114,9 @@ addIORequest(int fd, HsInt len, char* buf) { - EnterCriticalSection(&queue_lock); + OS_ACQUIRE_LOCK(&queue_lock); issued_reqs++; - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); #if 0 fprintf(stderr, "addIOReq: %d %d %d\n", fd, forWriting, len); fflush(stderr); @@ -125,9 +127,9 @@ addIORequest(int fd, unsigned int addDelayRequest(HsInt usecs) { - EnterCriticalSection(&queue_lock); + OS_ACQUIRE_LOCK(&queue_lock); issued_reqs++; - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); #if 0 fprintf(stderr, "addDelayReq: %d\n", usecs); fflush(stderr); #endif @@ -137,9 +139,9 @@ addDelayRequest(HsInt usecs) unsigned int addDoProcRequest(void* proc, void* param) { - EnterCriticalSection(&queue_lock); + OS_ACQUIRE_LOCK(&queue_lock); issued_reqs++; - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); #if 0 fprintf(stderr, "addProcReq: %p %p\n", proc, param); fflush(stderr); #endif @@ -153,7 +155,7 @@ startupAsyncIO() if (!StartIOManager()) { return 0; } - InitializeCriticalSection(&queue_lock); + OS_INIT_LOCK(&queue_lock); /* Create a pair of events: * * - completed_req_event -- signals the deposit of request result; @@ -197,7 +199,7 @@ shutdownAsyncIO(bool wait_threads) CloseHandle(completed_table_sema); completed_table_sema = NULL; } - DeleteCriticalSection(&queue_lock); + OS_CLOSE_LOCK(&queue_lock); } /* @@ -228,7 +230,7 @@ start: issued_reqs, completed_hw, wait); fflush(stderr); #endif - EnterCriticalSection(&queue_lock); + OS_ACQUIRE_LOCK(&queue_lock); // Nothing immediately available & we won't wait if ((!wait && completed_hw == 0) #if 0 @@ -237,12 +239,12 @@ start: (issued_reqs == 0 && completed_hw == 0) #endif ) { - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); return 0; } if (completed_hw == 0) { // empty table, drop lock and wait - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); if ( wait && sched_state == SCHED_RUNNING ) { DWORD dwRes = WaitForMultipleObjects(2, wait_handles, FALSE, INFINITE); @@ -344,7 +346,7 @@ start: } completed_hw = 0; ResetEvent(completed_req_event); - LeaveCriticalSection(&queue_lock); + OS_RELEASE_LOCK(&queue_lock); return 1; } #endif /* !THREADED_RTS */ @@ -373,6 +375,7 @@ abandonRequestWait( void ) * properly serviced (see resetAbandon() below). --SDM 18/12/2003 */ SetEvent(abandon_req_wait); + interruptIOManagerEvent (); } void diff --git a/rts/win32/AsyncIO.h b/rts/win32/AsyncMIO.h index 75d0e0460d..63d8f34827 100644 --- a/rts/win32/AsyncIO.h +++ b/rts/win32/AsyncMIO.h @@ -3,10 +3,15 @@ * Integrating Win32 asynchronous I/O with the GHC RTS. * * (c) sof, 2002-2003. + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see AsyncWinIO.h. */ #pragma once +#include "Rts.h" + extern unsigned int addIORequest(int fd, bool forWriting, diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c new file mode 100644 index 0000000000..2af806b1c8 --- /dev/null +++ b/rts/win32/AsyncWinIO.c @@ -0,0 +1,545 @@ +/* AsyncIO.h + * + * Integrating Win32 asynchronous IOCP with the GHC RTS. + * + * (c) Tamar Christina, 2018 - 2019 + * + * NOTE: This is the WinIO manager, only used for --io-manager=native. + * For the MIO manager see AsyncIO.h. + */ + +#include "Rts.h" +#include <rts/IOManager.h> +#include "AsyncWinIO.h" +#include "Prelude.h" +#include "Capability.h" +#include "Schedule.h" +#include "Rts.h" +#include "ThreadLabels.h" + +#include <stdbool.h> +#include <windows.h> +#include <stdint.h> +#include <stdio.h> + +/* Note [Non-Threaded WINIO design] + Compared to Async MIO, Async WINIO does all of the heavy processing at the + Haskell side of things. The same code as the threaded WINIO is re-used for + the Non-threaded version. Of course since we are in a non-threaded rts we + can't block on foreign calls without hanging the application. + + This file thus serves as a back-end service that continuously reads pending + events from the given I/O completion port and notifies the Haskell I/O manager + of work that has been completed. This does incur a slight cost in that the + rts has to actually schedule the Haskell thread to do the work, however this + shouldn't be a problem for performance. + + It is however a problem for the workload buffer we use as we are not allowed + to service new requests until the old ones have actually been read and + processes by the Haskell I/O side. + + To account for this the I/O manager works in two stages. + + 1) Like the threaded version, any long wait we do, we prefer to do it in an + alterable state so that we can respond immediately to new requests. Note + that once we know which completion port handle we are bound to we no longer + need the Haskell side to tell us of new work. We can simply handle any new + work pre-emptively. + + 2) We block in a non-alertable state whenever + a) The Completion port handle is yet unknown. + b) The RTS requested the I/O manager be shutdown via an event --TODO: Remove? + c) We are waiting on the Haskell I/O manager to service a previous + request as to allow us to re-use the buffer. + + We would ideally like to spend as little time as possible in 2). + + The workflow for this I/O manager is as follows: + + +------------------------+ + | Worker thread creation | + +-----------+------------+ + | + | + +-------------v---------------+ + +------> Block in unalertable wait +-----+ + | +-------------+---------------+ | + | | | + | | | + | +-----------v------------+ | + | |Init by Haskell I/O call| | If init already + wait for I/O | +-----------+------------+ | + processing in | | | + Haskell side | | | + | +--------v---------+ | + Also process | | alertable wait <-----------+ + events like | +--------+---------+ + shutdown | | + | | + | +-------v--------+ + +------------+process response| + +----------------+ + + The non-alertable wait itself is split into two phases during regular + execution: + 1.) canQueueIOThread == true + 2.) canQueueIOThread == false, outstanding_service_requests == true + + `notifyScheduler` puts us into the first phase. During which we wait + for the scheduler to call `queueIOThread`. + During the second phase we wait for the queued haskell thread to run. + + The alertable wait is done by calling into GetQueuedCompletionStatusEx. + After we return from the call we notify the haskell side of new events + via `notifyScheduler`. + + notifyScheduler set's flags to indicate to the scheduler that new IO work + needs to be processed. At this point the next call to `schedule` will + check the flag and schedule execution of a haskell thread executing + processRemoteCompletion. + + `processRemoteCompletion` will process IO results invoking call backs and + processing timer events. Once done it resets `outstanding_service_requests` + and wakes up the IOManager thread. Which at this point becomes unblocked + and reenters the altertable wait state. This is done by calling into + registerAlterableWait. + + As a design decision to keep this side as light as possible no bookkeeping + is done here to track requests. That is, this file has no way of knowing + of the remaining outstanding I/O requests, how many it actually completed + in the last call as that list may contain spurious events. + + It works around this by having the Haskell side tell it how much work it + still has left to do. + + Unlike the Threaded version we use a single worker thread to handle + completions and so it won't scale as well. But if high scalability is needed + then use the threaded runtime. This would have to become threadsafe + in order to use multiple threads, but this is non-trivial as the non-threaded + rts has no locks around any of the key parts. + + See also Note [WINIO Manager design]. + + + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Note [Notifying the RTS/Haskell of completed events] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The C side runner can't directly create a haskell thread. + With the current API of the haskell runtime this would be terrible + unsound. In particular the GC assumes no heap objects are generated, + and no heap memory is requested while it is running. + + To work around this the scheduler invokes queueIOThread which checks + if a (haskell) thread should be created to process IO requests. + Since we only use this code path in the non-threaded runtime this + ensures there is only one OS thread at a time making use of the haskell + heap. + + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Note [Non-Threaded IO Manager startup sequence] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Under the new IO Manager we run a bit of initialization under + hs_init(). The first call into actual IO manager code is a + invocation of startupAsyncWinIO(); + + There we initialize IO manager locale variables and. + * call ioManagerStart() + * Creat a thread to execute "runner" + + We never truely shut down the IO Manager. While this means we + might block forever on the IOPort if the IO Manager is no longer + needed we consider this cheap compared to the complexity of + properly handling pausing and resuming of the manager. + + */ + +/* The IOCP Handle all I/O requests are associated with for this RTS. */ +static HANDLE completionPortHandle = INVALID_HANDLE_VALUE; +/* Boolean controlling if the I/O manager is/should still be running. */ +static bool running = false; + +/* Boolean to indicate whether we have outstanding I/O requests that still need + to be processed by the I/O manager on the Haskell side. + Set by: + notifyScheduler (true) + registerAlertableWait (false) + Read by: + runner + */ +volatile bool outstanding_service_requests = false; +/* Indicates wether we have hit one case where we serviced as much requests as + we could because the buffer got full. In such cases for the next requests + we expand the buffers so we have room to process requests in bigger + batches. + Set by: + runner + Read by: + registerAlertableWait +*/ +static bool queue_full = false; + +/* Timeout to use for the next alertable wait. INFINITE means never timeout. + Also see note [WINIO Timer management]. */ +static DWORD timeout = INFINITE; + +static HANDLE workerThread = NULL; +static DWORD workerThreadId = 0; + +/* Synchronization mutex for modifying the above state variables in a thread + safe way. */ +static SRWLOCK wio_runner_lock; + +/* Conditional variable to wake the I/O manager up from a non-alertable waiting + state. */ +static CONDITION_VARIABLE wakeEvent; +/* Conditional variable to force the system (haskell) thread to wait for a request to + complete. */ +static CONDITION_VARIABLE threadIOWait; + +/* Number of callbacks to reserve slots for in ENTRIES. This is also the + total number of concurrent I/O requests we can handle in one go. */ +static uint32_t num_callbacks = 32; +/* Buffer for I/O request information. */ +static OVERLAPPED_ENTRY *entries; +/* Number of I/O calls verified to have completed in the last round by the + Haskell I/O Manager. */ +static uint32_t num_last_completed; + +/* Notify the Haskell side of this many new finished requests */ +static uint32_t num_notify; + +/* Indicates to the scheduler that new work is available for processing. + Set by: + runner + queueIOThread + Read by + queueIOThread +*/ +static volatile bool canQueueIOThread; + +static void notifyScheduler(uint32_t num); + +static DWORD WINAPI runner (LPVOID lpParam); + +/* Create and initialize the non-threaded I/O manager. + + Called just once from hs_init. */ +bool startupAsyncWinIO(void) +{ + ASSERT(!running); + running = true; + outstanding_service_requests = false; + completionPortHandle = INVALID_HANDLE_VALUE; + + InitializeSRWLock (&wio_runner_lock); + InitializeConditionVariable (&wakeEvent); + InitializeConditionVariable (&threadIOWait); + + entries = calloc (sizeof (OVERLAPPED_ENTRY), num_callbacks); + + /* Start the I/O manager before creating the worker thread to prevent a busy + wait or spin-lock, this will call registerIOCPHandle allowing us to + skip the initial un-alertable wait. */ + ioManagerStart (); + + workerThread = CreateThread (NULL, 0, runner, NULL, 0, &workerThreadId); + if (!workerThread) + { + barf ("could not create I/O manager thread."); + return false; + } + + return true; +} + +/* Terminate the I/O manager, if WAIT_THREADS then the call will block until + all helper threads are finished. */ +void shutdownAsyncWinIO(bool wait_threads) +{ + if (workerThread != NULL) + { + if (wait_threads) + { + AcquireSRWLockExclusive (&wio_runner_lock); + + running = false; + ioManagerWakeup (); + PostQueuedCompletionStatus (completionPortHandle, 0, 0, NULL); + WakeConditionVariable (&wakeEvent); + WakeConditionVariable (&threadIOWait); + + ReleaseSRWLockExclusive (&wio_runner_lock); + + /* Now wait for the thread to actually finish. */ + WaitForSingleObject (workerThread, INFINITE); + } + completionPortHandle = INVALID_HANDLE_VALUE; + workerThread = NULL; + workerThreadId = 0; + free (entries); + entries = NULL; + } + + /* Call back into the Haskell side to terminate things there too. */ + ioManagerDie (); +} + +/* Register the I/O completetion port handle PORT that the I/O manager will be + monitoring. All handles are expected to be associated with this handle. */ +void registerIOCPHandle (HANDLE port) +{ + AcquireSRWLockExclusive (&wio_runner_lock); + + completionPortHandle = port; + + ReleaseSRWLockExclusive (&wio_runner_lock); +} + +/* Callback hook so the Haskell part of the I/O manager can notify this manager + that a request someone is waiting on was completed synchronously. This means + we need to wake up the scheduler as there is work to be done. */ + +void completeSynchronousRequest (void) +{ + AcquireSRWLockExclusive (&wio_runner_lock); + + WakeConditionVariable (&threadIOWait); + + ReleaseSRWLockExclusive (&wio_runner_lock); +} + + +/* Register outstanding I/O requests that the I/O manager should handle. + + This function will unblock the runner if it has been blocked in an + non-alertable wait. It might end an alertable wait as well but this + depends on the exact parameters provided. + + The haskell side will call this to inform the runner either about new + I/O requests or to update the number of outstanding requests after + processing a bundle. + + * has_timeout tells us if the mssec parameter is valid. + * MSSEC is the maximum amount of time in milliseconds that an alertable wait + should be done for before the haskell side requested to be notified of progress. + * NUM_REQ is the total overall number of outstanding I/O requests. + * pending_service indicates that there might be still a outstanding service + request queued and therefore we shouldn't unblock the runner quite yet. + + `pending_service` is needed in case we cancel an IO operation. We don't want this + to result in two processRemoteCompletion threads being queued. As this is both harder + to reason about and bad for performance. So we only reset outstanding_service_requests + if no service is pending. + + */ + +void registerAlertableWait (bool has_timeout, DWORD mssec, uint64_t num_req, bool pending_service) +{ + ASSERT(completionPortHandle != INVALID_HANDLE_VALUE); + AcquireSRWLockExclusive (&wio_runner_lock); + + bool interrupt = false; + + if (num_req == 0 && !has_timeout) { + timeout = INFINITE; + } + else if(has_timeout) { + timeout = mssec; + } + outstanding_service_requests = pending_service; + + //Resize queue if required + if (queue_full) + { + num_callbacks *= 2; + OVERLAPPED_ENTRY *new + = realloc (entries, + sizeof (OVERLAPPED_ENTRY) * num_callbacks); + if (new) + entries = new; + queue_full = false; + } + + /* If the new timeout is earlier than the old one we have to reschedule the + wait. Do this by interrupting the current operation and setting the new + timeout, since it must be the shortest one in the queue. */ + if (timeout > mssec) + { + timeout = mssec; + interrupt = true; + } + + ReleaseSRWLockExclusive (&wio_runner_lock); + + // Since we call registerAlertableWait only after + // processing I/O requests it's always desireable to wake + // up the runner here. + WakeConditionVariable (&wakeEvent); + + if (interrupt) { + PostQueuedCompletionStatus (completionPortHandle, 0, 0, NULL); + } +} + +/* Exported callback function that will be called by the RTS to collect the + 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. */ +OVERLAPPED_ENTRY* getOverlappedEntries (uint32_t *num) +{ + *num = num_last_completed; + return entries; +} + + +/* Called by the scheduler when we have ran out of work to do and we have at + least one thread blocked on an I/O Port. When WAIT then if this function + returns you will have at least one action to service, though this may be a + wake-up action. */ + +void awaitAsyncRequests (bool wait) +{ + if(queueIOThread()) { + return; + } + AcquireSRWLockExclusive (&wio_runner_lock); + /* We don't deal with spurious requests here, that's left up to AwaitEvent.c + because in principle we need to check if the capability work queue is now + not empty but we can't do that here. Also these locks don't guarantee + fairness, as such a request may have completed without us seeing a + timeslice in between. */ + if (wait && outstanding_service_requests) + SleepConditionVariableSRW (&threadIOWait, &wio_runner_lock, INFINITE, 0); + + ReleaseSRWLockExclusive (&wio_runner_lock); +} + + + +/* Sets `canQueueIOThread` to indicate to the scheduler that it should + queue a new haskell thread to process IO events. */ +static void notifyScheduler(uint32_t num) { + AcquireSRWLockExclusive (&wio_runner_lock); + ASSERT(!canQueueIOThread); + canQueueIOThread = true; + num_notify = num; + WakeConditionVariable(&threadIOWait); + ReleaseSRWLockExclusive (&wio_runner_lock); +} + +/* Queues a new haskell thread to process IO events + if there is work to do. + + Returns true if a thread/work was queued. + + Precond: + Not already waiting on service requests. + Postcond: + outstanding_service_requests = true + processRemoteCompletion queued. + IO runner thread blocked until processRemoteCompletion has run. + */ +bool queueIOThread() +{ + bool result = false; +#if !defined(THREADED_RTS) + AcquireSRWLockExclusive (&wio_runner_lock); + if(canQueueIOThread) + { + ASSERT(!outstanding_service_requests); + num_last_completed = num_notify; + outstanding_service_requests = true; + canQueueIOThread = false; + Capability *cap = &MainCapability; + StgTSO * tso = createStrictIOThread (cap, RtsFlags.GcFlags.initialStkSize, + processRemoteCompletion_closure); + labelThread(cap, tso, "ProcessIOThread"); + + ASSERT(tso); + scheduleThreadNow (cap, tso); + result = true; + } + ReleaseSRWLockExclusive (&wio_runner_lock); +#endif + return result; +} + +/* Main thread runner for the non-threaded I/O Manager. */ + +static DWORD WINAPI runner (LPVOID lpParam STG_UNUSED) +{ + /* The last event that was sent to the I/O manager. */ + HsWord32 lastEvent = 0; + while (running) + { + AcquireSRWLockExclusive (&wio_runner_lock); + + lastEvent = readIOManagerEvent (); + /* Non-alertable wait. While here we can't server any I/O requests so we + would ideally like to spent as little time here as possible. As such + there are only 3 reasons to enter this state: + + 1) I/O manager hasn't been fully initialized yet. + 2) I/O manager was told to shutdown, instead of doing that we just + block indefinitely so we don't have to recreate the thread to start + back up. + 3) We are waiting for the RTS to service the last round of requests. */ + while (completionPortHandle == INVALID_HANDLE_VALUE + || lastEvent == IO_MANAGER_DIE + || outstanding_service_requests + || canQueueIOThread) + { + // fprintf(stderr, "NonAlert sleep:(%x, %i, %i)\n", + // lastEvent, outstanding_service_requests, canQueueIOThread); + // fflush(stderr); + SleepConditionVariableSRW (&wakeEvent, &wio_runner_lock, INFINITE, 0); + HsWord32 nextEvent = readIOManagerEvent (); + lastEvent = nextEvent ? nextEvent : lastEvent; + } + + ReleaseSRWLockExclusive (&wio_runner_lock); + + ULONG num_removed = 0; + ZeroMemory (entries, sizeof (entries[0]) * num_callbacks); + if (GetQueuedCompletionStatusEx (completionPortHandle, entries, + num_callbacks, &num_removed, timeout, + false)) + { + if (num_removed > 0) + { + queue_full = num_removed == num_callbacks; + } + } + else if (WAIT_TIMEOUT == GetLastError ()) + { + num_removed = 0; + } + // We always queue a haskell thread upon returning from GetQueuedCompletionStatusEx. + // We only return from GetQueuedCompletionStatusEx if: + // * IO was processed, in which case we need to process the events. + // * A timer event was registered/timed out. We need the process expired timers + // and update the timeout. + // * We woke up spuriously, which is quite rare. + // This simplifies the logic in exchange for a *very* small chance of redundant + // haskell threads. A redundant thread would be queued if: + // * We wake up spuriously + // * All returned results have been canceled already. + // It's not realistic nor worthwhile to check for these edge cases so we don't. + notifyScheduler (num_removed); + + AcquireSRWLockExclusive (&wio_runner_lock); + + if (!running) + ExitThread (0); + + ReleaseSRWLockExclusive (&wio_runner_lock); + } + return 0; +} diff --git a/rts/win32/AsyncWinIO.h b/rts/win32/AsyncWinIO.h new file mode 100644 index 0000000000..3ddf5de77a --- /dev/null +++ b/rts/win32/AsyncWinIO.h @@ -0,0 +1,25 @@ +/* AsyncIO.h + * + * Integrating Win32 asynchronous IOCP with the GHC RTS. + * + * (c) Tamar Christina, 2018 + * + * NOTE: This is the WinIO manager, only used for --io-manager=native. + * For the MIO manager see AsyncIO.h. + */ + +#pragma once + +#include "Rts.h" +#include <stdbool.h> +#include <windows.h> + +extern bool startupAsyncWinIO(void); +extern void shutdownAsyncWinIO(bool wait_threads); +extern void awaitAsyncRequests(bool wait); +extern void registerIOCPHandle (HANDLE port); +extern void registerAlertableWait (bool has_timeout, DWORD mssec, uint64_t num_req, bool service_pending); + +extern OVERLAPPED_ENTRY* getOverlappedEntries (uint32_t *num); +extern void completeSynchronousRequest (void); +extern bool queueIOThread(void); diff --git a/rts/win32/AwaitEvent.c b/rts/win32/AwaitEvent.c index b639121c87..6a621d6ef5 100644 --- a/rts/win32/AwaitEvent.c +++ b/rts/win32/AwaitEvent.c @@ -14,15 +14,18 @@ * */ #include "Rts.h" +#include "RtsFlags.h" #include "Schedule.h" #include "AwaitEvent.h" #include <windows.h> -#include "win32/AsyncIO.h" +#include "win32/AsyncMIO.h" +#include "win32/AsyncWinIO.h" #include "win32/ConsoleHandler.h" +#include <stdbool.h> // Used to avoid calling abandonRequestWait() if we don't need to. // Protected by sched_mutex. -static uint32_t workerWaitingForRequests = 0; +static bool workerWaitingForRequests = false; void awaitEvent(bool wait) @@ -30,9 +33,12 @@ awaitEvent(bool wait) do { /* Try to de-queue completed IO requests */ - workerWaitingForRequests = 1; - awaitRequests(wait); - workerWaitingForRequests = 0; + workerWaitingForRequests = true; + if (is_io_mng_native_p()) + awaitAsyncRequests(wait); + else + awaitRequests(wait); + workerWaitingForRequests = false; // If a signal was raised, we need to service it // XXX the scheduler loop really should be calling diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c index 3ddf4103da..05d15868eb 100644 --- a/rts/win32/ConsoleHandler.c +++ b/rts/win32/ConsoleHandler.c @@ -1,13 +1,15 @@ /* * Console control handler support. * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #include "Rts.h" #include <windows.h> #include "ConsoleHandler.h" #include "Schedule.h" #include "RtsUtils.h" -#include "AsyncIO.h" +#include "AsyncMIO.h" #include "RtsSignals.h" extern int stg_InstallConsoleEvent(int action, StgStablePtr *handler); @@ -86,7 +88,6 @@ static BOOL WINAPI shutdown_handler(DWORD dwCtrlType) return false; case CTRL_C_EVENT: case CTRL_BREAK_EVENT: - // If we're already trying to interrupt the RTS, terminate with // extreme prejudice. So the first ^C tries to exit the program // cleanly, and the second one just kills it. @@ -223,12 +224,12 @@ static BOOL WINAPI generic_handler(DWORD dwCtrlType) #if defined(THREADED_RTS) sendIOManagerEvent((StgWord8) ((dwCtrlType<<1) | 1)); + interruptIOManagerEvent (); #else if ( stg_pending_events < N_PENDING_EVENTS ) { stg_pending_buf[stg_pending_events] = dwCtrlType; stg_pending_events++; } - // we need to wake up awaitEvent() abandonRequestWait(); #endif diff --git a/rts/win32/ConsoleHandler.h b/rts/win32/ConsoleHandler.h index 06af9dd0d0..bb7278abba 100644 --- a/rts/win32/ConsoleHandler.h +++ b/rts/win32/ConsoleHandler.h @@ -1,6 +1,8 @@ /* * Console control handler support. * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #pragma once @@ -16,24 +18,24 @@ */ #if !defined(THREADED_RTS) -/* +/* * under THREADED_RTS, console events are passed to the IO manager * thread, which starts up the handler. See ThrIOManager.c. */ /* - * Function: signals_pending() - * + * Function: signals_pending() + * * Used by the RTS to check whether new signals have been 'recently' reported. - * If so, the RTS arranges for the delivered signals to be handled by - * de-queueing them from their table, running the associated Haskell + * If so, the RTS arranges for the delivered signals to be handled by + * de-queueing them from their table, running the associated Haskell * signal handler. */ extern StgInt stg_pending_events; #define signals_pending() ( stg_pending_events > 0) -/* +/* * Function: anyUserHandlers() * * Used by the Scheduler to decide whether its worth its while to stick diff --git a/rts/win32/IOManager.c b/rts/win32/IOManager.c index f155180ef3..47bcf4bcf4 100644 --- a/rts/win32/IOManager.c +++ b/rts/win32/IOManager.c @@ -3,6 +3,9 @@ * Non-blocking / asynchronous I/O for Win32. * * (c) sof, 2002-2003. + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #if !defined(THREADED_RTS) @@ -22,7 +25,7 @@ * Internal state maintained by the IO manager. */ typedef struct IOManagerState { - CritSection manLock; + Mutex manLock; WorkQueue* workQueue; int queueSize; int numWorkers; @@ -30,7 +33,7 @@ typedef struct IOManagerState { HANDLE hExitEvent; unsigned int requestID; /* fields for keeping track of active WorkItems */ - CritSection active_work_lock; + Mutex active_work_lock; WorkItem* active_work_items; UINT sleepResolution; } IOManagerState; @@ -65,7 +68,7 @@ IOWorkerProc(PVOID param) // The error code is communicated back on completion of request; reset. errCode = 0; - EnterCriticalSection(&iom->manLock); + OS_ACQUIRE_LOCK(&iom->manLock); /* Signal that the worker is idle. * * 'workersIdle' is used when determining whether or not to @@ -73,7 +76,7 @@ IOWorkerProc(PVOID param) * (see addIORequest().) */ iom->workersIdle++; - LeaveCriticalSection(&iom->manLock); + OS_RELEASE_LOCK(&iom->manLock); /* * A possible future refinement is to make long-term idle threads @@ -85,19 +88,19 @@ IOWorkerProc(PVOID param) if (rc == WAIT_OBJECT_0) { // we received the exit event - EnterCriticalSection(&iom->manLock); + OS_ACQUIRE_LOCK(&iom->manLock); ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); + OS_RELEASE_LOCK(&iom->manLock); return 0; } - EnterCriticalSection(&iom->manLock); + OS_ACQUIRE_LOCK(&iom->manLock); /* Signal that the thread is 'non-idle' and about to consume * a work item. */ iom->workersIdle--; iom->queueSize--; - LeaveCriticalSection(&iom->manLock); + OS_RELEASE_LOCK(&iom->manLock); if ( rc == (WAIT_OBJECT_0 + 1) ) { /* work item available, fetch it. */ @@ -266,17 +269,17 @@ IOWorkerProc(PVOID param) } else { fprintf(stderr, "unable to fetch work; fatal.\n"); fflush(stderr); - EnterCriticalSection(&iom->manLock); + OS_ACQUIRE_LOCK(&iom->manLock); ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); + OS_RELEASE_LOCK(&iom->manLock); return 1; } } else { fprintf(stderr, "waiting failed (%lu); fatal.\n", rc); fflush(stderr); - EnterCriticalSection(&iom->manLock); + OS_ACQUIRE_LOCK(&iom->manLock); ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); + OS_RELEASE_LOCK(&iom->manLock); return 1; } } @@ -334,13 +337,13 @@ StartIOManager(void) } ioMan->hExitEvent = hExit; - InitializeCriticalSection(&ioMan->manLock); + OS_INIT_LOCK(&ioMan->manLock); ioMan->workQueue = wq; ioMan->numWorkers = 0; ioMan->workersIdle = 0; ioMan->queueSize = 0; ioMan->requestID = 1; - InitializeCriticalSection(&ioMan->active_work_lock); + OS_INIT_LOCK(&ioMan->active_work_lock); ioMan->active_work_items = NULL; ioMan->sleepResolution = sleepResolution; @@ -360,7 +363,7 @@ int depositWorkItem( unsigned int reqID, WorkItem* wItem ) { - EnterCriticalSection(&ioMan->manLock); + OS_ACQUIRE_LOCK(&ioMan->manLock); #if 0 fprintf(stderr, "depositWorkItem: %d/%d\n", @@ -397,9 +400,9 @@ depositWorkItem( unsigned int reqID, if ( (ioMan->workersIdle < ioMan->queueSize) ) { /* see if giving up our quantum ferrets out some idle threads. */ - LeaveCriticalSection(&ioMan->manLock); + OS_RELEASE_LOCK(&ioMan->manLock); Sleep(0); - EnterCriticalSection(&ioMan->manLock); + OS_ACQUIRE_LOCK(&ioMan->manLock); if ( (ioMan->workersIdle < ioMan->queueSize) ) { /* No, go ahead and create another. */ ioMan->numWorkers++; @@ -408,7 +411,7 @@ depositWorkItem( unsigned int reqID, } } } - LeaveCriticalSection(&ioMan->manLock); + OS_RELEASE_LOCK(&ioMan->manLock); if (SubmitWork(ioMan->workQueue,wItem)) { /* Note: the work item has potentially been consumed by a worker thread @@ -522,17 +525,17 @@ void ShutdownIOManager ( bool wait_threads ) if (wait_threads) { /* Wait for all worker threads to die. */ for (;;) { - EnterCriticalSection(&ioMan->manLock); + OS_ACQUIRE_LOCK(&ioMan->manLock); num = ioMan->numWorkers; - LeaveCriticalSection(&ioMan->manLock); + OS_RELEASE_LOCK(&ioMan->manLock); if (num == 0) break; Sleep(10); } FreeWorkQueue(ioMan->workQueue); CloseHandle(ioMan->hExitEvent); - DeleteCriticalSection(&ioMan->active_work_lock); - DeleteCriticalSection(&ioMan->manLock); + OS_CLOSE_LOCK(&ioMan->active_work_lock); + OS_CLOSE_LOCK(&ioMan->manLock); mmresult = timeEndPeriod(ioMan->sleepResolution); if (mmresult != MMSYSERR_NOERROR) { @@ -550,10 +553,10 @@ void RegisterWorkItem(IOManagerState* ioMan, WorkItem* wi) { - EnterCriticalSection(&ioMan->active_work_lock); + OS_ACQUIRE_LOCK(&ioMan->active_work_lock); wi->link = ioMan->active_work_items; ioMan->active_work_items = wi; - LeaveCriticalSection(&ioMan->active_work_lock); + OS_RELEASE_LOCK(&ioMan->active_work_lock); } static @@ -563,7 +566,7 @@ DeregisterWorkItem(IOManagerState* ioMan, { WorkItem *ptr, *prev; - EnterCriticalSection(&ioMan->active_work_lock); + OS_ACQUIRE_LOCK(&ioMan->active_work_lock); for(prev=NULL,ptr=ioMan->active_work_items;ptr;prev=ptr,ptr=ptr->link) { if (wi->requestID == ptr->requestID) { if (prev==NULL) { @@ -571,13 +574,13 @@ DeregisterWorkItem(IOManagerState* ioMan, } else { prev->link = ptr->link; } - LeaveCriticalSection(&ioMan->active_work_lock); + OS_RELEASE_LOCK(&ioMan->active_work_lock); return; } } fprintf(stderr, "DeregisterWorkItem: unable to locate work item %d\n", wi->requestID); - LeaveCriticalSection(&ioMan->active_work_lock); + OS_RELEASE_LOCK(&ioMan->active_work_lock); } @@ -596,11 +599,11 @@ void abandonWorkRequest ( int reqID ) { WorkItem *ptr; - EnterCriticalSection(&ioMan->active_work_lock); + OS_ACQUIRE_LOCK(&ioMan->active_work_lock); for(ptr=ioMan->active_work_items;ptr;ptr=ptr->link) { if (ptr->requestID == (unsigned int)reqID ) { ptr->abandonOp = 1; - LeaveCriticalSection(&ioMan->active_work_lock); + OS_RELEASE_LOCK(&ioMan->active_work_lock); return; } } @@ -608,7 +611,7 @@ abandonWorkRequest ( int reqID ) * finished sometime since awaitRequests() last drained the completed * request table; i.e., not an error. */ - LeaveCriticalSection(&ioMan->active_work_lock); + OS_RELEASE_LOCK(&ioMan->active_work_lock); } #endif diff --git a/rts/win32/IOManager.h b/rts/win32/IOManager.h index a5bd61ab1b..cb876db9cc 100644 --- a/rts/win32/IOManager.h +++ b/rts/win32/IOManager.h @@ -3,6 +3,9 @@ * Non-blocking / asynchronous I/O for Win32. * * (c) sof, 2002-2003 + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #pragma once @@ -102,3 +105,5 @@ extern int AddProcRequest ( void* proc, CompletionProc onCompletion); extern void abandonWorkRequest ( int reqID ); + +extern void interruptIOManagerEvent ( void ); diff --git a/rts/win32/OSMem.c b/rts/win32/OSMem.c index dd0f60ff0a..fd26d06c4e 100644 --- a/rts/win32/OSMem.c +++ b/rts/win32/OSMem.c @@ -37,28 +37,11 @@ static alloc_rec* allocs = NULL; /* free_blocks are kept in ascending order, and adjacent blocks are merged */ static block_rec* free_blocks = NULL; -/* Mingw-w64 does not currently have this in their header. So we have to import it.*/ -typedef LPVOID(WINAPI *VirtualAllocExNumaProc)(HANDLE, LPVOID, SIZE_T, DWORD, DWORD, DWORD); - -/* Cache NUMA API call. */ -VirtualAllocExNumaProc _VirtualAllocExNuma; - void osMemInit(void) { allocs = NULL; free_blocks = NULL; - - /* Resolve and cache VirtualAllocExNuma. */ - if (osNumaAvailable() && RtsFlags.GcFlags.numa) - { - _VirtualAllocExNuma = (VirtualAllocExNumaProc)(void*)GetProcAddress(GetModuleHandleW(L"kernel32"), "VirtualAllocExNuma"); - if (!_VirtualAllocExNuma) - { - sysErrorBelch( - "osBindMBlocksToNode: VirtualAllocExNuma does not exist. How did you get this far?"); - } - } } static @@ -569,7 +552,7 @@ void osBindMBlocksToNode( On windows also -xb is broken, it does nothing so that can't be used to tweak it (see #12577). So for now, just let the OS decide. */ - temp = _VirtualAllocExNuma( + temp = VirtualAllocExNuma( GetCurrentProcess(), NULL, // addr? See base memory size, diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c index fe35f35e82..4701c344a0 100644 --- a/rts/win32/OSThreads.c +++ b/rts/win32/OSThreads.c @@ -27,69 +27,6 @@ static uint32_t* cpuGroupCumulativeCache = NULL; /* Processor group dist cache. */ static uint8_t* cpuGroupDistCache = NULL; -/* Win32 threads and synchronisation objects */ - -/* A Condition is represented by a Win32 Event object; - * a Mutex by a Mutex kernel object. - * - * ToDo: go through the defn and usage of these to - * make sure the semantics match up with that of - * the (assumed) pthreads behaviour. This is really - * just a first pass at getting something compilable. - */ - -void -initCondition( Condition* pCond ) -{ - HANDLE h = CreateEvent(NULL, - FALSE, /* auto reset */ - FALSE, /* initially not signalled */ - NULL); /* unnamed => process-local. */ - - if ( h == NULL ) { - sysErrorBelch("initCondition: unable to create"); - stg_exit(EXIT_FAILURE); - } - *pCond = h; - return; -} - -void -closeCondition( Condition* pCond ) -{ - if ( CloseHandle(*pCond) == 0 ) { - sysErrorBelch("closeCondition: failed to close"); - } - return; -} - -bool -broadcastCondition ( Condition* pCond ) -{ - PulseEvent(*pCond); - return true; -} - -bool -signalCondition ( Condition* pCond ) -{ - if (SetEvent(*pCond) == 0) { - sysErrorBelch("SetEvent"); - stg_exit(EXIT_FAILURE); - } - return true; -} - -bool -waitCondition ( Condition* pCond, Mutex* pMut ) -{ - RELEASE_LOCK(pMut); - WaitForSingleObject(*pCond, INFINITE); - /* Hmm..use WaitForMultipleObjects() ? */ - ACQUIRE_LOCK(pMut); - return true; -} - void yieldThread() { @@ -150,35 +87,6 @@ osThreadIsAlive(OSThreadId id) return (exit_code == STILL_ACTIVE); } -#if defined(USE_CRITICAL_SECTIONS) -void -initMutex (Mutex* pMut) -{ - InitializeCriticalSectionAndSpinCount(pMut,4000); -} -void -closeMutex (Mutex* pMut) -{ - DeleteCriticalSection(pMut); -} -#else -void -initMutex (Mutex* pMut) -{ - HANDLE h = CreateMutex ( NULL, /* default sec. attributes */ - TRUE, /* not owned => initially signalled */ - NULL - ); - *pMut = h; - return; -} -void -closeMutex (Mutex* pMut) -{ - CloseHandle(*pMut); -} -#endif - void newThreadLocalKey (ThreadLocalKey *key) { @@ -252,6 +160,13 @@ forkOS_createThread ( HsStablePtr entry ) (unsigned*)&pId) == 0); } +#if defined(x86_64_HOST_ARCH) + +#if !defined(ALL_PROCESSOR_GROUPS) +#define ALL_PROCESSOR_GROUPS 0xffff +#endif +#endif + void freeThreadingResources (void) { if (cpuGroupCache) @@ -426,12 +341,15 @@ getNumberOfProcessors (void) if (nproc) { - IF_DEBUG(scheduler, debugBelch("[*] Total number of active processors detected: %u\n", nproc)); + IF_DEBUG(scheduler, debugBelch("[*] Total number of active " + "processors detected: %u\n", nproc)); return nproc; } - IF_DEBUG(scheduler, debugBelch("Could not determine Max number of logical processors.\n" - "Falling back to old code which limits to 64 logical processors.\n")); + IF_DEBUG(scheduler, debugBelch("Could not determine Max number of " + "logical processors.\n" + "Falling back to old code which limits " + "to 64 logical processors.\n")); } #endif @@ -484,7 +402,6 @@ setThreadAffinity (uint32_t n, uint32_t m) // cap N of M for (i = 0; i < n_groups; i++) { #if defined(x86_64_HOST_ARCH) - // If we support the new API, use it. if (mask[i] > 0) { GROUP_AFFINITY hGroup; @@ -515,24 +432,15 @@ setThreadAffinity (uint32_t n, uint32_t m) // cap N of M free(mask); } -typedef BOOL (WINAPI *PCSIO)(HANDLE); - void interruptOSThread (OSThreadId id) { HANDLE hdl; - PCSIO pCSIO; if (!(hdl = OpenThread(THREAD_TERMINATE,FALSE,id))) { sysErrorBelch("interruptOSThread: OpenThread"); stg_exit(EXIT_FAILURE); } - pCSIO = (PCSIO)(void*)GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), - "CancelSynchronousIo"); - if ( NULL != pCSIO ) { - pCSIO(hdl); - } else { - // Nothing to do, unfortunately - } + CancelSynchronousIo(hdl); CloseHandle(hdl); } @@ -600,3 +508,55 @@ KernelThreadId kernelThreadId (void) DWORD tid = GetCurrentThreadId(); return tid; } + +/* Win32 threads and synchronisation objects */ + +/* A Condition is represented by a Win32 Conditional variable which is a + * user-mode object and so incurs no context switching overhead. + * a Mutex by a Mutex kernel object. + */ + +void +initCondition( Condition* pCond ) +{ + InitializeConditionVariable(pCond); + return; +} + +void +closeCondition( Condition* pCond STG_UNUSED) +{ + return; +} + +bool +broadcastCondition ( Condition* pCond ) +{ + WakeAllConditionVariable(pCond); + return true; +} + +bool +signalCondition ( Condition* pCond ) +{ + WakeConditionVariable(pCond); + return true; +} + +bool +waitCondition ( Condition* pCond, Mutex* pMut ) +{ + SleepConditionVariableSRW(pCond, pMut, INFINITE, 0); + return true; +} + +void +initMutex (Mutex* pMut) +{ + InitializeSRWLock(pMut); +} +void +closeMutex (Mutex* pMut) +{ + (void)pMut; +} diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index 44414b92c3..1b7ba851e2 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -5,41 +5,35 @@ * The IO manager thread in THREADED_RTS. * See also libraries/base/GHC/Conc.hs. * + * NOTE: This is used by both MIO and WINIO * ---------------------------------------------------------------------------*/ #include "Rts.h" #include "IOManager.h" +#include "rts\OSThreads.h" #include "Prelude.h" #include <windows.h> // Here's the Event that we use to wake up the IO manager thread static HANDLE io_manager_event = INVALID_HANDLE_VALUE; -// must agree with values in GHC.Conc: -#define IO_MANAGER_WAKEUP 0xffffffff -#define IO_MANAGER_DIE 0xfffffffe -// spurious wakeups are returned as zero. -// console events are ((event<<1) | 1) - -#if defined(THREADED_RTS) - #define EVENT_BUFSIZ 256 +// We lock using OS_ACQUIRE_LOCK the ensure the non-threaded WINIO +// C thread does not race with the scheduler code which can also +// access the event queue via FFI. Mutex event_buf_mutex; StgWord32 event_buf[EVENT_BUFSIZ]; uint32_t next_event; -#endif - +/*Creates the IO Managers event object. + Idempotent after first call. +*/ HANDLE getIOManagerEvent (void) { - // This function has to exist even in the non-THREADED_RTS, - // because code in GHC.Conc refers to it. It won't ever be called - // unless we're in the threaded RTS, however. -#if defined(THREADED_RTS) HANDLE hRes; - ACQUIRE_LOCK(&event_buf_mutex); + OS_ACQUIRE_LOCK(&event_buf_mutex); if (io_manager_event == INVALID_HANDLE_VALUE) { hRes = CreateEvent ( NULL, // no security attrs @@ -55,29 +49,27 @@ getIOManagerEvent (void) hRes = io_manager_event; } - RELEASE_LOCK(&event_buf_mutex); + OS_RELEASE_LOCK(&event_buf_mutex); return hRes; -#else - return NULL; -#endif } HsWord32 readIOManagerEvent (void) { - // This function must exist even in non-THREADED_RTS, - // see getIOManagerEvent() above. -#if defined(THREADED_RTS) HsWord32 res; - ACQUIRE_LOCK(&event_buf_mutex); + OS_ACQUIRE_LOCK(&event_buf_mutex); if (io_manager_event != INVALID_HANDLE_VALUE) { if (next_event == 0) { res = 0; // no event to return } else { - res = (HsWord32)(event_buf[--next_event]); + do { + // Dequeue as many wakeup events as possible. + res = (HsWord32)(event_buf[--next_event]); + } while (res == IO_MANAGER_WAKEUP && next_event); + if (next_event == 0) { if (!ResetEvent(io_manager_event)) { sysErrorBelch("readIOManagerEvent"); @@ -89,36 +81,47 @@ readIOManagerEvent (void) res = 0; } - RELEASE_LOCK(&event_buf_mutex); + OS_RELEASE_LOCK(&event_buf_mutex); - // debugBelch("readIOManagerEvent: %d\n", res); + //debugBelch("readIOManagerEvent: %d\n", res); return res; -#else - return 0; -#endif } void sendIOManagerEvent (HsWord32 event) { -#if defined(THREADED_RTS) - ACQUIRE_LOCK(&event_buf_mutex); + OS_ACQUIRE_LOCK(&event_buf_mutex); - // debugBelch("sendIOManagerEvent: %d\n", event); + //debugBelch("sendIOManagerEvent: %d to %p\n", event, io_manager_event); if (io_manager_event != INVALID_HANDLE_VALUE) { if (next_event == EVENT_BUFSIZ) { errorBelch("event buffer overflowed; event dropped"); } else { + event_buf[next_event++] = (StgWord32)event; if (!SetEvent(io_manager_event)) { - sysErrorBelch("sendIOManagerEvent"); + sysErrorBelch("sendIOManagerEvent: SetEvent"); stg_exit(EXIT_FAILURE); } - event_buf[next_event++] = (StgWord32)event; } } - RELEASE_LOCK(&event_buf_mutex); -#endif + OS_RELEASE_LOCK(&event_buf_mutex); +} + +void +interruptIOManagerEvent (void) +{ + if (is_io_mng_native_p ()) { + OS_ACQUIRE_LOCK(&event_buf_mutex); + + /* How expensive is this??. */ + Capability *cap; + cap = rts_lock(); + rts_evalIO(&cap, interruptIOManager_closure, NULL); + rts_unlock(cap); + + OS_RELEASE_LOCK(&event_buf_mutex); + } } void @@ -127,7 +130,6 @@ ioManagerWakeup (void) sendIOManagerEvent(IO_MANAGER_WAKEUP); } -#if defined(THREADED_RTS) void ioManagerDie (void) { @@ -135,9 +137,9 @@ ioManagerDie (void) // IO_MANAGER_DIE must be idempotent, as it is called // repeatedly by shutdownCapability(). Try conc059(threaded1) to // illustrate the problem. - ACQUIRE_LOCK(&event_buf_mutex); + OS_ACQUIRE_LOCK(&event_buf_mutex); io_manager_event = INVALID_HANDLE_VALUE; - RELEASE_LOCK(&event_buf_mutex); + OS_RELEASE_LOCK(&event_buf_mutex); // ToDo: wait for the IO manager to pick up the event, and // then release the Event and Mutex objects we've allocated. } @@ -145,7 +147,9 @@ ioManagerDie (void) void ioManagerStart (void) { +#if defined(THREADED_RTS) initMutex(&event_buf_mutex); +#endif next_event = 0; // Make sure the IO manager thread is running @@ -156,4 +160,3 @@ ioManagerStart (void) rts_unlock(cap); } } -#endif diff --git a/rts/win32/WorkQueue.c b/rts/win32/WorkQueue.c index e560bd24cd..dba20c668b 100644 --- a/rts/win32/WorkQueue.c +++ b/rts/win32/WorkQueue.c @@ -3,11 +3,13 @@ * * (c) sof, 2002-2003. */ +#include "Rts.h" #include "WorkQueue.h" #include <stdbool.h> #include <stdio.h> #include <stdlib.h> #include <string.h> +#include <windows.h> static void queue_error_rc( char* loc, DWORD err); static void queue_error( char* loc, char* reason); @@ -48,7 +50,7 @@ NewWorkQueue() memset(wq, 0, sizeof *wq); - InitializeCriticalSection(&wq->queueLock); + OS_INIT_LOCK(&wq->queueLock); wq->workAvailable = newSemaphore(0, WORKQUEUE_SIZE); wq->roomAvailable = newSemaphore(WORKQUEUE_SIZE, WORKQUEUE_SIZE); @@ -83,7 +85,7 @@ FreeWorkQueue ( WorkQueue* pq ) if ( pq->roomAvailable ) { CloseHandle(pq->roomAvailable); } - DeleteCriticalSection(&pq->queueLock); + OS_CLOSE_LOCK(&pq->queueLock); free(pq); return; } @@ -147,13 +149,13 @@ FetchWork ( WorkQueue* pq, void** ppw ) return false; } - EnterCriticalSection(&pq->queueLock); + OS_ACQUIRE_LOCK(&pq->queueLock); *ppw = pq->items[pq->head]; /* For sanity's sake, zero out the pointer. */ pq->items[pq->head] = NULL; pq->head = (pq->head + 1) % WORKQUEUE_SIZE; rc = ReleaseSemaphore(pq->roomAvailable,1, NULL); - LeaveCriticalSection(&pq->queueLock); + OS_RELEASE_LOCK(&pq->queueLock); if ( 0 == rc ) { queue_error_rc("FetchWork.ReleaseSemaphore()", GetLastError()); return false; @@ -191,11 +193,11 @@ SubmitWork ( WorkQueue* pq, void* pw ) return false; } - EnterCriticalSection(&pq->queueLock); + OS_ACQUIRE_LOCK(&pq->queueLock); pq->items[pq->tail] = pw; pq->tail = (pq->tail + 1) % WORKQUEUE_SIZE; rc = ReleaseSemaphore(pq->workAvailable,1, NULL); - LeaveCriticalSection(&pq->queueLock); + OS_RELEASE_LOCK(&pq->queueLock); if ( 0 == rc ) { queue_error_rc("SubmitWork.ReleaseSemaphore()", GetLastError()); return false; diff --git a/rts/win32/WorkQueue.h b/rts/win32/WorkQueue.h index 4dbfcd40d3..569a7b4445 100644 --- a/rts/win32/WorkQueue.h +++ b/rts/win32/WorkQueue.h @@ -14,12 +14,12 @@ #define WORKQUEUE_SIZE 16 typedef HANDLE Semaphore; -typedef CRITICAL_SECTION CritSection; +typedef SRWLOCK Mutex; typedef struct WorkQueue { /* the master lock, need to be grabbed prior to using any of the other elements of the struct. */ - CritSection queueLock; + Mutex queueLock; /* consumers/workers block waiting for 'workAvailable' */ Semaphore workAvailable; Semaphore roomAvailable; diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def index de4db2244b..cb9c32729e 100644 --- a/rts/win32/libHSbase.def +++ b/rts/win32/libHSbase.def @@ -27,8 +27,10 @@ EXPORTS base_GHCziPtr_FunPtr_con_info base_GHCziConcziIO_ensureIOManagerIsRunning_closure + base_GHCziConcziIO_interruptIOManager_closure base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure base_GHCziConcziSync_runSparks_closure + base_GHCziEventziWindows_processRemoteCompletion_closure base_GHCziTopHandler_flushStdHandles_closure @@ -41,7 +43,7 @@ EXPORTS base_GHCziIOziException_cannotCompactFunction_closure base_GHCziIOziException_cannotCompactPinned_closure base_GHCziIOziException_cannotCompactMutable_closure - + base_GHCziIOPort_doubleReadException_closure base_ControlziExceptionziBase_nonTermination_closure base_ControlziExceptionziBase_nestedAtomically_closure base_GHCziEventziThread_blockedOnBadFD_closure diff --git a/testsuite/config/ghc b/testsuite/config/ghc index b561fc806e..4f053eb50f 100644 --- a/testsuite/config/ghc +++ b/testsuite/config/ghc @@ -68,6 +68,14 @@ if (ghc_with_llvm and not config.unregisterised): config.compile_ways.append('optllvm') config.run_ways.append('optllvm') +# WinIO I/O manager for Windows +if windows: + winio_ways = ['winio', 'winio_threaded'] + if config.speed == 0: + config.run_ways += winio_ways + else: + config.other_ways += winio_ways + config.way_flags = { 'normal' : [], 'normal_h' : [], @@ -108,6 +116,8 @@ config.way_flags = { 'nonmoving_thr': ['-threaded'], 'nonmoving_thr_ghc': ['+RTS', '-xn', '-N2', '-RTS', '-threaded'], 'compacting_gc': [], + 'winio': [], + 'winio_threaded': ['-threaded'], } config.way_rts_flags = { @@ -150,6 +160,8 @@ config.way_rts_flags = { 'nonmoving_thr' : ['-xn', '-N2'], 'nonmoving_thr_ghc': ['-xn', '-N2'], 'compacting_gc': ['-c'], + 'winio': ['--io-manager=native'], + 'winio_threaded': ['--io-manager=native'], } # Useful classes of ways that can be used with only_ways(), omit_ways() and diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk index cb4b3747f5..b2cdf78f5f 100644 --- a/testsuite/mk/test.mk +++ b/testsuite/mk/test.mk @@ -60,7 +60,7 @@ TEST_HC_OPTS += -Werror=compat # removing this line. TEST_HC_OPTS += -dno-debug-output -TEST_HC_OPTS_INTERACTIVE = $(TEST_HC_OPTS) --interactive -v0 -ignore-dot-ghci -fno-ghci-history +TEST_HC_OPTS_INTERACTIVE = $(TEST_HC_OPTS) --interactive -v0 -ignore-dot-ghci -fno-ghci-history +RTS --io-manager=native -RTS RUNTEST_OPTS = diff --git a/testsuite/tests/backpack/cabal/T16219/backpack-issue.cabal b/testsuite/tests/backpack/cabal/T16219/backpack-issue.cabal index 69f47e8e54..3a15b2e705 100644 --- a/testsuite/tests/backpack/cabal/T16219/backpack-issue.cabal +++ b/testsuite/tests/backpack/cabal/T16219/backpack-issue.cabal @@ -1,8 +1,9 @@ +cabal-version: 2.2 name: backpack-issue version: 0.1.0.0 -- synopsis: -- description: -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Isaac Elliott maintainer: isaace71295@gmail.com @@ -10,7 +11,6 @@ maintainer: isaace71295@gmail.com -- category: build-type: Simple extra-source-files: CHANGELOG.md -cabal-version: >=2 library library-a signatures: A.Sig diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal index c46675f1ce..8955d65329 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal01 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library impl exposed-modules: H, I diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal index 92ba58633a..a94a6521a7 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal01 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library p signatures: H diff --git a/testsuite/tests/backpack/cabal/bkpcabal03/asig1/asig1.cabal b/testsuite/tests/backpack/cabal/bkpcabal03/asig1/asig1.cabal index f45c925414..3977ac1927 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal03/asig1/asig1.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal03/asig1/asig1.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: asig1 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library build-depends: base diff --git a/testsuite/tests/backpack/cabal/bkpcabal03/asig2/asig2.cabal b/testsuite/tests/backpack/cabal/bkpcabal03/asig2/asig2.cabal index 1d802d8fe3..e97ccbdc7e 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal03/asig2/asig2.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal03/asig2/asig2.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: asig2 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library build-depends: base diff --git a/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in1 b/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in1 index 689a7c87be..8fb32a789d 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in1 +++ b/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in1 @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal03 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library build-depends: asig1, base diff --git a/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in2 b/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in2 index a25c7fed46..8db22c1da7 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in2 +++ b/testsuite/tests/backpack/cabal/bkpcabal03/bkpcabal03.cabal.in2 @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal03 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library build-depends: asig1, asig2, base diff --git a/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in1 b/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in1 index 1ce11c5bcc..456c9f92c7 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in1 +++ b/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in1 @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal04 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library p signatures: A diff --git a/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in2 b/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in2 index e6fa4c6660..f15f5ac520 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in2 +++ b/testsuite/tests/backpack/cabal/bkpcabal04/bkpcabal04.cabal.in2 @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal04 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library p signatures: A diff --git a/testsuite/tests/backpack/cabal/bkpcabal05/bkpcabal05.cabal b/testsuite/tests/backpack/cabal/bkpcabal05/bkpcabal05.cabal index 47e78a4b74..723f105ce3 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal05/bkpcabal05.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal05/bkpcabal05.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal05 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.25 library signatures: A diff --git a/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.cabal b/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.cabal index ff322a4e02..e62687dcc0 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal06 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: 2.0 library sig signatures: P diff --git a/testsuite/tests/backpack/cabal/bkpcabal07/bkpcabal07.cabal b/testsuite/tests/backpack/cabal/bkpcabal07/bkpcabal07.cabal index 4f66fc44a9..db4d04e9da 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal07/bkpcabal07.cabal +++ b/testsuite/tests/backpack/cabal/bkpcabal07/bkpcabal07.cabal @@ -1,10 +1,10 @@ +cabal-version: 2.2 name: bkpcabal06 version: 0.1.0.0 -license: BSD3 +license: BSD-3-Clause author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=2.0 library indef signatures: P diff --git a/testsuite/tests/cabal/cabal01/test.cabal b/testsuite/tests/cabal/cabal01/test.cabal index b5c3b74ebe..c37f41c648 100644 --- a/testsuite/tests/cabal/cabal01/test.cabal +++ b/testsuite/tests/cabal/cabal01/test.cabal @@ -1,3 +1,4 @@ +Cabal-Version: 2.2 Name: test Version: 1.0 Exposed-Modules: A diff --git a/testsuite/tests/cabal/cabal04/Makefile b/testsuite/tests/cabal/cabal04/Makefile index e9366fa349..e8b3aab3ac 100644 --- a/testsuite/tests/cabal/cabal04/Makefile +++ b/testsuite/tests/cabal/cabal04/Makefile @@ -14,7 +14,7 @@ cabal04: $(MAKE) -s --no-print-directory clean '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup $(SETUP) clean - $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' $(VANILLA) $(PROF) $(DYN) + $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -with-rtsopts="--io-manager=native",$(filter-out -rtsopts,$(TEST_HC_OPTS)))' $(VANILLA) $(PROF) $(DYN) $(SETUP) build 2> err ! grep -v "Creating library file" err ifneq "$(CLEANUP)" "" diff --git a/testsuite/tests/cabal/cabal06/p-1.0/p.cabal b/testsuite/tests/cabal/cabal06/p-1.0/p.cabal index ab7b3ebffe..00336e7bae 100644 --- a/testsuite/tests/cabal/cabal06/p-1.0/p.cabal +++ b/testsuite/tests/cabal/cabal06/p-1.0/p.cabal @@ -4,7 +4,7 @@ license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.20 +cabal-version: 2.0 library exposed-modules: P diff --git a/testsuite/tests/cabal/cabal06/p-1.1/p.cabal b/testsuite/tests/cabal/cabal06/p-1.1/p.cabal index 8a7b7b271d..31ba170e04 100644 --- a/testsuite/tests/cabal/cabal06/p-1.1/p.cabal +++ b/testsuite/tests/cabal/cabal06/p-1.1/p.cabal @@ -4,7 +4,7 @@ license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.20 +cabal-version: 2.0 library exposed-modules: P diff --git a/testsuite/tests/cabal/cabal06/q/q.cabal b/testsuite/tests/cabal/cabal06/q/q.cabal index 7b3a074f88..770c0bfc3f 100644 --- a/testsuite/tests/cabal/cabal06/q/q.cabal +++ b/testsuite/tests/cabal/cabal06/q/q.cabal @@ -4,7 +4,7 @@ license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.20 +cabal-version: 2.0 library exposed-modules: Q diff --git a/testsuite/tests/cabal/cabal06/r/r.cabal b/testsuite/tests/cabal/cabal06/r/r.cabal index 60e16c1c78..2df73e0ed3 100644 --- a/testsuite/tests/cabal/cabal06/r/r.cabal +++ b/testsuite/tests/cabal/cabal06/r/r.cabal @@ -4,7 +4,7 @@ license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple -cabal-version: >=1.20 +cabal-version: 2.0 executable cabal06 build-depends: base, p, q diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index a0bcebf889..c83d29b03d 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -40,9 +40,6 @@ expectedGhcOnlyExtensions = [ "RelaxedLayout" , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" - , "LinearTypes" - , "QualifiedDo" - , "LexicalNegation" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/ghci/linking/dyn/Makefile b/testsuite/tests/ghci/linking/dyn/Makefile index ee345e5560..ee53d0463e 100644 --- a/testsuite/tests/ghci/linking/dyn/Makefile +++ b/testsuite/tests/ghci/linking/dyn/Makefile @@ -24,7 +24,7 @@ else CFLAGS = -fPIC endif -MY_TEST_HC_OPTS = $(filter-out -rtsopts,$(TEST_HC_OPTS)) $(CFLAGS) +MY_TEST_HC_OPTS = $(TEST_HC_OPTS) $(CFLAGS) # -------------------------------------------------------------- # Note: libAS.def is not used directly in these tests but is diff --git a/testsuite/tests/ghci/linking/dyn/T10955dyn.stderr b/testsuite/tests/ghci/linking/dyn/T10955dyn.stderr new file mode 100644 index 0000000000..e69dbaad75 --- /dev/null +++ b/testsuite/tests/ghci/linking/dyn/T10955dyn.stderr @@ -0,0 +1,4 @@ +Warning: -rtsopts and -with-rtsopts have no effect with -shared. + Call hs_init_ghc() from your main() function to set these options. +Warning: -rtsopts and -with-rtsopts have no effect with -shared. + Call hs_init_ghc() from your main() function to set these options. diff --git a/testsuite/tests/ghci/linking/dyn/load_short_name.stderr b/testsuite/tests/ghci/linking/dyn/load_short_name.stderr new file mode 100644 index 0000000000..cd2812b10c --- /dev/null +++ b/testsuite/tests/ghci/linking/dyn/load_short_name.stderr @@ -0,0 +1,2 @@ +Warning: -rtsopts and -with-rtsopts have no effect with -shared. + Call hs_init_ghc() from your main() function to set these options. diff --git a/utils/fs/fs.c b/utils/fs/fs.c index 51f45eb2d0..ebed2ca0fc 100644 --- a/utils/fs/fs.c +++ b/utils/fs/fs.c @@ -412,7 +412,7 @@ int FS(_stat64) (const char *path, struct __stat64 *buffer) static __time64_t ftToPosix(FILETIME ft) { - // takes the last modified date + /* takes the last modified date. */ LARGE_INTEGER date, adjust; date.HighPart = ft.dwHighDateTime; date.LowPart = ft.dwLowDateTime; diff --git a/utils/fs/fs.h b/utils/fs/fs.h index cb04d54127..9e4b8e2052 100644 --- a/utils/fs/fs.h +++ b/utils/fs/fs.h @@ -45,6 +45,5 @@ int FS(_wunlink) (const wchar_t *filename); int FS(remove) (const char *path); int FS(_wremove) (const wchar_t *path); #else - FILE *FS(fopen) (const char* filename, const char* mode); #endif diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 31d363c0fa..3fe744fec3 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -919,6 +919,8 @@ ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x ++ " " ++ ppType y +ppType (TyApp (TyCon "IOPort#") [x,y]) = "mkIOPortPrimTy " ++ ppType x + ++ " " ++ ppType y ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp (TyCon "Void#") []) = "voidPrimTy" diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index 381bc53a02..a964e55070 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -22,10 +22,11 @@ CABAL_CONSTRAINT := --constraint="Cabal == $(CABAL_DOTTED_VERSION)" # generate MIN_VERSION_<pkgname>() CPP macros. The generation of those # macros is triggered by `-hide-all-packages`, so we have to explicitly # enumerate all packages we need in scope. +CABAL_BUILD_DEPS := ghc-prim base binary array transformers time containers bytestring deepseq process pretty directory filepath template-haskell ifeq "$(Windows_Host)" "YES" -CABAL_BUILD_DEPS := ghc-prim base array transformers time containers bytestring deepseq process pretty directory filepath Win32 template-haskell +CABAL_BUILD_DEPS += Win32 else -CABAL_BUILD_DEPS := ghc-prim base array transformers time containers bytestring deepseq process pretty directory filepath unix template-haskell +CABAL_BUILD_DEPS += unix endif ghc-cabal_DIST_BINARY_NAME = ghc-cabal$(exeext0) @@ -65,7 +66,6 @@ $(ghc-cabal_DIST_BINARY): $(CABAL_LEXER_DEP) utils/ghc-cabal/Main.hs $(TOUCH_DEP -no-user-package-db \ -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ -DCABAL_VERSION=$(CABAL_VERSION) \ - -DCABAL_PARSEC \ -DBOOTSTRAPPING \ -odir bootstrapping \ -hidir bootstrapping \ diff --git a/utils/hp2ps/Main.h b/utils/hp2ps/Main.h index da856f4884..4c6101f2bb 100644 --- a/utils/hp2ps/Main.h +++ b/utils/hp2ps/Main.h @@ -24,7 +24,7 @@ void _stgAssert PROTO((char *, unsigned int)); /* partain: some ubiquitous types: floatish & intish. Dubious to use float/int, but that is what it used to be... - (WDP 95/03) + (WDP 95/03) */ typedef double floatish; typedef double doublish; /* higher precision, if anything; little used */ diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject e792dd8e5589d42a4d416f78df8efb70995f95e +Subproject 7accbea001bcac638c4320d3755af2947811490 |