Commit da05d79d authored by Daniel Gröber (dxld)'s avatar Daniel Gröber (dxld) Committed by Ben Gamari

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
parent 9e763afa
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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 ]
......
......@@ -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 ()
......
......@@ -7,3 +7,4 @@ import GhcPrelude ()
data Plugin
data LoadedPlugin
data StaticPlugin
......@@ -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
......
......@@ -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/'])
module Main where
main = print "Hello world!"
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 }
==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)
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