diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-12-14 11:23:02 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-12-21 01:46:39 -0500 |
commit | 9728d6c2b62f38f79c8833b1819200985fe173dc (patch) | |
tree | 8e44abae10080473b22ad71f750613cdc1fa9a96 | |
parent | 00b55bfcd982bed2c9fc02d9c3ca66ba9d41bb5c (diff) | |
download | haskell-9728d6c2b62f38f79c8833b1819200985fe173dc.tar.gz |
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
-rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Env/Types.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Driver/Plugins.hs | 50 | ||||
-rw-r--r-- | compiler/GHC/Driver/Plugins.hs-boot | 3 | ||||
-rw-r--r-- | compiler/GHC/HsToCore.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Iface/Load.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Make.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 47 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Context.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/plugins/static-plugins.hs | 4 | ||||
m--------- | utils/haddock | 0 |
15 files changed, 91 insertions, 75 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 diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs index 73d91a93e3..5d5afc4dcc 100644 --- a/testsuite/tests/plugins/static-plugins.hs +++ b/testsuite/tests/plugins/static-plugins.hs @@ -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 } diff --git a/utils/haddock b/utils/haddock -Subproject bbe3c508cc5688683f9febbed814e5230dce0c4 +Subproject 00e7d92f372c706dfd749d824c8c97d38383c25 |