diff options
Diffstat (limited to 'compiler/ghci/GHCi.hs')
| -rw-r--r-- | compiler/ghci/GHCi.hs | 61 |
1 files changed, 39 insertions, 22 deletions
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 -- ----------------------------------------------------------------------------- |