summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs2
-rw-r--r--compiler/GHC/Driver/Env/Types.hs17
-rw-r--r--compiler/GHC/Driver/Main.hs5
-rw-r--r--compiler/GHC/Driver/Plugins.hs50
-rw-r--r--compiler/GHC/Driver/Plugins.hs-boot3
-rw-r--r--compiler/GHC/HsToCore.hs4
-rw-r--r--compiler/GHC/Iface/Load.hs2
-rw-r--r--compiler/GHC/Iface/Make.hs4
-rw-r--r--compiler/GHC/Iface/Recomp.hs47
-rw-r--r--compiler/GHC/Runtime/Context.hs4
-rw-r--r--compiler/GHC/Runtime/Loader.hs12
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs10
13 files changed, 88 insertions, 74 deletions
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 7062865ed7..6b68ccee64 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -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 }
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index 0c58ac8855..b0fcc6fd64 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -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.).
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index c403b3e85a..39c1f7af4e 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -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
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index 83d41a6695..4fbbd5ce32 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -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 {
diff --git a/compiler/GHC/Driver/Plugins.hs-boot b/compiler/GHC/Driver/Plugins.hs-boot
index 7b5f8ca161..15b3657dd0 100644
--- a/compiler/GHC/Driver/Plugins.hs-boot
+++ b/compiler/GHC/Driver/Plugins.hs-boot
@@ -5,6 +5,9 @@ module GHC.Driver.Plugins where
import GHC.Prelude ()
data Plugin
+data Plugins
+
+emptyPlugins :: Plugins
data LoadedPlugin
data StaticPlugin
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index d55bdf7115..a7bbbf16aa 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -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)
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 78005781d4..f1da9d7e0a 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -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)
}}}}
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index fd0516ca87..9627752811 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -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)
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 89e10424e3..6b184787fa 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -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
diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs
index a1df5fd029..8222e96ce8 100644
--- a/compiler/GHC/Runtime/Context.hs
+++ b/compiler/GHC/Runtime/Context.hs
@@ -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
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 704f499a4f..e93e6969bc 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -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
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 9ddff4213b..bba7eeaedc 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -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')
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 06270c1848..68bfba4448 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -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
View Lorry Controller Status