Commit bc41e471 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor interpreterDynamic and interpreterProfiled

* `interpreterDynamic` and `interpreterProfiled` now take `Interp`
  parameters instead of DynFlags

* slight refactoring of `ExternalInterp` so that we can read the iserv
  configuration (which is pure) without reading an MVar.
parent 8e6febce
......@@ -614,13 +614,15 @@ setSessionDynFlags dflags = do
else return (pure ())
let
conf = IServConfig
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfProfiled = gopt Opt_SccProfilingOn dflags
, iservConfDynamic = WayDyn `elem` ways dflags
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
}
s <- liftIO $ newMVar (IServPending conf)
return (Just (ExternalInterp (IServ s)))
s <- liftIO $ newMVar IServPending
return (Just (ExternalInterp conf (IServ s)))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
return (Just InternalInterp)
......
......@@ -19,12 +19,10 @@ 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
import GHC.Driver.Session
import GHC.Driver.Ways
import Outputable
import GHC.Platform
import Name
......@@ -418,8 +416,10 @@ schemeER_wrk d p rhs
, cgb_resty = exprType (deAnnotate' newRhs)
}
newBreakInfo tick_no breakInfo
dflags <- getDynFlags
let cc | interpreterProfiled dflags = cc_arr ! tick_no
hsc_env <- getHscEnv
let cc | Just interp <- hsc_interp hsc_env
, interpreterProfiled interp
= cc_arr ! tick_no
| otherwise = toRemotePtr nullPtr
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
......@@ -996,8 +996,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
hsc_env <- getHscEnv
let
profiling
| Just (ExternalInterp _) <- hsc_interp hsc_env = gopt Opt_SccProfilingOn dflags
| otherwise = hostIsProfiled
| Just interp <- hsc_interp hsc_env
= interpreterProfiled interp
| otherwise = False
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
......
......@@ -162,7 +162,6 @@ module GHC.Driver.Session (
addPluginModuleName,
defaultDynFlags, -- Settings -> DynFlags
defaultWays,
interpreterProfiled, interpreterDynamic,
initDynFlags, -- DynFlags -> IO DynFlags
defaultFatalMessager,
defaultLogAction,
......@@ -1501,16 +1500,6 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
then [WayDyn]
else []
interpreterProfiled :: DynFlags -> Bool
interpreterProfiled dflags
| gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
| otherwise = hostIsProfiled
interpreterDynamic :: DynFlags -> Bool
interpreterDynamic dflags
| gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
| otherwise = hostIsDynamic
--------------------------------------------------------------------------
--
-- Note [JSON Error Messages]
......
......@@ -157,13 +157,13 @@ mkCCSArray
:: HscEnv -> Module -> Int -> [MixEntry_]
-> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
mkCCSArray hsc_env modul count entries = do
if interpreterProfiled dflags
then do
case hsc_interp hsc_env of
Just interp | GHCi.interpreterProfiled interp -> do
let module_str = moduleNameString (moduleName modul)
costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
return (listArray (0,count-1) costcentres)
else do
return (listArray (0,-1) [])
_ -> return (listArray (0,-1) [])
where
dflags = hsc_dflags hsc_env
mk_one (srcspan, decl_path, _, _) = (name, src)
......
......@@ -273,7 +273,7 @@ withVirtualCWD m = do
-- a virtual CWD is only necessary when we're running interpreted code in
-- the same process as the compiler.
case hsc_interp hsc_env of
Just (ExternalInterp _) -> m
Just (ExternalInterp {}) -> m
_ -> do
let ic = hsc_IC hsc_env
let set_cwd = do
......@@ -1247,11 +1247,11 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
#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)
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
ExternalInterp {} -> throwIO (InstallationError
"this operation requires -fno-external-interpreter")
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
......
......@@ -25,6 +25,8 @@ module GHC.Runtime.Interpreter
, getClosure
, getModBreaks
, seqHValue
, interpreterDynamic
, interpreterProfiled
-- * The object-code linker
, initObjLinker
......@@ -41,7 +43,7 @@ module GHC.Runtime.Interpreter
-- * Lower-level API using messages
, iservCmd, Message(..), withIServ, withIServ_
, withInterp, stopInterp
, withInterp, hscInterp, stopInterp
, iservCall, readIServ, writeIServ
, purgeLookupSymbolCache
, freeHValueRefs
......@@ -55,9 +57,6 @@ import GhcPrelude
import GHC.Runtime.Interpreter.Types
import GHCi.Message
#if defined(HAVE_INTERNAL_INTERPRETER)
import GHCi.Run
#endif
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
......@@ -78,6 +77,11 @@ import Module
import GHC.ByteCode.Types
import Unique
#if defined(HAVE_INTERNAL_INTERPRETER)
import GHCi.Run
import GHC.Driver.Ways
#endif
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
......@@ -176,7 +180,7 @@ iservCmd hsc_env msg = withInterp hsc_env $ \case
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> run msg -- Just run it directly
#endif
(ExternalInterp i) -> withIServ_ i $ \iserv ->
(ExternalInterp c i) -> withIServ_ c i $ \iserv ->
uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
iservCall iserv msg
......@@ -185,9 +189,15 @@ iservCmd hsc_env msg = withInterp hsc_env $ \case
--
-- 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
withInterp hsc_env action = action (hscInterp hsc_env)
-- | Retreive the targe code interpreter
--
-- Fails if no target code interpreter is available
hscInterp :: HscEnv -> Interp
hscInterp hsc_env = case hsc_interp hsc_env of
Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")
Just i -> i
-- Note [uninterruptibleMask_ and iservCmd]
--
......@@ -202,14 +212,14 @@ withInterp hsc_env action = case hsc_interp hsc_env of
-- Overloaded because this is used from TcM as well as IO.
withIServ
:: (MonadIO m, ExceptionMonad m)
=> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ (IServ mIServState) action = do
=> IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ conf (IServ mIServState) action = do
gmask $ \restore -> do
state <- liftIO $ takeMVar mIServState
iserv <- case state of
-- start the external iserv process if we haven't done so yet
IServPending conf ->
IServPending ->
liftIO (spawnIServ conf)
`gonException` (liftIO $ putMVar mIServState state)
......@@ -230,8 +240,8 @@ withIServ (IServ mIServState) action = do
withIServ_
:: (MonadIO m, ExceptionMonad m)
=> IServ -> (IServInstance -> m a) -> m a
withIServ_ iserv action = withIServ iserv $ \inst ->
=> IServConfig -> IServ -> (IServInstance -> m a) -> m a
withIServ_ conf iserv action = withIServ conf iserv $ \inst ->
(inst,) <$> action inst
-- -----------------------------------------------------------------------------
......@@ -432,7 +442,7 @@ lookupSymbol hsc_env str = withInterp hsc_env $ \case
InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#endif
ExternalInterp i -> withIServ i $ \iserv -> do
ExternalInterp c i -> withIServ c 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
......@@ -461,9 +471,9 @@ purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp (IServ mstate)) ->
Just (ExternalInterp _ (IServ mstate)) ->
modifyMVar_ mstate $ \state -> pure $ case state of
IServPending {} -> state
IServPending -> state
IServRunning iserv -> IServRunning
(iserv { iservLookupSymbolCache = emptyUFM })
......@@ -564,7 +574,6 @@ spawnIServ conf = do
, iservProcess = ph
, iservLookupSymbolCache = emptyUFM
, iservPendingFrees = []
, iservConfig = conf
}
-- | Stop the interpreter
......@@ -574,16 +583,16 @@ stopInterp hsc_env = case hsc_interp hsc_env of
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp (IServ mstate)) ->
Just (ExternalInterp _ (IServ mstate)) ->
gmask $ \_restore -> modifyMVar_ mstate $ \state -> do
case state of
IServPending {} -> pure state -- already stopped
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))
pure IServPending
runWithPipes :: (CreateProcess -> IO ProcessHandle)
-> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
......@@ -669,11 +678,11 @@ mkFinalizedHValue hsc_env rref = do
let hvref = toHValueRef rref
free <- case hsc_interp hsc_env of
Nothing -> return (pure ())
Nothing -> return (pure ())
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> return (freeRemoteRef hvref)
Just InternalInterp -> return (freeRemoteRef hvref)
#endif
Just (ExternalInterp (IServ i)) -> return $ modifyMVar_ i $ \state ->
Just (ExternalInterp _ (IServ i)) -> return $ modifyMVar_ i $ \state ->
case state of
IServPending {} -> pure state -- already shut down
IServRunning inst -> do
......@@ -698,9 +707,9 @@ wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)
-- the compiler, so it fails when @-fexternal-interpreter@ is on.
wormholeRef :: Interp -> RemoteRef a -> IO a
#if defined(HAVE_INTERNAL_INTERPRETER)
wormholeRef InternalInterp _r = localRef _r
wormholeRef InternalInterp _r = localRef _r
#endif
wormholeRef (ExternalInterp _) _r
wormholeRef (ExternalInterp {}) _r
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
......@@ -726,3 +735,17 @@ getModBreaks hmi
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
-- | Interpreter uses Profiling way
interpreterProfiled :: Interp -> Bool
#if defined(HAVE_INTERNAL_INTERPRETER)
interpreterProfiled InternalInterp = hostIsProfiled
#endif
interpreterProfiled (ExternalInterp c _) = iservConfProfiled c
-- | Interpreter uses Dynamic way
interpreterDynamic :: Interp -> Bool
#if defined(HAVE_INTERNAL_INTERPRETER)
interpreterDynamic InternalInterp = hostIsDynamic
#endif
interpreterDynamic (ExternalInterp c _) = iservConfDynamic c
......@@ -22,9 +22,9 @@ import System.Process ( ProcessHandle, CreateProcess )
-- | Runtime interpreter
data Interp
= ExternalInterp !IServ -- ^ External interpreter
= ExternalInterp !IServConfig !IServ -- ^ External interpreter
#if defined(HAVE_INTERNAL_INTERPRETER)
| InternalInterp -- ^ Internal interpreter
| InternalInterp -- ^ Internal interpreter
#endif
-- | External interpreter
......@@ -36,15 +36,17 @@ newtype IServ = IServ (MVar IServState)
-- | State of an external interpreter
data IServState
= IServPending !IServConfig -- ^ Not spawned yet
= IServPending -- ^ Not spawned yet
| IServRunning !IServInstance -- ^ Running
-- | Configuration needed to spawn an external interpreter
data IServConfig = IServConfig
{ iservConfProgram :: !String -- ^ External program to run
, iservConfOpts :: ![String] -- ^ Command-line options
, iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook
, iservConfTrace :: IO () -- ^ Trace action executed after spawn
{ iservConfProgram :: !String -- ^ External program to run
, iservConfOpts :: ![String] -- ^ Command-line options
, iservConfProfiled :: !Bool -- ^ Use Profiling way
, iservConfDynamic :: !Bool -- ^ Use Dynamic way
, iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook
, iservConfTrace :: IO () -- ^ Trace action executed after spawn
}
-- | External interpreter instance
......@@ -56,8 +58,5 @@ data IServInstance = IServInstance
-- ^ Values that need to be freed before the next command is sent.
-- Threads can append values to this list asynchronously (by modifying the
-- IServ state MVar).
, iservConfig :: !IServConfig
-- ^ Config used to spawn the external interpreter
}
......@@ -578,7 +578,7 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk
checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay hsc_env srcspan
| Just (ExternalInterp _) <- hsc_interp hsc_env = return Nothing
| Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing
-- with -fexternal-interpreter we load the .o files, whatever way
-- they were built. If they were built for a non-std way, then
-- we will use the appropriate variant of the iserv binary to load them.
......@@ -885,7 +885,7 @@ dynLinkObjs hsc_env pls objs = do
unlinkeds = concatMap linkableUnlinked new_objs
wanted_objs = map nameOfObject unlinkeds
if interpreterDynamic (hsc_dflags hsc_env)
if interpreterDynamic (hscInterp hsc_env)
then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
return (pls2, Succeeded)
else do mapM_ (loadObj hsc_env) wanted_objs
......@@ -1270,7 +1270,7 @@ linkPackage hsc_env pkg
= do
let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
is_dyn = interpreterDynamic dflags
is_dyn = interpreterDynamic (hscInterp hsc_env)
dirs | is_dyn = Packages.libraryDynDirs pkg
| otherwise = Packages.libraryDirs pkg
......@@ -1486,6 +1486,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
where
dflags = hsc_dflags hsc_env
interp = hscInterp hsc_env
dirs = lib_dirs ++ gcc_dirs
gcc = False
user = True
......@@ -1500,8 +1501,8 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
]
lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
loading_profiled_hs_libs = interpreterProfiled dflags
loading_dynamic_hs_libs = interpreterDynamic dflags
loading_profiled_hs_libs = interpreterProfiled interp
loading_dynamic_hs_libs = interpreterDynamic interp
import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib"
, "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
......@@ -1547,7 +1548,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
assumeDll
| is_hs
, not loading_dynamic_hs_libs
, interpreterProfiled dflags
, interpreterProfiled interp
= do
warningMsg dflags
(text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
......
......@@ -105,7 +105,7 @@ loadFrontendPlugin hsc_env mod_name = do
-- #14335
checkExternalInterpreter :: HscEnv -> IO ()
checkExternalInterpreter hsc_env
| Just (ExternalInterp _) <- hsc_interp hsc_env
| Just (ExternalInterp {}) <- hsc_interp hsc_env
= throwIO (InstallationError "Plugins require -fno-external-interpreter")
| otherwise
= pure ()
......
......@@ -776,9 +776,9 @@ convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
convertAnnotationWrapper fhv = do
interp <- tcGetInterp
case interp of
ExternalInterp _ -> Right <$> runTH THAnnWrapper fhv
ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
InternalInterp -> do
annotation_wrapper <- liftIO $ wormhole InternalInterp fhv
return $ Right $
case unsafeCoerce annotation_wrapper of
......@@ -821,7 +821,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
runQuasi $ sequence_ qs
#endif
ExternalInterp iserv -> withIServ_ iserv $ \i -> do
ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do
tcg <- getGblEnv
th_state <- readTcRef (tcg_th_remote_state tcg)
case th_state of
......@@ -1215,11 +1215,11 @@ finishTH :: TcM ()
finishTH = do
hsc_env <- getTopEnv
case hsc_interp hsc_env of
Nothing -> pure ()
Nothing -> pure ()
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp _) -> do
Just (ExternalInterp {}) -> do
tcg <- getGblEnv
writeTcRef (tcg_th_remote_state tcg) Nothing
......@@ -1248,11 +1248,11 @@ runTH ty fhv = do
return r
#endif
ExternalInterp iserv ->
ExternalInterp conf iserv ->
-- Run it on the server. For an overview of how TH works with
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
withIServ_ iserv $ \i -> do
withIServ_ conf iserv $ \i -> do
rstate <- getTHState i
loc <- TH.qLocation
liftIO $
......
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