diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | compiler/ghci/GHCi.hs | 61 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 7 | ||||
| -rw-r--r-- | ghc.mk | 2 | ||||
| -rw-r--r-- | iserv/cbits/iservmain.c (renamed from iserv/iservmain.c) | 0 | ||||
| -rw-r--r-- | iserv/iserv-bin.cabal | 8 | ||||
| -rw-r--r-- | iserv/src/GHCi/Utils.hsc | 25 | ||||
| -rw-r--r-- | iserv/src/Main.hs (renamed from iserv/Main.hs) | 10 | ||||
| -rw-r--r-- | mk/warnings.mk | 5 |
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" @@ -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 |