[Git][ghc/ghc][master] 2 commits: Move Plugins into HscEnv (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Sat Nov 21 06:14:19 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ecfd0278 by Sylvain Henry at 2020-11-21T01:14:09-05:00
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
- - - - -
72f2257c by Sylvain Henry at 2020-11-21T01:14:09-05:00
Don't initialize plugins in the Core2Core pipeline
Some plugins can be added via TH (cf addCorePlugin). Initialize them in
the driver instead of in the Core2Core pipeline.
- - - - -
24 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Monad.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- docs/users_guide/extending_ghc.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
- testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
- testsuite/tests/plugins/static-plugins.hs
- utils/haddock
Changes:
=====================================
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 at .
@@ -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
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -60,7 +60,6 @@ import GHC.Unit.Module.Env
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.Deps
-import GHC.Runtime.Loader -- ( initializePlugins )
import GHC.Runtime.Context
import GHC.Types.SrcLoc
@@ -88,18 +87,14 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_loc = loc
, mg_deps = deps
, mg_rdr_env = rdr_env })
- = do { -- make sure all plugins are loaded
-
- ; let builtin_passes = getCoreToDo dflags
+ = do { let builtin_passes = getCoreToDo dflags
orph_mods = mkModuleSet (mod : dep_orphs deps)
uniq_mask = 's'
;
; (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'
+ ; all_passes <- withPlugins hsc_env'
installCoreToDos
builtin_passes
; runCorePasses all_passes guts }
=====================================
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.
}
{-
=====================================
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
@@ -1424,16 +1426,22 @@ hscGetSafeMode tcg_env = do
-- Simplifiers
--------------------------------------------------------------
+-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
+-- module names added via TH (cf 'addCorePlugin').
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env plugins modguts =
runHsc hsc_env $ hscSimplify' plugins modguts
+-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
+-- module names added via TH (cf 'addCorePlugin').
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins ds_result = do
hsc_env <- getHscEnv
- let hsc_env_with_plugins = hsc_env
- { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
- }
+ hsc_env_with_plugins <- if null plugins -- fast path
+ then return hsc_env
+ else liftIO $ initializePlugins $ hsc_env
+ { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
+ }
{-# SCC "Core2Core" #-}
liftIO $ core2core hsc_env_with_plugins ds_result
=====================================
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
=====================================
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")
=====================================
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 }, ())
=====================================
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 {
=====================================
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) }
=====================================
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
=====================================
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)
}}}}
=====================================
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
=====================================
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
=====================================
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 })
=====================================
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
=====================================
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
=====================================
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')
=====================================
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
=====================================
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"
=====================================
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
=====================================
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
=====================================
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"
=====================================
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
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 4d0498d503bd51b7d7626497580232685a2691a1
+Subproject commit 25fa8fde84701c010fa466c2648f8f6d10265e8f
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53ad67eacacde8fde452f1a323d5886183375182...72f2257c792e6178933f12ee3401939da11584b6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53ad67eacacde8fde452f1a323d5886183375182...72f2257c792e6178933f12ee3401939da11584b6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201121/e4dc8447/attachment-0001.html>
More information about the ghc-commits
mailing list