From ecfd0278cb811c93853c176fe5df60222d1a8fb5 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 3 Nov 2020 12:04:53 +0100
Subject: [PATCH] Move Plugins into HscEnv (#17957)
Loaded plugins have nothing to do in DynFlags so this patch moves them
into HscEnv (session state).
"DynFlags plugins" become "Driver plugins" to still be able to register
static plugins.
Bump haddock submodule
---
compiler/GHC.hs | 20 +++++++++-
compiler/GHC/Core/Opt/Pipeline.hs | 5 +--
compiler/GHC/Driver/Env.hs | 31 ++++++++++++---
compiler/GHC/Driver/Main.hs | 38 +++++++++---------
compiler/GHC/Driver/Monad.hs | 10 ++++-
compiler/GHC/Driver/Pipeline.hs | 17 ++++----
compiler/GHC/Driver/Pipeline/Monad.hs | 14 +++++--
compiler/GHC/Driver/Plugins.hs | 36 ++++++++---------
compiler/GHC/Driver/Session.hs | 19 +--------
compiler/GHC/HsToCore.hs | 2 +-
compiler/GHC/Iface/Load.hs | 3 +-
compiler/GHC/Iface/Make.hs | 2 +-
compiler/GHC/Iface/Recomp.hs | 8 ++--
compiler/GHC/Runtime/Context.hs | 13 +++++--
compiler/GHC/Runtime/Eval.hs | 4 +-
compiler/GHC/Runtime/Loader.hs | 29 +++++++-------
compiler/GHC/Tc/Gen/Splice.hs | 2 +-
compiler/GHC/Tc/Module.hs | 39 ++++++++++---------
docs/users_guide/extending_ghc.rst | 18 +++++----
ghc/GHCi/UI.hs | 7 +---
ghc/Main.hs | 16 +++-----
.../plugins/hooks-plugin/Hooks/Plugin.hs | 16 +++++---
testsuite/tests/plugins/static-plugins.hs | 14 ++++---
utils/haddock | 2 +-
24 files changed, 205 insertions(+), 160 deletions(-)
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 13d8ba5ec7db..cc8f93bba057 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 14fb11bcccd1..918d1308dde7 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 f155fc0187a9..6bf83c576e40 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 e924826b0c34..7672dcb3e7b7 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 4787574465d8..d30f26999a4c 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 c65c54ab12bd..a2dc71d95763 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 b2db6170ecf4..03ee6e14f65c 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 3436cc34a6eb..2d8bc0ad856a 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 2f26276eb792..082cdf95a8a5 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 14de36906d91..9cf33aa02ac7 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 308119327cbd..4fb775db53ad 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 f9ad42a3c939..f333525e4b06 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 a123d24fba8a..fe0f4439f5d8 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 7220dea503c0..932e499e4745 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 b66f95988959..692a4c718c9b 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 93b396752561..592df3ccc867 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 ed248c09ccca..468410400f29 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 754059571b17..44a92da7ae75 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 483334d17c18..dbd527cb2b6d 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 025f82fa08b0..d44eb79bd183 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 b7992b10b8ab..db926fb85f75 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 616d202d299f..361f40eb2495 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 af57614ffeaa..be0a503f8483 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 4d0498d503bd..25fa8fde8470 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 4d0498d503bd51b7d7626497580232685a2691a1
+Subproject commit 25fa8fde84701c010fa466c2648f8f6d10265e8f
--
GitLab