Enable RemoteGHCi on Windows

Makes the needed changes to make RemoteGHCi work on Windows.
The approach passes OS Handles areound instead of the Posix Fd
as on Linux.

The reason is that I could not find any real documentation about
the behaviour of Windows w.r.t inheritance and Posix FDs.

The implementation with Fd did not seem to be able to find the Fd
in the child process. Instead I'm using the much better documented
approach of passing inheriting handles.

This requires a small modification to the `process` library.
https://github.com/haskell/process/pull/52

Test Plan: ./validate On Windows x86_64

Reviewers: thomie, erikd, bgamari, simonmar, austin, hvr

Reviewed By: simonmar

Subscribers: #ghc_windows_task_force

Differential Revision: https://phabricator.haskell.org/D1836

GHC Trac Issues: #11100

9 files changed, 81 insertions, 38 deletions

diff --git a/.gitignore b/.gitignore
index 5c2af906e9..bc95f12aec 100644
--- a/.gitignore
+++ b/.gitignore
@@ -73,6 +73,7 @@ _darcs/
 /ghc/stage2/
 /ghc/stage3/
 /iserv/stage2*/
+/iserv/dist/
 
 # -----------------------------------------------------------------------------
 # specific generated files
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index a6109314de..08285a88ae 100644
--- a/compiler/ghci/GHCi.hs
+++ b/compiler/ghci/GHCi.hs
@@ -52,10 +52,8 @@ import HscTypes
 import UniqFM
 import Panic
 import DynFlags
-#ifndef mingw32_HOST_OS
 import ErrUtils
 import Outputable
-#endif
 import Exception
 import BasicTypes
 import FastString
@@ -70,8 +68,11 @@ import Foreign
 import Foreign.C
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Exit
-#ifndef mingw32_HOST_OS
 import Data.Maybe
+import GHC.IO.Handle.Types (Handle)
+#ifdef mingw32_HOST_OS
+import GHC.IO.Handle.FD (fdToHandle)
+#else
 import System.Posix as Posix
 #endif
 import System.Process
@@ -396,11 +397,6 @@ handleIServFailure IServ{..} e = do
 -- Starting and stopping the iserv process
 
 startIServ :: DynFlags -> IO IServ
-#ifdef mingw32_HOST_OS
-startIServ _ = panic "startIServ"
-  -- should not be called, because we disable -fexternal-interpreter on Windows.
-  -- (see DynFlags.makeDynFlagsConsistent)
-#else
 startIServ dflags = do
   let flavour
         | WayProf `elem` ways dflags = "-prof"
@@ -409,16 +405,7 @@ startIServ dflags = do
       prog = pgm_i dflags ++ flavour
       opts = getOpts dflags opt_i
   debugTraceMsg dflags 3 $ text "Starting " <> text prog
