winio: add support to iserv.

5 files changed, 84 insertions, 11 deletions

diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 2c84980513..ed906279cc 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 6929e538c6..778d6e08e5 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 6b23f913cb..d660c10932 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 f606eb9d94..6b6613ad1b 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 a73efacb2b..95e43b93c9 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}