diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 13d8ba5ec7db862d0c7ae6f8e7131aec7e105b64..cc8f93bba0574331c1bad0ea109787b1d6cd3e07 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -313,6 +313,7 @@ import GHC.Driver.Monad
import GHC.Driver.Ppr
import GHC.ByteCode.Types
+import GHC.Runtime.Loader
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
@@ -729,6 +730,8 @@ getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags = getSessionDynFlags
-- | Set the 'DynFlags' used to evaluate interactive expressions.
+-- Also initialise (load) plugins.
+--
-- Note: this cannot be used for changes to packages. Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'unitState' into the interactive @DynFlags@.
@@ -736,7 +739,22 @@ setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- checkNewInteractiveDynFlags dflags'
- modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
+ modifySessionM $ \hsc_env0 -> do
+ let ic0 = hsc_IC hsc_env0
+
+ -- Initialise (load) plugins in the interactive environment with the new
+ -- DynFlags
+ plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
+ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
+
+ -- Update both plugins cache and DynFlags in the interactive context.
+ return $ hsc_env0
+ { hsc_IC = ic0
+ { ic_plugins = hsc_plugins plugin_env
+ , ic_dflags = hsc_dflags plugin_env
+ }
+ }
+
-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 14fb11bcccd14991305528203735c05fbfbf0fcc..918d1308dde7ee6c08ec511134e008ff9e4f55f6 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -97,9 +97,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod
orph_mods print_unqual loc $
do { hsc_env' <- getHscEnv
- ; dflags' <- liftIO $ initializePlugins hsc_env'
- (hsc_dflags hsc_env')
- ; all_passes <- withPlugins dflags'
+ ; hsc_env'' <- liftIO $ initializePlugins hsc_env'
+ ; all_passes <- withPlugins hsc_env''
installCoreToDos
builtin_passes
; runCorePasses all_passes guts }
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index f155fc0187a90bc8ae752187f08521e774c6639a..6bf83c576e400d476de59cdbc0722f21ee874158 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -26,7 +26,7 @@ import GHC.Prelude
import GHC.Driver.Ppr
import GHC.Driver.Session
-import GHC.Unit.Finder.Types
+import {-# SOURCE #-} GHC.Driver.Plugins
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types (Interp)
@@ -39,6 +39,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo
import GHC.Unit.External
+import GHC.Unit.Finder.Types
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -94,14 +95,17 @@ runHsc hsc_env (Hsc hsc) = do
printOrThrowWarnings (hsc_dflags hsc_env) w
return a
+-- | Switches in the DynFlags and Plugins from the InteractiveContext
mkInteractiveHscEnv :: HscEnv -> HscEnv
-mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags }
- where
- interactive_dflags = ic_dflags (hsc_IC hsc_env)
+mkInteractiveHscEnv hsc_env =
+ let ic = hsc_IC hsc_env
+ in hsc_env { hsc_dflags = ic_dflags ic
+ , hsc_plugins = ic_plugins ic
+ }
-runInteractiveHsc :: HscEnv -> Hsc a -> IO a
--- A variant of runHsc that switches in the DynFlags from the
+-- | A variant of runHsc that switches in the DynFlags and Plugins from the
-- InteractiveContext before running the Hsc computation.
+runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.
@@ -178,6 +182,21 @@ data HscEnv
, hsc_home_unit :: !HomeUnit
-- ^ Home-unit
+ , hsc_plugins :: ![LoadedPlugin]
+ -- ^ plugins dynamically loaded after processing arguments. What
+ -- will be loaded here is directed by DynFlags.pluginModNames.
+ -- Arguments are loaded from DynFlags.pluginModNameOpts.
+ --
+ -- The purpose of this field is to cache the plugins so they
+ -- don't have to be loaded each time they are needed. See
+ -- 'GHC.Runtime.Loader.initializePlugins'.
+
+ , hsc_static_plugins :: ![StaticPlugin]
+ -- ^ static plugins which do not need dynamic loading. These plugins are
+ -- intended to be added by GHC API users directly to this list.
+ --
+ -- To add dynamically loaded plugins through the GHC API see
+ -- 'addPluginModuleName' instead.
}
{-
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index e924826b0c34c307f8324ee3567caec98932c2a9..7672dcb3e7b79f1c4b40a0a78bbee257deb1407f 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -241,18 +241,20 @@ newHscEnv dflags = do
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
emptyLoader <- uninitializedLoader
- return HscEnv { hsc_dflags = dflags
- , hsc_targets = []
- , hsc_mod_graph = emptyMG
- , hsc_IC = emptyInteractiveContext dflags
- , hsc_HPT = emptyHomePackageTable
- , hsc_EPS = eps_var
- , hsc_NC = nc_var
- , hsc_FC = fc_var
- , hsc_type_env_var = Nothing
- , hsc_interp = Nothing
- , hsc_loader = emptyLoader
- , hsc_home_unit = home_unit
+ return HscEnv { hsc_dflags = dflags
+ , hsc_targets = []
+ , hsc_mod_graph = emptyMG
+ , hsc_IC = emptyInteractiveContext dflags
+ , hsc_HPT = emptyHomePackageTable
+ , hsc_EPS = eps_var
+ , hsc_NC = nc_var
+ , hsc_FC = fc_var
+ , hsc_type_env_var = Nothing
+ , hsc_interp = Nothing
+ , hsc_loader = emptyLoader
+ , hsc_home_unit = home_unit
+ , hsc_plugins = []
+ , hsc_static_plugins = []
}
-- -----------------------------------------------------------------------------
@@ -454,7 +456,8 @@ hscParse' mod_summary
-- apply parse transformation of plugins
let applyPluginAction p opts
= parsedResultAction p opts mod_summary
- withPlugins dflags applyPluginAction res
+ hsc_env <- getHscEnv
+ withPlugins hsc_env applyPluginAction res
-- -----------------------------------------------------------------------------
@@ -764,12 +767,11 @@ hscIncrementalCompile :: Bool
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
- -> IO (HscStatus, DynFlags)
+ -> IO (HscStatus, HscEnv)
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
- dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
- let hsc_env'' = hsc_env' { hsc_dflags = dflags }
+ hsc_env'' <- initializePlugins hsc_env'
-- One-shot mode needs a knot-tying mutable variable for interface
-- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
@@ -804,14 +806,14 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
-- any further typechecking. It's much more useful
-- in make mode, since this HMI will go into the HPT.
genModDetails hsc_env' iface
- return (HscUpToDate iface details, dflags)
+ return (HscUpToDate iface details, hsc_env')
-- We finished type checking. (mb_old_hash is the hash of
-- the interface that existed on disk; it's possible we had
-- to retypecheck but the resulting interface is exactly
-- the same.)
Right (FrontendTypecheck tc_result, mb_old_hash) -> do
status <- finish mod_summary tc_result mb_old_hash
- return (status, dflags)
+ return (status, hsc_env)
-- Runs the post-typechecking frontend (desugar and simplify). We want to
-- generate most of the interface as late as possible. This gets us up-to-date
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 4787574465d8cd33342078c15bc24fa3a00abd63..d30f26999a4cd5e6c8649059cb914c2e3e51a4d5 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -16,7 +16,8 @@ module GHC.Driver.Monad (
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
- Session(..), withSession, modifySession, withTempSession,
+ Session(..), withSession, modifySession, modifySessionM,
+ withTempSession,
-- ** Warnings
logWarnings, printException,
@@ -73,6 +74,13 @@ modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession f = do h <- getSession
setSession $! f h
+-- | Set the current session to the result of applying the current session to
+-- the argument.
+modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()
+modifySessionM f = do h <- getSession
+ h' <- f h
+ setSession $! h'
+
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession m = do
saved_session <- getSession
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index c65c54ab12bded236f91efc2f56812b53cc40705..a2dc71d95763f10ab7d994c67a8ccfaaacbbc619 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -197,10 +197,12 @@ compileOne' m_tc_result mHscMessage
debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
-- Run the pipeline up to codeGen (so everything up to, but not including, STG)
- (status, plugin_dflags) <- hscIncrementalCompile
+ (status, plugin_hsc_env) <- hscIncrementalCompile
always_do_basic_recompilation_check
m_tc_result mHscMessage
hsc_env summary source_modified mb_old_iface (mod_index, nmods)
+ -- Use an HscEnv updated with the plugin info
+ let hsc_env' = plugin_hsc_env
let flags = hsc_dflags hsc_env0
in do unless (gopt Opt_KeepHiFiles flags) $
@@ -210,10 +212,6 @@ compileOne' m_tc_result mHscMessage
addFilesToClean flags TFL_GhcSession $
[ml_obj_file $ ms_location summary]
- -- Use an HscEnv with DynFlags updated with the plugin info (returned from
- -- hscIncrementalCompile)
- let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }
-
case (status, bcknd) of
(HscUpToDate iface hmi_details, _) ->
-- TODO recomp014 triggers this assert. What's going on?!
@@ -1259,12 +1257,15 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
-- run the compiler!
let msg hsc_env _ what _ = oneShotMsg hsc_env what
- (result, plugin_dflags) <-
+ (result, plugin_hsc_env) <-
liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
mod_summary source_unchanged Nothing (1,1)
- -- In the rest of the pipeline use the dflags with plugin info
- setDynFlags plugin_dflags
+ -- In the rest of the pipeline use the loaded plugins
+ setPlugins (hsc_plugins plugin_hsc_env)
+ (hsc_static_plugins plugin_hsc_env)
+ -- "driver" plugins may have modified the DynFlags so we update them
+ setDynFlags (hsc_dflags plugin_hsc_env)
return (HscOut src_flavour mod_name result,
panic "HscOut doesn't have an input filename")
diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs
index b2db6170ecf45fd429ad33934acce9c662391495..03ee6e14f65c6137258e962f92b397d901fa6f73 100644
--- a/compiler/GHC/Driver/Pipeline/Monad.hs
+++ b/compiler/GHC/Driver/Pipeline/Monad.hs
@@ -7,7 +7,7 @@ module GHC.Driver.Pipeline.Monad (
, PhasePlus(..)
, PipeEnv(..), PipeState(..), PipelineOutput(..)
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface
- , pipeStateDynFlags, pipeStateModIface
+ , pipeStateDynFlags, pipeStateModIface, setPlugins
) where
import GHC.Prelude
@@ -18,6 +18,7 @@ import GHC.Utils.Outputable
import GHC.Driver.Session
import GHC.Driver.Phases
import GHC.Driver.Env
+import GHC.Driver.Plugins
import GHC.SysTools.FileCleanup (TempFileLifetime)
@@ -69,9 +70,9 @@ data PipeEnv = PipeEnv {
-- PipeState: information that might change during a pipeline run
data PipeState = PipeState {
hsc_env :: HscEnv,
- -- ^ only the DynFlags change in the HscEnv. The DynFlags change
- -- at various points, for example when we read the OPTIONS_GHC
- -- pragmas in the Cpp phase.
+ -- ^ only the DynFlags and the Plugins change in the HscEnv. The
+ -- DynFlags change at various points, for example when we read the
+ -- OPTIONS_GHC pragmas in the Cpp phase.
maybe_loc :: Maybe ModLocation,
-- ^ the ModLocation. This is discovered during compilation,
-- in the Hsc phase where we read the module header.
@@ -117,6 +118,11 @@ setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags dflags = P $ \_env state ->
return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
+setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()
+setPlugins dyn static = P $ \_env state ->
+ let hsc_env' = (hsc_env state){ hsc_plugins = dyn, hsc_static_plugins = static }
+ in return (state{hsc_env = hsc_env'}, ())
+
setModLocation :: ModLocation -> CompPipeline ()
setModLocation loc = P $ \_env state ->
return (state{ maybe_loc = Just loc }, ())
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index 3436cc34a6eb3b3e77d0251c5b70aa2a7ad7e6e2..2d8bc0ad856a0e39188c4c8a997497d43b87596f 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -50,7 +50,6 @@ module GHC.Driver.Plugins (
import GHC.Prelude
import GHC.Driver.Env
-import GHC.Driver.Session
import GHC.Driver.Monad
import GHC.Driver.Phases
@@ -98,13 +97,14 @@ data Plugin = Plugin {
, holeFitPlugin :: HoleFitPlugin
-- ^ An optional plugin to handle hole fits, which may re-order
-- or change the list of valid hole fits and refinement hole fits.
- , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
- -- ^ An optional plugin to update 'DynFlags', right after
- -- plugin loading. This can be used to register hooks
- -- or tweak any field of 'DynFlags' before doing
- -- actual work on a module.
+
+ , driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
+ -- ^ An optional plugin to update 'HscEnv', right after plugin loading. This
+ -- can be used to register hooks or tweak any field of 'DynFlags' before
+ -- doing actual work on a module.
--
-- @since 8.10.1
+
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
@@ -214,7 +214,7 @@ defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
, holeFitPlugin = const Nothing
- , dynflagsPlugin = const return
+ , driverPlugin = const return
, pluginRecompile = impurePlugin
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
@@ -242,25 +242,25 @@ keepRenamedSource _ gbl_env group =
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
-plugins :: DynFlags -> [PluginWithArgs]
-plugins df =
- map lpPlugin (cachedPlugins df) ++
- map spPlugin (staticPlugins df)
+plugins :: HscEnv -> [PluginWithArgs]
+plugins hsc_env =
+ map lpPlugin (hsc_plugins hsc_env) ++
+ map spPlugin (hsc_static_plugins hsc_env)
-- | Perform an operation by using all of the plugins in turn.
-withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
-withPlugins df transformation input = foldM go input (plugins df)
+withPlugins :: Monad m => HscEnv -> PluginOperation m a -> a -> m a
+withPlugins hsc_env transformation input = foldM go input (plugins hsc_env)
where
go arg (PluginWithArgs p opts) = transformation p opts arg
-mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a]
-mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df)
+mapPlugins :: HscEnv -> (Plugin -> [CommandLineOption] -> a) -> [a]
+mapPlugins hsc_env f = map (\(PluginWithArgs p opts) -> f p opts) (plugins hsc_env)
-- | Perform a constant operation by using all of the plugins in turn.
-withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
-withPlugins_ df transformation input
+withPlugins_ :: Monad m => HscEnv -> ConstPluginOperation m a -> a -> m ()
+withPlugins_ hsc_env transformation input
= mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)
- (plugins df)
+ (plugins hsc_env)
type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
data FrontendPlugin = FrontendPlugin {
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2f26276eb7923f0da90cd9b5e4441dfe63996ea7..082cdf95a8a53a8c6fe384e374c8a8b39e1e5bda 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -235,9 +235,8 @@ import GHC.Unit.Home
import GHC.Unit.Types
import GHC.Unit.Parser
import GHC.Unit.Module
-import {-# SOURCE #-} GHC.Driver.Plugins
-import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Builtin.Names ( mAIN_NAME )
+import {-# SOURCE #-} GHC.Driver.Hooks
import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase)
import GHC.Driver.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Flags
@@ -561,18 +560,6 @@ data DynFlags = DynFlags {
frontendPluginOpts :: [String],
-- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
-- order that they're specified on the command line.
- cachedPlugins :: [LoadedPlugin],
- -- ^ plugins dynamically loaded after processing arguments. What will be
- -- loaded here is directed by pluginModNames. Arguments are loaded from
- -- pluginModNameOpts. The purpose of this field is to cache the plugins so
- -- they don't have to be loaded each time they are needed. See
- -- 'GHC.Runtime.Loader.initializePlugins'.
- staticPlugins :: [StaticPlugin],
- -- ^ static plugins which do not need dynamic loading. These plugins are
- -- intended to be added by GHC API users directly to this list.
- --
- -- To add dynamically loaded plugins through the GHC API see
- -- 'addPluginModuleName' instead.
-- GHC API hooks
hooks :: Hooks,
@@ -1220,8 +1207,6 @@ defaultDynFlags mySettings llvmConfig =
pluginModNames = [],
pluginModNameOpts = [],
frontendPluginOpts = [],
- cachedPlugins = [],
- staticPlugins = [],
hooks = emptyHooks,
outputFile_ = Nothing,
@@ -1878,7 +1863,7 @@ clearPluginModuleNames :: DynFlags -> DynFlags
clearPluginModuleNames d =
d { pluginModNames = []
, pluginModNameOpts = []
- , cachedPlugins = [] }
+ }
addPluginModuleNameOption :: String -> DynFlags -> DynFlags
addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 14de36906d9110c8ee4228e535a78ce069c0485a..9cf33aa02ac7f4d0722a761fd81f312069102af4 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -198,7 +198,7 @@ deSugar hsc_env
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
- pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))
+ pluginModules = map lpModule (hsc_plugins hsc_env)
home_unit = hsc_home_unit hsc_env
; deps <- mkDependencies (homeUnitId home_unit)
(map mi_module pluginModules) tcg_env
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 308119327cbd18bbea7af7526595a918dc1aff39..4fb775db53ad87304603f0cbfe5647f8e44aa934 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -433,7 +433,6 @@ loadInterface doc_str mod from
; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
-- Check whether we have the interface already
- ; dflags <- getDynFlags
; hsc_env <- getTopEnv
; let home_unit = hsc_home_unit hsc_env
; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
@@ -551,7 +550,7 @@ loadInterface doc_str mod from
; -- invoke plugins with *full* interface, not final_iface, to ensure
-- that plugins have access to declarations, etc.
- res <- withPlugins dflags (\p -> interfaceLoadAction p) iface
+ res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface
; return (Succeeded res)
}}}}
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index f9ad42a3c9392e9851229d0baf8064c1995b9bd0..f333525e4b06af8656ca884656615bcce626e0ab 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -193,7 +193,7 @@ mkIfaceTc hsc_env safe_mode mod_details
}
= do
let used_names = mkUsedNames tc_result
- let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))
+ let pluginModules = map lpModule (hsc_plugins hsc_env)
let home_unit = hsc_home_unit hsc_env
deps <- mkDependencies (homeUnitId home_unit)
(map mi_module pluginModules) tc_result
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index a123d24fba8a49f7b29b22c9425499e9a14adcdf..fe0f4439f5d8f55988491fc917ff2df3dbd61945 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -276,16 +276,16 @@ checkVersions hsc_env mod_summary iface
-- | Check if any plugins are requesting recompilation
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
-checkPlugins hsc iface = liftIO $ do
- new_fingerprint <- fingerprintPlugins hsc
+checkPlugins hsc_env iface = liftIO $ do
+ new_fingerprint <- fingerprintPlugins hsc_env
let old_fingerprint = mi_plugin_hash (mi_final_exts iface)
- pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
+ pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)
return $
pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins hsc_env =
- fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
+ fingerprintPlugins' $ plugins hsc_env
fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' plugins = do
diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs
index 7220dea503c0b07111ade6da0017d4e94901b554..932e499e4745eb5889fc1b97514917ee7efda4a6 100644
--- a/compiler/GHC/Runtime/Context.hs
+++ b/compiler/GHC/Runtime/Context.hs
@@ -18,6 +18,7 @@ import GHC.Prelude
import GHC.Hs
import GHC.Driver.Session
+import {-# SOURCE #-} GHC.Driver.Plugins
import GHC.Runtime.Eval.Types ( Resume )
@@ -240,8 +241,12 @@ data InteractiveContext
-- ^ The function that is used for printing results
-- of expressions in ghci and -e mode.
- ic_cwd :: Maybe FilePath
- -- virtual CWD of the program
+ ic_cwd :: Maybe FilePath,
+ -- ^ virtual CWD of the program
+
+ ic_plugins :: ![LoadedPlugin]
+ -- ^ Cache of loaded plugins. We store them here to avoid having to
+ -- load them everytime we switch to the interctive context.
}
data InteractiveImport
@@ -270,7 +275,9 @@ emptyInteractiveContext dflags
ic_int_print = printName, -- System.IO.print by default
ic_default = Nothing,
ic_resume = [],
- ic_cwd = Nothing }
+ ic_cwd = Nothing,
+ ic_plugins = []
+ }
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule (InteractiveContext { ic_mod_index = index })
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index b66f959889595d8ebcfe895e550e5da570797046..692a4c718c9bbbf4e36a1648c9bb88ef63b76125 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -218,11 +218,9 @@ execStmt' stmt stmt_text ExecOptions{..} = do
-- Turn off -fwarn-unused-local-binds when running a statement, to hide
-- warnings about the implicit bindings we introduce.
- -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
- -- -wwarn-unused-local-binds)
let ic = hsc_IC hsc_env -- use the interactive dflags
idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
- hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })
+ hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})
r <- liftIO $ hscParsedStmt hsc_env' stmt
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 93b39675256128ca5fede14c0969d7eea68ed9ce..592df3ccc867c493ba481aa30a0a6f6fa0c49eb4 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -69,21 +69,22 @@ import Unsafe.Coerce ( unsafeCoerce )
-- flags. Should be called after command line arguments are parsed, but before
-- actual compilation starts. Idempotent operation. Should be re-called if
-- pluginModNames or pluginModNameOpts changes.
-initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
-initializePlugins hsc_env df
- | map lpModuleName (cachedPlugins df)
- == pluginModNames df -- plugins not changed
- && all (\p -> paArguments (lpPlugin p)
- == argumentsForPlugin p (pluginModNameOpts df))
- (cachedPlugins df) -- arguments not changed
- = return df -- no need to reload plugins
+initializePlugins :: HscEnv -> IO HscEnv
+initializePlugins hsc_env
+ -- plugins not changed
+ | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags
+ -- arguments not changed
+ , all same_args (hsc_plugins hsc_env)
+ = return hsc_env -- no need to reload plugins
| otherwise
- = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
- let df' = df { cachedPlugins = loadedPlugins }
- withPlugins df' runDflagsPlugin df'
-
- where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
- runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags
+ = do loaded_plugins <- loadPlugins hsc_env
+ let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }
+ withPlugins hsc_env' driverPlugin hsc_env'
+ where
+ plugin_args = pluginModNameOpts dflags
+ same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args
+ argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
+ dflags = hsc_dflags hsc_env
loadPlugins :: HscEnv -> IO [LoadedPlugin]
loadPlugins hsc_env
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index ed248c09ccca446e98ac35e80f4d82beceeb55ef..468410400f295fb8943edeedd3237f92c0801e0e 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -932,7 +932,7 @@ runMeta' show_code ppr_hs run_and_convert expr
-- run plugins
; hsc_env <- getTopEnv
- ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
+ ; expr' <- withPlugins hsc_env spliceRunAction expr
-- Desugar
; ds_expr <- initDsTc (dsLExpr expr')
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 754059571b175bfce3937aa51b9d0edf63ad7830..44a92da7ae752bef2fc891822c0ad3a227f5e9ec 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -326,7 +326,7 @@ tcRnModuleTcRnM hsc_env mod_sum
reportUnusedNames tcg_env hsc_src
; -- add extra source files to tcg_dependent_files
addDependentFiles src_files
- ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
+ ; tcg_env <- runTypecheckerPlugin mod_sum tcg_env
; -- Dump output and return
tcDump tcg_env
; return tcg_env }
@@ -3034,10 +3034,10 @@ Type Checker Plugins
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m =
- do let plugins = getTcPlugins (hsc_dflags hsc_env)
- case plugins of
- [] -> m -- Common fast case
- _ -> do ev_binds_var <- newTcEvBinds
+ case getTcPlugins hsc_env of
+ [] -> m -- Common fast case
+ plugins -> do
+ ev_binds_var <- newTcEvBinds
(solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins
-- This ensures that tcPluginStop is called even if a type
-- error occurs during compilation (Fix of #10078)
@@ -3052,13 +3052,13 @@ withTcPlugins hsc_env m =
do s <- runTcPluginM start ev_binds_var
return (solve s, stop s)
-getTcPlugins :: DynFlags -> [GHC.Tc.Utils.Monad.TcPlugin]
-getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
+getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin]
+getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args)
withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins hsc_env m =
- case (getHfPlugins (hsc_dflags hsc_env)) of
+ case getHfPlugins hsc_env of
[] -> m -- Common fast case
plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins
-- This ensures that hfPluginStop is called even if a type
@@ -3074,18 +3074,19 @@ withHoleFitPlugins hsc_env m =
do ref <- init
return (plugin ref, stop ref)
-getHfPlugins :: DynFlags -> [HoleFitPluginR]
-getHfPlugins dflags =
- catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args)
+getHfPlugins :: HscEnv -> [HoleFitPluginR]
+getHfPlugins hsc_env =
+ catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args)
runRenamerPlugin :: TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin gbl_env hs_group = do
- dflags <- getDynFlags
- withPlugins dflags
- (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
+ hsc_env <- getTopEnv
+ withPlugins hsc_env
+ (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)
+ >> renamedResultAction p opts e g))
(gbl_env, hs_group)
@@ -3103,11 +3104,11 @@ getRenamedStuff tc_result
, tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
(tcg_rn_decls tc_result)
-runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
-runTypecheckerPlugin sum hsc_env gbl_env = do
- let dflags = hsc_dflags hsc_env
- withPlugins dflags
- (\p opts env -> mark_plugin_unsafe dflags
+runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
+runTypecheckerPlugin sum gbl_env = do
+ hsc_env <- getTopEnv
+ withPlugins hsc_env
+ (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)
>> typeCheckResultAction p opts sum env)
gbl_env
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index 483334d17c1812d93cbf1f689754b1a73ad3fa42..dbd527cb2b6de795bd208ee04aa6dac71caa3853 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -1341,13 +1341,17 @@ this idea can be seen below:
import GHC.Tc.Utils.Monad
plugin :: Plugin
- plugin = defaultPlugin { dynflagsPlugin = hooksP }
-
- hooksP :: [CommandLineOption] -> DynFlags -> IO DynFlags
- hooksP opts dflags = return $ dflags
- { hooks = (hooks dflags)
- { runMetaHook = Just (fakeRunMeta opts) }
- }
+ plugin = driverPlugin { driverPlugin = hooksP }
+
+ hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv
+ hooksP opts hsc_env = do
+ let dflags = hsc_dflags hsc_env
+ dflags' = dflags
+ { hooks = (hooks dflags)
+ { runMetaHook = Just (fakeRunMeta opts) }
+ }
+ hsc_env' = hsc_env { hsc_dflags = dflags' }
+ return hsc_env'
-- This meta hook doesn't actually care running code in splices,
-- it just replaces any expression splice with the "0"
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 025f82fa08b0c5a57d540a864e15d195b3418c37..d44eb79bd183c7b161b482cf6ec3ca1d795f6bcd 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -81,8 +81,6 @@ import GHC.Unit.Module.ModSummary
import GHC.Data.StringBuffer
import GHC.Utils.Outputable
-import GHC.Runtime.Loader ( initializePlugins )
-
-- Other random utilities
import GHC.Types.Basic hiding ( isTopLevel )
import GHC.Settings.Config
@@ -2943,10 +2941,7 @@ newDynFlags interactive_only minus_opts = do
when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
- -- Load any new plugins
- hsc_env0 <- GHC.getSession
- idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)
- GHC.setInteractiveDynFlags idflags2
+ GHC.setInteractiveDynFlags idflags1
installInteractivePrint (interactivePrint idflags1) False
dflags0 <- getDynFlags
diff --git a/ghc/Main.hs b/ghc/Main.hs
index b7992b10b8ab9e767134ddc78cac64aa57be9aea..db926fb85f75e1e0acc4707e60529fe03da0ee92 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -36,7 +36,6 @@ import GHC.Platform.Host
#if defined(HAVE_INTERNAL_INTERPRETER)
import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
-import GHC.Runtime.Loader ( initializePlugins )
#endif
import GHC.Runtime.Loader ( loadFrontendPlugin )
@@ -247,9 +246,8 @@ main' postLoadMode dflags0 args flagWarnings = do
DoMake -> doMake srcs
DoMkDependHS -> doMkDependHS (map fst srcs)
StopBefore p -> liftIO (oneShot hsc_env p srcs)
- DoInteractive -> ghciUI hsc_env dflags6 srcs Nothing
- DoEval exprs -> ghciUI hsc_env dflags6 srcs $ Just $
- reverse exprs
+ DoInteractive -> ghciUI srcs Nothing
+ DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
DoAbiHash -> abiHash (map fst srcs)
ShowPackages -> liftIO $ showUnits dflags6
DoFrontend f -> doFrontend f srcs
@@ -257,16 +255,12 @@ main' postLoadMode dflags0 args flagWarnings = do
liftIO $ dumpFinalStats dflags6
-ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
- -> Ghc ()
+ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
#if !defined(HAVE_INTERNAL_INTERPRETER)
-ghciUI _ _ _ _ =
+ghciUI _ _ =
throwGhcException (CmdLineError "not built for interactive use")
#else
-ghciUI hsc_env dflags0 srcs maybe_expr = do
- dflags1 <- liftIO (initializePlugins hsc_env dflags0)
- _ <- GHC.setSessionDynFlags dflags1
- interactiveUI defaultGhciSettings srcs maybe_expr
+ghciUI srcs maybe_expr = interactiveUI defaultGhciSettings srcs maybe_expr
#endif
diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
index 616d202d299fb056b8728915e1d3607d6bbeb246..361f40eb2495b0c6c246443f68b5de3031a32531 100644
--- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
+++ b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
@@ -10,13 +10,17 @@ import GHC.Driver.Hooks
import GHC.Tc.Utils.Monad
plugin :: Plugin
-plugin = defaultPlugin { dynflagsPlugin = hooksP }
+plugin = defaultPlugin { driverPlugin = hooksP }
-hooksP :: [CommandLineOption] -> DynFlags -> IO DynFlags
-hooksP opts dflags = return $ dflags
- { hooks = (hooks dflags)
- { runMetaHook = Just (fakeRunMeta opts) }
- }
+hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv
+hooksP opts hsc_env = do
+ let dflags = hsc_dflags hsc_env
+ dflags' = dflags
+ { hooks = (hooks dflags)
+ { runMetaHook = Just (fakeRunMeta opts) }
+ }
+ hsc_env' = hsc_env { hsc_dflags = dflags' }
+ return hsc_env'
-- This meta hook doesn't actually care running code in splices,
-- it just replaces any expression splice with the "0"
diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs
index af57614ffeaa63f1f6b128238008ad02f5aa2cf1..be0a503f84836357c000153d310f1737bd3a3b50 100644
--- a/testsuite/tests/plugins/static-plugins.hs
+++ b/testsuite/tests/plugins/static-plugins.hs
@@ -1,9 +1,13 @@
module Main where
-import GHC.Types.Avail
-import Control.Monad.IO.Class
+import GHC.Driver.Env
import GHC.Driver.Session
(getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut)
+import GHC.Driver.Plugins
+import GHC.Driver.Monad
+
+import GHC.Types.Avail
+import Control.Monad.IO.Class
import GHC
import GHC.Fingerprint.Type
import GHC.Hs.Decls
@@ -12,7 +16,6 @@ import GHC.Hs.Expr
import GHC.Hs.Extension
import GHC.Hs.ImpExp
import GHC.Utils.Outputable
-import GHC.Driver.Plugins
import System.Environment
import GHC.Tc.Types
@@ -65,9 +68,10 @@ main = do
target <- guessTarget "static-plugins-module.hs" Nothing
setTargets [target]
+ modifySession (\hsc_env -> hsc_env { hsc_static_plugins = the_plugins})
+
dflags <- getSessionDynFlags
- setSessionDynFlags dflags { staticPlugins = the_plugins
- , outputFile_ = Nothing }
+ setSessionDynFlags dflags { outputFile_ = Nothing }
load LoadAllTargets
diff --git a/utils/haddock b/utils/haddock
index 4d0498d503bd51b7d7626497580232685a2691a1..25fa8fde84701c010fa466c2648f8f6d10265e8f 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 4d0498d503bd51b7d7626497580232685a2691a1
+Subproject commit 25fa8fde84701c010fa466c2648f8f6d10265e8f