diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 2c84980513a1f0063f4ccf79112fe5fdf486344e..ed906279cc578fca412cbd07de157fbee5811879 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -113,6 +113,11 @@ import GHC.IO.Handle.Types (Handle)
#if defined(mingw32_HOST_OS)
import Foreign.C
import GHC.IO.Handle.FD (fdToHandle)
+# if defined(__IO_MANAGER_WINIO__)
+import GHC.IO.SubSystem ((<!>))
+import GHC.IO.Handle.Windows (handleToHANDLE)
+import GHC.Event.Windows (associateHandle')
+# endif
#else
import System.Posix as Posix
#endif
@@ -606,7 +611,9 @@ foreign import ccall "io.h _close"
foreign import ccall unsafe "io.h _get_osfhandle"
_get_osfhandle :: CInt -> IO CInt
-runWithPipes createProc prog opts = do
+runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle)
+ -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+runWithPipesPOSIX createProc prog opts = do
(rfd1, wfd1) <- createPipeFd -- we read on rfd1
(rfd2, wfd2) <- createPipeFd -- we write on wfd2
wh_client <- _get_osfhandle wfd1
@@ -619,6 +626,27 @@ runWithPipes createProc prog opts = do
where mkHandle :: CInt -> IO Handle
mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)
+# if defined (__IO_MANAGER_WINIO__)
+runWithPipesNative :: (CreateProcess -> IO ProcessHandle)
+ -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+runWithPipesNative createProc prog opts = do
+ (rh, wfd1) <- createPipe -- we read on rfd1
+ (rfd2, wh) <- createPipe -- we write on wfd2
+ wh_client <- handleToHANDLE wfd1
+ rh_client <- handleToHANDLE rfd2
+ -- Associate the handle with the current manager
+ -- but don't touch the ones we're passing to the child
+ -- since it needs to register the handle with its own manager.
+ associateHandle' =<< handleToHANDLE rh
+ associateHandle' =<< handleToHANDLE wh
+ let args = show wh_client : show rh_client : opts
+ ph <- createProc (proc prog args)
+ return (ph, rh, wh)
+
+runWithPipes = runWithPipesPOSIX <!> runWithPipesNative
+# else
+runWithPipes = runWithPipesPOSIX
+# endif
#else
runWithPipes createProc prog opts = do
(rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index 6929e538c68c16cc3fc29ff870252813894a8145..778d6e08e595825ee153d80e8e09e8b414d3b6c7 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -68,7 +68,7 @@ module GHC.Event.Windows (
module GHC.Event.Windows.ConsoleEvent
) where
--- define DEBUG 1
+-- #define DEBUG 1
-- #define DEBUG_TRACE 1
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 6b23f913cb00761a76cf665a4b9d6f443c4cb6f2..d660c10932633ab312130b8f8b0bb0ff2a15765a 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -618,7 +618,7 @@ getBin h get leftover = go leftover (runGetIncremental get)
go Nothing (Partial fun) = do
-- putStrLn "before hGetSome"
b <- B.hGetSome h (32*1024)
- -- printf "hGetSome: %d\n" (B.length b)
+ -- putStrLn $ "hGetSome: " ++ show (B.length b)
if B.null b
then return Nothing
else go Nothing (fun (Just b))
diff --git a/libraries/libiserv/src/GHCi/Utils.hsc b/libraries/libiserv/src/GHCi/Utils.hsc
index f606eb9d94658220ed2f288bbbe6c1915dd31322..6b6613ad1bb3471358f0ac9c2911a01ab9dffe85 100644
--- a/libraries/libiserv/src/GHCi/Utils.hsc
+++ b/libraries/libiserv/src/GHCi/Utils.hsc
@@ -6,7 +6,16 @@ module GHCi.Utils
import Foreign.C
import GHC.IO.Handle (Handle())
#if defined(mingw32_HOST_OS)
+import Foreign.Ptr (ptrToIntPtr)
+import GHC.IO (onException)
import GHC.IO.Handle.FD (fdToHandle)
+import GHC.Windows (HANDLE)
+import GHC.IO.SubSystem ((<!>))
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+import GHC.IO.Device as IODevice
+import GHC.IO.Encoding (getLocaleEncoding)
+import GHC.IO.IOMode
+import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
#else
import System.Posix
#endif
@@ -14,12 +23,28 @@ import System.Posix
#include <fcntl.h> /* for _O_BINARY */
-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
-getGhcHandle :: CInt -> IO Handle
+
#if defined(mingw32_HOST_OS)
-getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle
+getGhcHandle :: HANDLE -> IO Handle
+getGhcHandle = getGhcHandlePOSIX <!> getGhcHandleNative
+
+getGhcHandlePOSIX :: HANDLE -> IO Handle
+getGhcHandlePOSIX handle = do
+ let intptr = ptrToIntPtr handle
+ _open_osfhandle (fromIntegral intptr) (#const _O_BINARY) >>= fdToHandle
+
+getGhcHandleNative :: HANDLE -> IO Handle
+getGhcHandleNative hwnd =
+ do mb_codec <- fmap Just getLocaleEncoding
+ let iomode = ReadWriteMode
+ native_handle = fromHANDLE hwnd :: Io NativeHandle
+ hw_type <- IODevice.devType $ native_handle
+ mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec
+ `onException` IODevice.close native_handle
foreign import ccall "io.h _open_osfhandle" _open_osfhandle ::
CInt -> CInt -> IO CInt
#else
+getGhcHandle :: CInt -> IO Handle
getGhcHandle fd = fdToHandle $ Fd fd
#endif
diff --git a/utils/iserv/src/Main.hs b/utils/iserv/src/Main.hs
index a73efacb2b09aa20ee36ec75633e6ea77dd8db77..95e43b93c9cb497b8a86106038c4043452048269 100644
--- a/utils/iserv/src/Main.hs
+++ b/utils/iserv/src/Main.hs
@@ -21,6 +21,14 @@ import Data.IORef
import System.Environment
import System.Exit
import Text.Printf
+#if defined(WINDOWS)
+import Foreign.Ptr (wordPtrToPtr)
+# if defined(__IO_MANAGER_WINIO__)
+import GHC.IO.SubSystem ((<!>))
+import GHC.IO.Handle.Windows (handleToHANDLE)
+import GHC.Event.Windows (associateHandle')
+# endif
+#endif
dieWithUsage :: IO a
dieWithUsage = do
@@ -36,12 +44,27 @@ dieWithUsage = do
main :: IO ()
main = do
args <- getArgs
- (wfd1, rfd2, rest) <-
+ (outh, inh, rest) <-
case args of
arg0:arg1:rest -> do
+#if defined(WINDOWS)
+ let wfd1 = wordPtrToPtr (read arg0)
+ rfd2 = wordPtrToPtr (read arg1)
+# if defined(__IO_MANAGER_WINIO__)
+ -- register the handles we received with
+ -- our I/O manager otherwise we can't use
+ -- them correctly.
+ return () <!> (do
+ associateHandle' wfd1
+ associateHandle' rfd2)
+# endif
+#else
let wfd1 = read arg0
rfd2 = read arg1
- return (wfd1, rfd2, rest)
+#endif
+ inh <- getGhcHandle rfd2
+ outh <- getGhcHandle wfd1
+ return (outh, inh, rest)
_ -> dieWithUsage
(verbose, rest') <- case rest of
@@ -56,10 +79,7 @@ main = do
dieWithUsage
when verbose $
- printf "GHC iserv starting (in: %d; out: %d)\n"
- (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
- inh <- getGhcHandle rfd2
- outh <- getGhcHandle wfd1
+ printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh)
installSignalHandlers
lo_ref <- newIORef Nothing
let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}