diff options
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 2 | ||||
| -rw-r--r-- | compiler/iface/MkIface.hs | 18 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 19 | ||||
| -rw-r--r-- | compiler/main/DynamicLoading.hs | 13 | ||||
| -rw-r--r-- | compiler/main/Plugins.hs | 45 | ||||
| -rw-r--r-- | compiler/main/Plugins.hs-boot | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/plugins/all.T | 6 | ||||
| -rw-r--r-- | testsuite/tests/plugins/static-plugins-module.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/plugins/static-plugins.hs | 80 | ||||
| -rw-r--r-- | testsuite/tests/plugins/static-plugins.stdout | 25 |
11 files changed, 178 insertions, 36 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 0ed35f2d4c..aa24ee0a5d 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -169,7 +169,7 @@ deSugar hsc_env ; let used_names = mkUsedNames tcg_env pluginModules = - map lpModule (plugins (hsc_dflags hsc_env)) + map lpModule (cachedPlugins (hsc_dflags hsc_env)) ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tcg_env diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index aba14baa2d..7b66472d7a 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -119,7 +119,8 @@ import Data.Ord import Data.IORef import System.Directory import System.FilePath -import Plugins ( PluginRecompile(..), Plugin(..), LoadedPlugin(..)) +import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), + pluginRecompile', plugins ) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> @@ -189,7 +190,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details = do let used_names = mkUsedNames tc_result let pluginModules = - map lpModule (plugins (hsc_dflags hsc_env)) + map lpModule (cachedPlugins (hsc_dflags hsc_env)) deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tc_result @@ -1324,17 +1325,16 @@ checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc iface = liftIO $ do -- [(ModuleName, Plugin, [Opts])] let old_fingerprint = mi_plugin_hash iface - loaded_plugins = plugins (hsc_dflags hsc) - res <- mconcat <$> mapM checkPlugin loaded_plugins + res <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) return (pluginRecompileToRecompileRequired old_fingerprint res) fingerprintPlugins :: HscEnv -> IO Fingerprint fingerprintPlugins hsc_env = do - fingerprintPlugins' (plugins (hsc_dflags hsc_env)) + fingerprintPlugins' $ plugins(hsc_dflags hsc_env) -fingerprintPlugins' :: [LoadedPlugin] -> IO Fingerprint +fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint fingerprintPlugins' plugins = do - res <- mconcat <$> mapM checkPlugin plugins + res <- mconcat <$> mapM pluginRecompile' plugins return $ case res of NoForceRecompile -> fingerprintString "NoForceRecompile" ForceRecompile -> fingerprintString "ForceRecompile" @@ -1344,10 +1344,6 @@ fingerprintPlugins' plugins = do (MaybeRecompile fp) -> fp - -checkPlugin :: LoadedPlugin -> IO PluginRecompile -checkPlugin (LoadedPlugin plugin _ opts) = pluginRecompile plugin opts - pluginRecompileToRecompileRequired :: Fingerprint -> PluginRecompile -> RecompileRequired pluginRecompileToRecompileRequired old_fp pr = case pr of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3fb3874c63..48c7103dd9 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -984,12 +984,18 @@ 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. - plugins :: [LoadedPlugin], - -- ^ plugins loaded after processing arguments. What will be loaded here - -- is directed by pluginModNames. Arguments are loaded from + 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 'DynamicLoading.initializePlugins'. + -- they don't have to be loaded each time they are needed. See + -- 'DynamicLoading.initializePlugins'. + staticPlugins :: [StaticPlugin], + -- ^ staic 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, @@ -1917,7 +1923,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = pluginModNames = [], pluginModNameOpts = [], frontendPluginOpts = [], - plugins = [], + cachedPlugins = [], + staticPlugins = [], hooks = emptyHooks, outputFile = Nothing, diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 7420f7cc01..0a5264e3f2 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -83,13 +83,15 @@ initializePlugins _ df return df #else initializePlugins hsc_env df - | map lpModuleName (plugins df) == pluginModNames df -- plugins not changed - && all (\p -> lpArguments p == argumentsForPlugin p (pluginModNameOpts df)) - (plugins df) -- arguments not changed + | 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 | otherwise = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) - return $ df { plugins = loadedPlugins } + return $ df { cachedPlugins = loadedPlugins } where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) #endif @@ -106,7 +108,8 @@ loadPlugins hsc_env dflags = hsc_dflags hsc_env to_load = pluginModNames dflags - attachOptions mod_nm (plug, mod) = LoadedPlugin plug mod (reverse options) + attachOptions mod_nm (plug, mod) = + LoadedPlugin (PluginWithArgs plug (reverse options)) mod where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs index 430b0790f9..de04415244 100644 --- a/compiler/main/Plugins.hs +++ b/compiler/main/Plugins.hs @@ -32,8 +32,10 @@ module Plugins ( , keepRenamedSource -- * Internal + , PluginWithArgs(..), plugins, pluginRecompile' , LoadedPlugin(..), lpModuleName - , withPlugins, withPlugins_ + , StaticPlugin(..) + , mapPlugins, withPlugins, withPlugins_ ) where import GhcPrelude @@ -120,20 +122,33 @@ data Plugin = Plugin { -- For the full discussion, check the full proposal at: -- https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } -- | A plugin with its arguments. The result of loading the plugin. -data LoadedPlugin = LoadedPlugin { - lpPlugin :: Plugin - -- ^ the actual callable plugin +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments , lpModule :: ModIface - -- ^ the module containing the plugin - , lpArguments :: [CommandLineOption] - -- ^ command line arguments for the plugin + -- ^ the module containing the plugin + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments } lpModuleName :: LoadedPlugin -> ModuleName lpModuleName = moduleName . mi_module . lpModule +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint @@ -196,16 +211,24 @@ 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) + -- | 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 (\arg (LoadedPlugin p _ opts) -> transformation p opts arg) - input (plugins df) +withPlugins df transformation input = foldM go input (plugins df) + 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) -- | 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 - = mapM_ (\(LoadedPlugin p _ opts) -> transformation p opts input) + = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) (plugins df) type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () diff --git a/compiler/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot index 4ccd3d8402..c90c6ebaf7 100644 --- a/compiler/main/Plugins.hs-boot +++ b/compiler/main/Plugins.hs-boot @@ -7,3 +7,4 @@ import GhcPrelude () data Plugin data LoadedPlugin +data StaticPlugin diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 3b12837bdc..0a6d7e5bb2 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -2832,8 +2832,7 @@ withTcPlugins hsc_env m = return (solve s, stop s) getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] -getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags) - where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p) +getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) runRenamerPlugin :: TcGblEnv -> HsGroup GhcRn diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T index 9a1a7ea398..72a42da91a 100644 --- a/testsuite/tests/plugins/all.T +++ b/testsuite/tests/plugins/all.T @@ -193,3 +193,9 @@ test('plugin-recomp-change-prof', when(not config.have_profiling,skip) ], run_command, ['$MAKE -s --no-print-directory plugin-recomp-change-prof']) + +test('static-plugins', + [extra_files(['simple-plugin/']), + extra_run_opts('"' + config.libdir + '"')], + compile_and_run, + ['-package ghc -isimple-plugin/']) diff --git a/testsuite/tests/plugins/static-plugins-module.hs b/testsuite/tests/plugins/static-plugins-module.hs new file mode 100644 index 0000000000..4aafd0de8a --- /dev/null +++ b/testsuite/tests/plugins/static-plugins-module.hs @@ -0,0 +1,2 @@ +module Main where +main = print "Hello world!" diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs new file mode 100644 index 0000000000..36e18b86b5 --- /dev/null +++ b/testsuite/tests/plugins/static-plugins.hs @@ -0,0 +1,80 @@ +module Main where + +import Avail +import Control.Monad.IO.Class +import DynFlags + (getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut) +import GHC +import GHC.Fingerprint.Type +import HsDecls +import HsDoc +import HsExpr +import HsExtension +import HsImpExp +import HscTypes +import Outputable +import Plugins +import System.Environment +import TcRnTypes + +import Simple.SourcePlugin (plugin) + +main = do + libdir:args <- getArgs + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + -- liftIO $ print args + -- (dflags,_,_) + -- <- parseDynamicFlagsCmdLine dflags (map noLoc args) + -- we need to LinkInMemory otherwise `setTarget [] >> load LoadAllTargets` + -- below will fail. + setSessionDynFlags dflags { ghcLink = LinkInMemory} + + -- Start with a pure plugin, this should trigger recomp. + liftIO $ putStrLn "==pure.0" + loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []] + + -- The same (or a different) pure plugin shouldn't trigger recomp. + liftIO $ putStrLn "==pure.1" + loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []] + + -- Next try with a fingerprint plugin, should trigger recomp. + liftIO $ putStrLn "==fp0.0" + loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []] + + -- With the same fingerprint plugin, should not trigger recomp. + liftIO $ putStrLn "==fp0.1" + loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []] + + -- Change the plugin fingerprint, should trigger recomp. + liftIO $ putStrLn "==fp1" + loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp1 []] + + -- TODO: this currently doesn't work, patch pending + -- -- Even though the plugin is now pure we should still recomp since we + -- -- used a potentially impure plugin before + -- liftIO $ putStrLn "pure.2" + -- loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []] + + where + loadWithPlugins the_plugins = do + -- first unload (like GHCi :load does) + GHC.setTargets [] + _ <- GHC.load LoadAllTargets + + target <- guessTarget "static-plugins-module.hs" Nothing + setTargets [target] + + dflags <- getSessionDynFlags + setSessionDynFlags dflags { staticPlugins = the_plugins + , outputFile = Nothing } + load LoadAllTargets + + +plugin_fp0 = + plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 0 } +plugin_fp1 = + plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 1 } +plugin0_pure = + plugin { pluginRecompile = \_ -> pure $ NoForceRecompile } diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout new file mode 100644 index 0000000000..f7520a7cfb --- /dev/null +++ b/testsuite/tests/plugins/static-plugins.stdout @@ -0,0 +1,25 @@ +==pure.0 +parsePlugin() +interfacePlugin: Prelude +interfacePlugin: GHC.Float +interfacePlugin: GHC.Base +interfacePlugin: System.IO +typeCheckPlugin (rn) +interfacePlugin: GHC.Prim +interfacePlugin: GHC.Show +interfacePlugin: GHC.Types +interfacePlugin: GHC.TopHandler +typeCheckPlugin (tc) +interfacePlugin: GHC.CString +interfacePlugin: GHC.Integer.Type +interfacePlugin: GHC.Natural +==pure.1 +==fp0.0 +parsePlugin() +typeCheckPlugin (rn) +typeCheckPlugin (tc) +==fp0.1 +==fp1 +parsePlugin() +typeCheckPlugin (rn) +typeCheckPlugin (tc) |