-  (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
-  (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
-  setFdOption rfd1 CloseOnExec True
-  setFdOption wfd2 CloseOnExec True
-  let args = show wfd1 : show rfd2 : opts
-  (_, _, _, ph) <- createProcess (proc prog args)
-  closeFd wfd1
-  closeFd rfd2
-  rh <- fdToHandle rfd1
-  wh <- fdToHandle wfd2
+  (ph, rh, wh) <- runWithPipes prog opts
   lo_ref <- newIORef Nothing
   cache_ref <- newIORef emptyUFM
   return $ IServ
@@ -429,12 +416,8 @@ startIServ dflags = do
     , iservLookupSymbolCache = cache_ref
     , iservPendingFrees = []
     }
-#endif
 
 stopIServ :: HscEnv -> IO ()
-#ifdef mingw32_HOST_OS
-stopIServ _ = return ()
-#else
 stopIServ HscEnv{..} =
   gmask $ \_restore -> do
     m <- takeMVar hsc_iserv
@@ -446,6 +429,40 @@ stopIServ HscEnv{..} =
     if isJust ex
        then return ()
        else iservCall iserv Shutdown
+
+runWithPipes :: FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+#ifdef mingw32_HOST_OS
+foreign import ccall "io.h _close"
+   c__close :: CInt -> IO CInt
+
+foreign import ccall unsafe "io.h _get_osfhandle"
+   _get_osfhandle :: CInt -> IO CInt
+
+runWithPipes prog opts = do
+    (rfd1, wfd1) <- createPipeFd -- we read on rfd1
+    (rfd2, wfd2) <- createPipeFd -- we write on wfd2
+    wh_client    <- _get_osfhandle wfd1
+    rh_client    <- _get_osfhandle rfd2
+    let args = show wh_client : show rh_client : opts
+    (_, _, _, ph) <- createProcess (proc prog args)
+    rh <- mkHandle rfd1
+    wh <- mkHandle wfd2
+    return (ph, rh, wh)
+      where mkHandle :: CInt -> IO Handle
+            mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
+#else
+runWithPipes prog opts = do
+    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+    setFdOption rfd1 CloseOnExec True
+    setFdOption wfd2 CloseOnExec True
+    let args = show wfd1 : show rfd2 : opts
+    (_, _, _, ph) <- createProcess (proc prog args)
+    closeFd wfd1
+    closeFd rfd2
+    rh <- fdToHandle rfd1
+    wh <- fdToHandle wfd2
+    return (ph, rh, wh)
 #endif
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 22c2915960..0e9d4207d4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -4413,13 +4413,6 @@ makeDynFlagsConsistent dflags
     = let dflags' = gopt_unset dflags Opt_BuildDynamicToo
           warn    = "-dynamic-too is not supported on Windows"
       in loop dflags' warn
- -- Disalbe -fexternal-interpreter on Windows.  This is a temporary measure;
- -- all that is missing is the implementation of the interprocess communication
- -- which uses pipes on POSIX systems. (#11100)
- | os == OSMinGW32 && gopt Opt_ExternalInterpreter dflags
-    = let dflags' = gopt_unset dflags Opt_ExternalInterpreter
-          warn    = "-fexternal-interpreter is currently not supported on Windows"
-      in loop dflags' warn
  | hscTarget dflags == HscC &&
    not (platformUnregisterised (targetPlatform dflags))
     = if cGhcWithNativeCodeGen == "YES"
diff --git a/ghc.mk b/ghc.mk
index 0759961200..8257cf0337 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -670,9 +670,7 @@ BUILD_DIRS += utils/mkUserGuidePart
 BUILD_DIRS += docs/users_guide
 BUILD_DIRS += utils/count_lines
 BUILD_DIRS += utils/compare_sizes
-ifneq "$(Windows_Host)" "YES"
 BUILD_DIRS += iserv
-endif
 
 # ----------------------------------------------
 # Actually include the sub-ghc.mk's
diff --git a/iserv/iservmain.c b/iserv/cbits/iservmain.c
index f7eb5664c5..f7eb5664c5 100644
--- a/iserv/iservmain.c
+++ b/iserv/cbits/iservmain.c
diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
index a770b4fc99..3fd5d2bd28 100644
--- a/iserv/iserv-bin.cabal
+++ b/iserv/iserv-bin.cabal
@@ -15,12 +15,16 @@ cabal-version: >=1.10
 Executable iserv
     Default-Language: Haskell2010
     Main-Is: Main.hs
-    C-Sources: iservmain.c
+    C-Sources: cbits/iservmain.c
+    Hs-Source-Dirs: src
+    Other-Modules: GHCi.Utils
     Build-Depends: array      >= 0.5 && < 0.6,
                    base       >= 4   && < 5,
-                   unix       >= 2.7 && < 2.8,
                    binary     >= 0.7 && < 0.9,
                    bytestring >= 0.10 && < 0.11,
                    containers >= 0.5 && < 0.6,
                    deepseq    >= 1.4 && < 1.5,
                    ghci       == 8.1
+
+    if !os(windows)
+        Build-Depends: unix   >= 2.7 && < 2.8
diff --git a/iserv/src/GHCi/Utils.hsc b/iserv/src/GHCi/Utils.hsc
new file mode 100644
index 0000000000..b90cfacb5f
--- /dev/null
+++ b/iserv/src/GHCi/Utils.hsc
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+module GHCi.Utils
+    ( getGhcHandle
+    ) where
+
+import Foreign.C
+import GHC.IO.Handle (Handle())
+#ifdef mingw32_HOST_OS
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import System.Posix
+#endif
+
+#include <fcntl.h>     /* for _O_BINARY */
+
+-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
+getGhcHandle :: CInt -> IO Handle
+#ifdef mingw32_HOST_OS
+getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle
+
+foreign import ccall "io.h _open_osfhandle" _open_osfhandle ::
+    CInt -> CInt -> IO CInt
+#else
+getGhcHandle fd     = fdToHandle $ Fd fd
+#endif
diff --git a/iserv/Main.hs b/iserv/src/Main.hs
index cbaf9277d5..46ae82b464 100644
--- a/iserv/Main.hs
+++ b/iserv/src/Main.hs
@@ -5,6 +5,7 @@ import GHCi.Run
 import GHCi.TH
 import GHCi.Message
 import GHCi.Signals
+import GHCi.Utils
 
 import Control.DeepSeq
 import Control.Exception
@@ -13,7 +14,6 @@ import Data.Binary
 import Data.IORef
 import System.Environment
 import System.Exit
-import System.Posix
 import Text.Printf
 
 main :: IO ()
@@ -22,13 +22,13 @@ main = do
   let wfd1 = read arg0; rfd2 = read arg1
   verbose <- case rest of
     ["-v"] -> return True
-    [] -> return False
-    _ -> die "iserv: syntax: iserv <write-fd> <read-fd> [-v]"
+    []     -> return False
+    _      -> die "iserv: syntax: iserv <write-fd> <read-fd> [-v]"
   when verbose $ do
     printf "GHC iserv starting (in: %d; out: %d)\n"
       (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
-  inh <- fdToHandle rfd2
-  outh <- fdToHandle wfd1
+  inh  <- getGhcHandle rfd2
+  outh <- getGhcHandle wfd1
   installSignalHandlers
   lo_ref <- newIORef Nothing
   let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
diff --git a/mk/warnings.mk b/mk/warnings.mk
index abbee68735..10c0935348 100644
--- a/mk/warnings.mk
+++ b/mk/warnings.mk
@@ -61,6 +61,11 @@ ifeq "$(HostOS_CPP)" "mingw32"
 libraries/time_dist-install_EXTRA_HC_OPTS += -Wno-unused-imports -Wno-identities
 endif
 
+# On Windows, the pattern for CallConv is already exaustive. Ignore the warning
+ifeq "$(HostOS_CPP)" "mingw32"
+libraries/ghci_dist-install_EXTRA_HC_OPTS += -Wno-overlapping-patterns
+endif
+
 # haskeline has warnings about deprecated use of block/unblock
 libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-deprecations
 libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-unused-imports