Commit 9728d6c2 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

Give plugins a better interface (#17957)

Plugins were directly fetched from HscEnv (hsc_static_plugins and
hsc_plugins). The tight coupling of plugins and of HscEnv is undesirable
and it's better to store them in a new Plugins datatype and to use it in
the plugins' API (e.g. withPlugins, mapPlugins...).

In the process, the interactive context (used by GHCi) got proper
support for different static plugins than those used for loaded modules.

Bump haddock submodule
parent 00b55bfc
Pipeline #45435 canceled with stages
in 31 seconds
......@@ -92,7 +92,7 @@ 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
; all_passes <- withPlugins hsc_env'
; all_passes <- withPlugins (hsc_plugins hsc_env')
installCoreToDos
builtin_passes
; runCorePasses all_passes guts }
......
......@@ -85,21 +85,8 @@ data HscEnv
-- ^ target code interpreter (if any) to use for TH and GHCi.
-- See Note [Target code interpreter]
, 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.
, hsc_plugins :: !Plugins
-- ^ Plugins
, hsc_unit_env :: UnitEnv
-- ^ Unit environment (unit state, home unit, etc.).
......
......@@ -265,8 +265,7 @@ newHscEnv dflags = do
, hsc_type_env_vars = emptyKnotVars
, hsc_interp = Nothing
, hsc_unit_env = unit_env
, hsc_plugins = []
, hsc_static_plugins = []
, hsc_plugins = emptyPlugins
, hsc_hooks = emptyHooks
, hsc_tmpfs = tmpfs
}
......@@ -479,7 +478,7 @@ hscParse' mod_summary
let applyPluginAction p opts
= parsedResultAction p opts mod_summary
hsc_env <- getHscEnv
withPlugins hsc_env applyPluginAction res
withPlugins (hsc_plugins hsc_env) applyPluginAction res
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
checkBidirectionFormatChars start_loc sb
......
......@@ -7,7 +7,9 @@
module GHC.Driver.Plugins (
-- * Plugins
Plugin(..)
Plugins (..)
, emptyPlugins
, Plugin(..)
, defaultPlugin
, CommandLineOption
-- ** Recompilation checking
......@@ -45,7 +47,7 @@ module GHC.Driver.Plugins (
, HoleFitPluginR
-- * Internal
, PluginWithArgs(..), plugins, pluginRecompile'
, PluginWithArgs(..), pluginsWithArgs, pluginRecompile'
, LoadedPlugin(..), lpModuleName
, StaticPlugin(..)
, mapPlugins, withPlugins, withPlugins_
......@@ -251,25 +253,47 @@ keepRenamedSource _ gbl_env group =
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
plugins :: HscEnv -> [PluginWithArgs]
plugins hsc_env =
map lpPlugin (hsc_plugins hsc_env) ++
map spPlugin (hsc_static_plugins hsc_env)
data Plugins = Plugins
{ 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.
, loadedPlugins :: ![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'.
}
emptyPlugins :: Plugins
emptyPlugins = Plugins [] []
pluginsWithArgs :: Plugins -> [PluginWithArgs]
pluginsWithArgs plugins =
map lpPlugin (loadedPlugins plugins) ++
map spPlugin (staticPlugins plugins)
-- | Perform an operation by using all of the plugins in turn.
withPlugins :: Monad m => HscEnv -> PluginOperation m a -> a -> m a
withPlugins hsc_env transformation input = foldM go input (plugins hsc_env)
withPlugins :: Monad m => Plugins -> PluginOperation m a -> a -> m a
withPlugins plugins transformation input = foldM go input (pluginsWithArgs plugins)
where
go arg (PluginWithArgs p opts) = transformation p opts arg
mapPlugins :: HscEnv -> (Plugin -> [CommandLineOption] -> a) -> [a]
mapPlugins hsc_env f = map (\(PluginWithArgs p opts) -> f p opts) (plugins hsc_env)
mapPlugins :: Plugins -> (Plugin -> [CommandLineOption] -> a) -> [a]
mapPlugins plugins f = map (\(PluginWithArgs p opts) -> f p opts) (pluginsWithArgs plugins)
-- | Perform a constant operation by using all of the plugins in turn.
withPlugins_ :: Monad m => HscEnv -> ConstPluginOperation m a -> a -> m ()
withPlugins_ hsc_env transformation input
withPlugins_ :: Monad m => Plugins -> ConstPluginOperation m a -> a -> m ()
withPlugins_ plugins transformation input
= mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)
(plugins hsc_env)
(pluginsWithArgs plugins)
type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
data FrontendPlugin = FrontendPlugin {
......
......@@ -5,6 +5,9 @@ module GHC.Driver.Plugins where
import GHC.Prelude ()
data Plugin
data Plugins
emptyPlugins :: Plugins
data LoadedPlugin
data StaticPlugin
......@@ -22,6 +22,7 @@ import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Driver.Env
import GHC.Driver.Backend
import GHC.Driver.Plugins
import GHC.Hs
......@@ -90,7 +91,6 @@ import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
import GHC.Driver.Plugins ( LoadedPlugin(..) )
{-
************************************************************************
......@@ -196,7 +196,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 (hsc_plugins hsc_env)
pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
home_unit = hsc_home_unit hsc_env
; let deps = mkDependencies home_unit
(tcg_mod tcg_env)
......
......@@ -575,7 +575,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 hsc_env (\p -> interfaceLoadAction p) iface
res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
; return (Succeeded res)
}}}}
......
......@@ -51,7 +51,7 @@ import GHC.Core.Unify( RoughMatchTc(..) )
import GHC.Driver.Env
import GHC.Driver.Backend
import GHC.Driver.Session
import GHC.Driver.Plugins (LoadedPlugin(..))
import GHC.Driver.Plugins
import GHC.Types.Id
import GHC.Types.Fixity.Env
......@@ -197,7 +197,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary
}
= do
let used_names = mkUsedNames tc_result
let pluginModules = map lpModule (hsc_plugins hsc_env)
let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
let home_unit = hsc_home_unit hsc_env
let deps = mkDependencies home_unit
(tcg_mod tc_result)
......
......@@ -19,7 +19,7 @@ import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )
import GHC.Driver.Plugins
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
......@@ -333,7 +333,7 @@ checkVersions hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkDependencies hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Just iface) else do {
; recomp <- checkPlugins hsc_env iface
; recomp <- checkPlugins (hsc_plugins hsc_env) iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
......@@ -362,28 +362,27 @@ checkVersions hsc_env mod_summary iface
-- | Check if any plugins are requesting recompilation
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins hsc_env iface = liftIO $ do
new_fingerprint <- fingerprintPlugins hsc_env
checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired
checkPlugins plugins iface = liftIO $ do
recomp <- recompPlugins plugins
let new_fingerprint = fingerprintPluginRecompile recomp
let old_fingerprint = mi_plugin_hash (mi_final_exts iface)
pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)
return $
pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins hsc_env =
fingerprintPlugins' $ plugins hsc_env
fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' plugins = do
res <- mconcat <$> mapM pluginRecompile' plugins
return $ case res of
NoForceRecompile -> fingerprintString "NoForceRecompile"
ForceRecompile -> fingerprintString "ForceRecompile"
-- is the chance of collision worth worrying about?
-- An alternative is to fingerprintFingerprints [fingerprintString
-- "maybeRecompile", fp]
(MaybeRecompile fp) -> fp
return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp
recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins)
fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins
fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile recomp = case recomp of
NoForceRecompile -> fingerprintString "NoForceRecompile"
ForceRecompile -> fingerprintString "ForceRecompile"
-- is the chance of collision worth worrying about?
-- An alternative is to fingerprintFingerprints [fingerprintString
-- "maybeRecompile", fp]
MaybeRecompile fp -> fp
pluginRecompileToRecompileRequired
......@@ -1164,7 +1163,7 @@ addFingerprints hsc_env iface0
hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
plugin_hash <- fingerprintPlugins hsc_env
plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
-- the ABI hash depends on:
-- - decls
......
......@@ -284,7 +284,7 @@ data InteractiveContext
ic_cwd :: Maybe FilePath,
-- ^ virtual CWD of the program
ic_plugins :: ![LoadedPlugin]
ic_plugins :: !Plugins
-- ^ Cache of loaded plugins. We store them here to avoid having to
-- load them everytime we switch to the interctive context.
}
......@@ -321,7 +321,7 @@ emptyInteractiveContext dflags
ic_default = Nothing,
ic_resume = [],
ic_cwd = Nothing,
ic_plugins = []
ic_plugins = emptyPlugins
}
icReaderEnv :: InteractiveContext -> GlobalRdrEnv
......
......@@ -74,14 +74,16 @@ import GHC.Unit.Types (ModuleNameWithIsBoot)
initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv
initializePlugins hsc_env mnwib
-- plugins not changed
| map lpModuleName (hsc_plugins hsc_env) == reverse (pluginModNames dflags)
| loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)
, map lpModuleName loaded_plugins == reverse (pluginModNames dflags)
-- arguments not changed
, all same_args (hsc_plugins hsc_env)
= return hsc_env -- no need to reload plugins
, all same_args loaded_plugins
= return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account
| otherwise
= do loaded_plugins <- loadPlugins hsc_env mnwib
let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }
withPlugins hsc_env' driverPlugin hsc_env'
let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins }
let hsc_env' = hsc_env { hsc_plugins = plugins' }
withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'
where
plugin_args = pluginModNameOpts dflags
same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args
......
......@@ -994,7 +994,7 @@ runMeta' show_code ppr_hs run_and_convert expr
-- run plugins
; hsc_env <- getTopEnv
; expr' <- withPlugins hsc_env spliceRunAction expr
; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr
-- Desugar
; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')
......
......@@ -3071,7 +3071,7 @@ Type Checker Plugins
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m =
case catMaybes $ mapPlugins hsc_env tcPlugin of
case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of
[] -> m -- Common fast case
plugins -> do
ev_binds_var <- newTcEvBinds
......@@ -3096,7 +3096,7 @@ withTcPlugins hsc_env m =
withDefaultingPlugins :: HscEnv -> TcM a -> TcM a
withDefaultingPlugins hsc_env m =
do case catMaybes $ mapPlugins hsc_env defaultingPlugin of
do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of
[] -> m -- Common fast case
plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
-- This ensures that dePluginStop is called even if a type
......@@ -3114,7 +3114,7 @@ withDefaultingPlugins hsc_env m =
withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins hsc_env m =
case catMaybes $ mapPlugins hsc_env holeFitPlugin of
case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of
[] -> m -- Common fast case
plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
-- This ensures that hfPluginStop is called even if a type
......@@ -3136,7 +3136,7 @@ runRenamerPlugin :: TcGblEnv
-> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin gbl_env hs_group = do
hsc_env <- getTopEnv
withPlugins hsc_env
withPlugins (hsc_plugins hsc_env)
(\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)
>> renamedResultAction p opts e g))
(gbl_env, hs_group)
......@@ -3159,7 +3159,7 @@ getRenamedStuff tc_result
runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin sum gbl_env = do
hsc_env <- getTopEnv
withPlugins hsc_env
withPlugins (hsc_plugins hsc_env)
(\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)
>> typeCheckResultAction p opts sum env)
gbl_env
......
......@@ -68,7 +68,9 @@ main = do
target <- guessTarget "static-plugins-module.hs" Nothing Nothing
setTargets [target]
modifySession (\hsc_env -> hsc_env { hsc_static_plugins = the_plugins})
modifySession $ \hsc_env ->
let old_plugins = hsc_plugins hsc_env
in hsc_env { hsc_plugins = old_plugins { staticPlugins = the_plugins } }
dflags <- getSessionDynFlags
setSessionDynFlags dflags { outputFile_ = Nothing }
......
Subproject commit bbe3c508cc5688683f9febbed814e5230dce0c4b
Subproject commit 00e7d92f372c706dfd749d824c8c97d38383c25f
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment