diff options
author | Daniel Gröber <dxld@darkboxed.org> | 2018-12-11 13:24:12 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-12-11 14:23:22 -0500 |
commit | da05d79d03e5e03e391b381f23c46fc02957abf7 (patch) | |
tree | 4506d0f46dc5df4293ae1933d87b1367be0de831 | |
parent | 9e763afa9f1f75eacce24291f298f32527591b14 (diff) | |
download | haskell-da05d79d03e5e03e391b381f23c46fc02957abf7.tar.gz |
Support registering Plugins through the GHC API
This allows tooling using the GHC API to use plugins internally.
Hopefully this will make it possible to decouple the development of
useful plugins from (currently) kitchen-sink type tooling projects
such as ghc-mod or HIE -- at least to some extent.
Test Plan: validate
Reviewers: bgamari, mpickering
Subscribers: mpickering, alanz, rwbarton, carter
GHC Trac Issues: #15826
Differential Revision: https://phabricator.haskell.org/D5278
-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) |