Commit 44a5d51a authored by Tamar Christina's avatar Tamar Christina Committed by Ben Gamari

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
parent e2bdf03a
......@@ -73,6 +73,7 @@ _darcs/
/ghc/stage2/
/ghc/stage3/
/iserv/stage2*/
/iserv/dist/
# -----------------------------------------------------------------------------
# specific generated files
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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"
......
......@@ -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
......
......@@ -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
{-# 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
......@@ -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}
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment