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.
haskell/process#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

.gitignore

@@ -73,6 +73,7 @@ _darcs/
 /ghc/stage2/
 /ghc/stage3/
 /iserv/stage2*/
+/iserv/dist/
 
 # -----------------------------------------------------------------------------
 # specific generated files

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
 
 -- -----------------------------------------------------------------------------

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"

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

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

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

iserv/Main.hs → 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}

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