Commit 18757cab authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor runtime interpreter code

In #14335 we want to be able to use both the internal interpreter (for
the plugins) and the external interpreter (for TH and GHCi) at the same
time.

This patch performs some preliminary refactoring: the `hsc_interp` field
of HscEnv replaces `hsc_iserv` and is now used to indicate which
interpreter (internal, external) to use to execute TH and GHCi.

Opt_ExternalInterpreter flag and iserv options in DynFlags are now
queried only when we set the session DynFlags. It should help making GHC
multi-target in the future by selecting an interpreter according to the
selected target.
parent b5fb58fd
Pipeline #16336 failed with stages
in 18 minutes and 43 seconds
......@@ -299,11 +299,13 @@ import GHC.ByteCode.Types
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
import GHC.Core.Ppr.TyThing ( pprFamInst )
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Pipeline ( compileOne' )
import GHC.Driver.Monad
import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
......@@ -373,6 +375,8 @@ import System.Exit ( exitWith, ExitCode(..) )
import Exception
import Data.IORef
import System.FilePath
import Control.Concurrent
import Control.Applicative ((<|>))
import Maybes
import System.IO.Error ( isDoesNotExistError )
......@@ -486,7 +490,7 @@ withCleanupSession ghc = ghc `gfinally` cleanup
liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
stopIServ hsc_env -- shut down the IServ
stopInterp hsc_env -- shut down the IServ
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
......@@ -594,8 +598,42 @@ setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- liftIO $ interpretPackageEnv dflags'
(dflags''', preload) <- liftIO $ initPackages dflags''
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
then do
let
prog = pgm_i dflags ++ flavour
flavour
| WayProf `elem` ways dflags = "-prof"
| WayDyn `elem` ways dflags = "-dyn"
| otherwise = ""
msg = text "Starting " <> text prog
tr <- if verbosity dflags >= 3
then return (logInfo dflags (defaultDumpStyle dflags) msg)
else return (pure ())
let
conf = IServConfig
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
}
s <- liftIO $ newMVar (IServPending conf)
return (Just (ExternalInterp (IServ s)))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
return (Just InternalInterp)
#else
return Nothing
#endif
modifySession $ \h -> h{ hsc_dflags = dflags'''
, hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } }
, hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }
, hsc_interp = hsc_interp h <|> interp
-- we only update the interpreter if there wasn't
-- already one set up
}
invalidateModSummaryCache
return preload
......
......@@ -19,6 +19,7 @@ import GHC.ByteCode.Asm
import GHC.ByteCode.Types
import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
import GHCi.FFI
import GHCi.RemoteTypes
import BasicTypes
......@@ -991,9 +992,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise
= do
dflags <- getDynFlags
hsc_env <- getHscEnv
let
profiling
| gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
| Just (ExternalInterp _) <- hsc_interp hsc_env = gopt Opt_SccProfilingOn dflags
| otherwise = rtsIsProfiled
-- Top of stack is the return itbl, as usual.
......
......@@ -99,7 +99,6 @@ import GHC.Core.Lint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
import Panic
import ConLike
import Control.Concurrent
import ApiAnnotation
import Module
......@@ -197,7 +196,6 @@ newHscEnv dflags = do
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
iserv_mvar <- newMVar Nothing
emptyDynLinker <- uninitializedLinker
return HscEnv { hsc_dflags = dflags
, hsc_targets = []
......@@ -208,7 +206,7 @@ newHscEnv dflags = do
, hsc_NC = nc_var
, hsc_FC = fc_var
, hsc_type_env_var = Nothing
, hsc_iserv = iserv_mvar
, hsc_interp = Nothing
, hsc_dynLinker = emptyDynLinker
}
......
......@@ -22,7 +22,6 @@ module GHC.Driver.Types (
FinderCache, FindResult(..), InstalledFindResult(..),
Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,
HscStatus(..),
IServ(..),
-- * ModuleGraph
ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG,
......@@ -157,8 +156,7 @@ import GhcPrelude
import GHC.ByteCode.Types
import GHC.Runtime.Eval.Types ( Resume )
import GHCi.Message ( Pipe )
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter.Types (Interp)
import GHC.ForeignSrcLang
import UniqFM
......@@ -221,8 +219,6 @@ import Data.IORef
import Data.Time
import Exception
import System.FilePath
import Control.Concurrent
import System.Process ( ProcessHandle )
import Control.DeepSeq
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
......@@ -473,15 +469,43 @@ data HscEnv
-- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for
-- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack]
, hsc_iserv :: MVar (Maybe IServ)
-- ^ interactive server process. Created the first
-- time it is needed.
, hsc_interp :: Maybe Interp
-- ^ target code interpreter (if any) to use for TH and GHCi.
-- See Note [Target code interpreter]
, hsc_dynLinker :: DynLinker
-- ^ dynamic linker.
}
{-
Note [Target code interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Template Haskell and GHCi use an interpreter to execute code that is built for
the compiler target platform (= code host platform) on the compiler host
platform (= code build platform).
The internal interpreter can be used when both platforms are the same and when
the built code is compatible with the compiler itself (same way, etc.). This
interpreter is not always available: for instance stage1 compiler doesn't have
it because there might be an ABI mismatch between the code objects (built by
stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).
In most cases, an external interpreter can be used instead: it runs in a
separate process and it communicates with the compiler via a two-way message
passing channel. The process is lazily spawned to avoid overhead when it is not
used.
The target code interpreter to use can be selected per session via the
`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in
which case Template Haskell and GHCi will fail to run. The interpreter to use is
configured via command-line flags (in `GHC.setSessionDynFlags`).
-}
-- Note [hsc_type_env_var hack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- hsc_type_env_var is used to initialize tcg_type_env_var, and
......@@ -524,14 +548,6 @@ data HscEnv
-- should not populate the EPS. But that's a refactor for
-- another day.
data IServ = IServ
{ iservPipe :: Pipe
, iservProcess :: ProcessHandle
, iservLookupSymbolCache :: IORef (UniqFM (Ptr ()))
, iservPendingFrees :: [HValueRef]
}
-- | Retrieve the ExternalPackageState cache.
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
......
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,
RecordWildCards, BangPatterns #-}
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
......@@ -51,6 +51,7 @@ import GhcPrelude
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Interpreter.Types
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Driver.Monad
......@@ -278,24 +279,25 @@ withVirtualCWD m = do
-- a virtual CWD is only necessary when we're running interpreted code in
-- the same process as the compiler.
if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
let ic = hsc_IC hsc_env
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
case ic_cwd ic of
Just dir -> liftIO $ setCurrentDirectory dir
Nothing -> return ()
return dir
reset_cwd orig_dir = do
virt_dir <- liftIO $ getCurrentDirectory
hsc_env <- getSession
let old_IC = hsc_IC hsc_env
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
gbracket set_cwd reset_cwd $ \_ -> m
case hsc_interp hsc_env of
Just (ExternalInterp _) -> m
_ -> do
let ic = hsc_IC hsc_env
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
case ic_cwd ic of
Just dir -> liftIO $ setCurrentDirectory dir
Nothing -> return ()
return dir
reset_cwd orig_dir = do
virt_dir <- liftIO $ getCurrentDirectory
hsc_env <- getSession
let old_IC = hsc_IC hsc_env
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
gbracket set_cwd reset_cwd $ \_ -> m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
......@@ -1213,8 +1215,9 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr expr = do
fhv <- compileParsedExprRemote expr
dflags <- getDynFlags
liftIO $ wormhole dflags fhv
hsc_env <- getSession
liftIO $ withInterp hsc_env $ \interp ->
wormhole interp fhv
-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
......@@ -1249,12 +1252,14 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
-- RTTI primitives
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x
| gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
| otherwise
= cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
#if defined(HAVE_INTERNAL_INTERPRETER)
obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case
InternalInterp -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
#else
obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case
#endif
ExternalInterp _ -> throwIO (InstallationError
"this operation requires -fno-external-interpreter")
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
......
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
--
-- | Interacting with the interpreter, whether it is running on an
......@@ -38,7 +40,8 @@ module GHC.Runtime.Interpreter
, findSystemLibrary
-- * Lower-level API using messages
, iservCmd, Message(..), withIServ, stopIServ
, iservCmd, Message(..), withIServ, withIServ_
, withInterp, stopInterp
, iservCall, readIServ, writeIServ
, purgeLookupSymbolCache
, freeHValueRefs
......@@ -50,6 +53,7 @@ module GHC.Runtime.Interpreter
import GhcPrelude
import GHC.Runtime.Interpreter.Types
import GHCi.Message
#if defined(HAVE_INTERNAL_INTERPRETER)
import GHCi.Run
......@@ -62,13 +66,10 @@ import GHC.Driver.Types
import UniqFM
import Panic
import GHC.Driver.Session
import ErrUtils
import Outputable
import Exception
import BasicTypes
import FastString
import Util
import GHC.Driver.Hooks
import Control.Concurrent
import Control.Monad
......@@ -157,11 +158,6 @@ Other Notes on Remote GHCi
* Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
-}
#if !defined(HAVE_INTERNAL_INTERPRETER)
needExtInt :: IO a
needExtInt = throwIO
(InstallationError "this operation requires -fexternal-interpreter")
#endif
-- | Run a command in the interpreter's context. With
-- @-fexternal-interpreter@, the command is serialized and sent to an
......@@ -169,23 +165,28 @@ needExtInt = throwIO
-- @Binary@ constraint). With @-fno-external-interpreter@ we execute
-- the command directly here.
iservCmd :: Binary a => HscEnv -> Message a -> IO a
iservCmd hsc_env@HscEnv{..} msg
| gopt Opt_ExternalInterpreter hsc_dflags =
withIServ hsc_env $ \iserv ->
uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
iservCall iserv msg
| otherwise = -- Just run it directly
iservCmd hsc_env msg = withInterp hsc_env $ \case
#if defined(HAVE_INTERNAL_INTERPRETER)
run msg
#else
needExtInt
InternalInterp -> run msg -- Just run it directly
#endif
(ExternalInterp i) -> withIServ_ i $ \iserv ->
uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
iservCall iserv msg
-- | Execute an action with the interpreter
--
-- Fails if no target code interpreter is available
withInterp :: HscEnv -> (Interp -> IO a) -> IO a
withInterp hsc_env action = case hsc_interp hsc_env of
Nothing -> throwIO (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")
Just i -> action i
-- Note [uninterruptibleMask_ and iservCmd]
--
-- If we receive an async exception, such as ^C, while communicating
-- with the iserv process then we will be out-of-sync and not be able
-- to recoever. Thus we use uninterruptibleMask_ during
-- to recover. Thus we use uninterruptibleMask_ during
-- communication. A ^C will be delivered to the iserv process (because
-- signals get sent to the whole process group) which will interrupt
-- the running computation and return an EvalException result.
......@@ -194,24 +195,37 @@ iservCmd hsc_env@HscEnv{..} msg
-- Overloaded because this is used from TcM as well as IO.
withIServ
:: (MonadIO m, ExceptionMonad m)
=> HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv{..} action =
=> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ (IServ mIServState) action = do
gmask $ \restore -> do
m <- liftIO $ takeMVar hsc_iserv
-- start the iserv process if we haven't done so yet
iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
`gonException` (liftIO $ putMVar hsc_iserv Nothing)
state <- liftIO $ takeMVar mIServState
iserv <- case state of
-- start the external iserv process if we haven't done so yet
IServPending conf ->
liftIO (spawnIServ conf)
`gonException` (liftIO $ putMVar mIServState state)
IServRunning inst -> return inst
let iserv' = iserv{ iservPendingFrees = [] }
(iserv'',a) <- (do
-- free any ForeignHValues that have been garbage collected.
let iserv' = iserv{ iservPendingFrees = [] }
a <- (do
liftIO $ when (not (null (iservPendingFrees iserv))) $
iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
-- run the inner action
restore $ action iserv)
`gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
liftIO $ putMVar hsc_iserv (Just iserv')
-- run the inner action
restore $ action iserv')
`gonException` (liftIO $ putMVar mIServState (IServRunning iserv'))
liftIO $ putMVar mIServState (IServRunning iserv'')
return a
withIServ_
:: (MonadIO m, ExceptionMonad m)
=> IServ -> (IServInstance -> m a) -> m a
withIServ_ iserv action = withIServ iserv $ \inst ->
(inst,) <$> action inst
-- -----------------------------------------------------------------------------
-- Wrappers around messages
......@@ -371,41 +385,45 @@ initObjLinker :: HscEnv -> IO ()
initObjLinker hsc_env = iservCmd hsc_env InitLinker
lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol hsc_env@HscEnv{..} str
| gopt Opt_ExternalInterpreter hsc_dflags =
-- Profiling of GHCi showed a lot of time and allocation spent
-- making cross-process LookupSymbol calls, so I added a GHC-side
-- cache which sped things up quite a lot. We have to be careful
-- to purge this cache when unloading code though.
withIServ hsc_env $ \iserv@IServ{..} -> do
cache <- readIORef iservLookupSymbolCache
case lookupUFM cache str of
Just p -> return (Just p)
Nothing -> do
m <- uninterruptibleMask_ $
iservCall iserv (LookupSymbol (unpackFS str))
case m of
Nothing -> return Nothing
Just r -> do
let p = fromRemotePtr r
writeIORef iservLookupSymbolCache $! addToUFM cache str p
return (Just p)
| otherwise =
lookupSymbol hsc_env str = withInterp hsc_env $ \case
#if defined(HAVE_INTERNAL_INTERPRETER)
fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#else
needExtInt
InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#endif
ExternalInterp i -> withIServ i $ \iserv -> do
-- Profiling of GHCi showed a lot of time and allocation spent
-- making cross-process LookupSymbol calls, so I added a GHC-side
-- cache which sped things up quite a lot. We have to be careful
-- to purge this cache when unloading code though.
let cache = iservLookupSymbolCache iserv
case lookupUFM cache str of
Just p -> return (iserv, Just p)
Nothing -> do
m <- uninterruptibleMask_ $
iservCall iserv (LookupSymbol (unpackFS str))
case m of
Nothing -> return (iserv, Nothing)
Just r -> do
let p = fromRemotePtr r
cache' = addToUFM cache str p
iserv' = iserv {iservLookupSymbolCache = cache'}
return (iserv', Just p)
lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
lookupClosure hsc_env str =
iservCmd hsc_env (LookupClosure str)
purgeLookupSymbolCache :: HscEnv -> IO ()
purgeLookupSymbolCache hsc_env@HscEnv{..} =
when (gopt Opt_ExternalInterpreter hsc_dflags) $
withIServ hsc_env $ \IServ{..} ->
writeIORef iservLookupSymbolCache emptyUFM
purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of
Nothing -> pure ()
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp (IServ mstate)) ->
modifyMVar_ mstate $ \state -> pure $ case state of
IServPending {} -> state
IServRunning iserv -> IServRunning
(iserv { iservLookupSymbolCache = emptyUFM })
-- | loadDLL loads a dynamic library using the OS's native linker
......@@ -460,74 +478,70 @@ findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
-- Raw calls and messages
-- | Send a 'Message' and receive the response from the iserv process
iservCall :: Binary a => IServ -> Message a -> IO a
iservCall iserv@IServ{..} msg =
remoteCall iservPipe msg
iservCall :: Binary a => IServInstance -> Message a -> IO a
iservCall iserv msg =
remoteCall (iservPipe iserv) msg
`catch` \(e :: SomeException) -> handleIServFailure iserv e
-- | Read a value from the iserv process
readIServ :: IServ -> Get a -> IO a
readIServ iserv@IServ{..} get =
readPipe iservPipe get
readIServ :: IServInstance -> Get a -> IO a
readIServ iserv get =
readPipe (iservPipe iserv) get
`catch` \(e :: SomeException) -> handleIServFailure iserv e
-- | Send a value to the iserv process
writeIServ :: IServ -> Put -> IO ()
writeIServ iserv@IServ{..} put =
writePipe iservPipe put
writeIServ :: IServInstance -> Put -> IO ()
writeIServ iserv put =
writePipe (iservPipe iserv) put
`catch` \(e :: SomeException) -> handleIServFailure iserv e
handleIServFailure :: IServ -> SomeException -> IO a
handleIServFailure IServ{..} e = do
ex <- getProcessExitCode iservProcess
handleIServFailure :: IServInstance -> SomeException -> IO a
handleIServFailure iserv e = do
let proc = iservProcess iserv
ex <- getProcessExitCode proc
case ex of
Just (ExitFailure n) ->
throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
_ -> do
terminateProcess iservProcess
_ <- waitForProcess iservProcess
terminateProcess proc
_ <- waitForProcess proc
throw e
-- -----------------------------------------------------------------------------
-- Starting and stopping the iserv process
startIServ :: DynFlags -> IO IServ
startIServ dflags = do
let flavour
| WayProf `elem` ways dflags = "-prof"
| WayDyn `elem` ways dflags = "-dyn"
| otherwise = ""
prog = pgm_i dflags ++ flavour
opts = getOpts dflags opt_i
debugTraceMsg dflags 3 $ text "Starting " <> text prog
let createProc = lookupHook createIservProcessHook
(\cp -> do { (_,_,_,ph) <- createProcess cp
; return ph })
dflags
(ph, rh, wh) <- runWithPipes createProc prog opts
-- | Spawn an external interpreter
spawnIServ :: IServConfig -> IO IServInstance
spawnIServ conf = do
iservConfTrace conf
let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp
; return ph })
(iservConfHook conf)
(ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)
(iservConfOpts conf)
lo_ref <- newIORef Nothing
cache_ref <- newIORef emptyUFM
return $ IServ
{ iservPipe = Pipe { pipeRead = rh
, pipeWrite = wh
, pipeLeftovers = lo_ref }
, iservProcess = ph
, iservLookupSymbolCache = cache_ref
, iservPendingFrees = []
return $ IServInstance
{ iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
, iservProcess = ph
, iservLookupSymbolCache = emptyUFM
, iservPendingFrees = []
, iservConfig = conf
}
stopIServ :: HscEnv -> IO ()
stopIServ HscEnv{..} =
gmask $ \_restore -> do
m <- takeMVar hsc_iserv
maybe (return ()) stop m
putMVar hsc_iserv Nothing
where
stop iserv = do
ex <- getProcessExitCode (iservProcess iserv)
if isJust ex
then return ()
else iservCall iserv Shutdown
-- | Stop the interpreter
stopInterp :: HscEnv -> IO ()
stopInterp hsc_env = case hsc_interp hsc_env of
Nothing -> pure ()
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp (IServ mstate)) ->
gmask $ \_restore -> modifyMVar_ mstate $ \state -> do
case state of
IServPending {} -> pure state -- already stopped
IServRunning i -> do
ex <- getProcessExitCode (iservProcess i)
if isJust ex
then pure ()
else iservCall i Shutdown
pure (IServPending (iservConfig i))
runWithPipes :: (CreateProcess -> IO ProcessHandle)
-> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
......@@ -609,20 +623,23 @@ principle it would probably be ok, but it seems less hairy this way.
-- | Creates a 'ForeignRef' that will automatically release the