summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthew.pickering@tweag.io>2018-05-27 11:57:27 -0400
committerBen Gamari <ben@smart-cactus.org>2018-05-30 18:06:33 -0400
commit1d1e2b77fdc2babdf4fff72b9120c6831e7b422f (patch)
tree088af3cf628ef34181ec90434d55d5f1b05ead41
parente0b44e2eccd4053852b6c4c3de75a714301ec080 (diff)
downloadhaskell-1d1e2b77fdc2babdf4fff72b9120c6831e7b422f.tar.gz
Implement "An API for deciding whether plugins should cause recompilation"
This patch implements the API proposed as pull request #108 for plugin authors to influence the recompilation checker. It adds a new field to a plugin which computes a `FingerPrint`. This is recorded in interface files and if it changes then we recompile the module. There are also helper functions such as `purePlugin` and `impurePlugin` for constructing plugins which have simple recompilation semantics but in general, an author can compute a hash as they wish. Fixes #12567 and #7414 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/002 2-plugin-recompilation.rst Reviewers: bgamari, ggreif Reviewed By: bgamari Subscribers: rwbarton, thomie, carter GHC Trac Issues: #7414, #12567 Differential Revision: https://phabricator.haskell.org/D4366
-rw-r--r--compiler/deSugar/Desugar.hs6
-rw-r--r--compiler/deSugar/DsUsage.hs21
-rw-r--r--compiler/iface/LoadIface.hs1
-rw-r--r--compiler/iface/MkIface.hs70
-rw-r--r--compiler/main/DynamicLoading.hs18
-rw-r--r--compiler/main/HscTypes.hs6
-rw-r--r--compiler/main/Plugins.hs64
-rw-r--r--compiler/simplCore/CoreMonad.hs6
-rw-r--r--compiler/simplCore/SimplCore.hs5
-rw-r--r--docs/users_guide/extending_ghc.rst57
-rw-r--r--testsuite/tests/plugins/Makefile27
-rw-r--r--testsuite/tests/plugins/T12567a.stderr5
-rw-r--r--testsuite/tests/plugins/all.T18
-rw-r--r--testsuite/tests/plugins/plugin-recomp-flags.stderr6
-rw-r--r--testsuite/tests/plugins/plugin-recomp-flags.stdout4
-rw-r--r--testsuite/tests/plugins/plugin-recomp-impure.stderr6
-rw-r--r--testsuite/tests/plugins/plugin-recomp-impure.stdout4
-rw-r--r--testsuite/tests/plugins/plugin-recomp-pure.stderr3
-rw-r--r--testsuite/tests/plugins/plugin-recomp-pure.stdout2
-rw-r--r--testsuite/tests/plugins/plugin-recomp-test.hs8
-rw-r--r--testsuite/tests/plugins/plugin-recomp/Common.hs17
-rw-r--r--testsuite/tests/plugins/plugin-recomp/FingerprintPlugin.hs10
-rw-r--r--testsuite/tests/plugins/plugin-recomp/ImpurePlugin.hs10
-rw-r--r--testsuite/tests/plugins/plugin-recomp/LICENSE10
-rw-r--r--testsuite/tests/plugins/plugin-recomp/Makefile20
-rw-r--r--testsuite/tests/plugins/plugin-recomp/PurePlugin.hs10
-rw-r--r--testsuite/tests/plugins/plugin-recomp/Setup.hs3
-rw-r--r--testsuite/tests/plugins/plugin-recomp/plugin-recomp.cabal20
-rw-r--r--testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs7
29 files changed, 406 insertions, 38 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index e8ce029b04..ce12a5631a 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -66,6 +66,7 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
+import Plugins ( LoadedPlugin(..) )
{-
************************************************************************
@@ -169,7 +170,10 @@ deSugar hsc_env
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
- ; deps <- mkDependencies tcg_env
+ pluginModules =
+ map lpModule (plugins (hsc_dflags hsc_env))
+ ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
+ pluginModules tcg_env
; used_th <- readIORef tc_splice_used
; dep_files <- readIORef dependent_files
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
index 2eebca818f..c8a04247cc 100644
--- a/compiler/deSugar/DsUsage.hs
+++ b/compiler/deSugar/DsUsage.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
module DsUsage (
-- * Dependency/fingerprinting code (used by MkIface)
@@ -49,17 +50,23 @@ its dep_orphs. This was the cause of Trac #14128.
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
-mkDependencies :: TcGblEnv -> IO Dependencies
-mkDependencies
- TcGblEnv{ tcg_mod = mod,
+--
+-- The first argument is additional dependencies from plugins
+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
+mkDependencies iuid pluginModules
+ (TcGblEnv{ tcg_mod = mod,
tcg_imports = imports,
tcg_th_used = th_var
- }
+ })
= do
-- Template Haskell used?
+ let (mns, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
+ plugin_dep_mods = map (,False) mns
+ plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
th_used <- readIORef th_var
let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
(moduleName mod))
+ ++ plugin_dep_mods
-- M.hi-boot can be in the imp_dep_mods, but we must remove
-- it before recording the modules on which this one depends!
-- (We want to retain M.hi-boot in imp_dep_mods so that
@@ -71,8 +78,10 @@ mkDependencies
-- We must also remove self-references from imp_orphs. See
-- Note [Module self-dependency]
- pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
- | otherwise = imp_dep_pkgs imports
+ raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
+
+ pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
+ | otherwise = raw_pkgs
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 8f0e958b48..0845208a32 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -1073,6 +1073,7 @@ pprModIface iface
, nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
, nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))
, nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))
+ , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))
, nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (text "where")
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index bb19a9ef13..3375abd6e5 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -118,6 +118,12 @@ import Data.Ord
import Data.IORef
import System.Directory
import System.FilePath
+import Plugins ( PluginRecompile(..), Plugin(..), LoadedPlugin(..))
+#if __GLASGOW_HASKELL__ < 840
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
+#endif
{-
************************************************************************
@@ -177,7 +183,11 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
}
= do
let used_names = mkUsedNames tc_result
- deps <- mkDependencies tc_result
+ let pluginModules =
+ map lpModule (plugins (hsc_dflags hsc_env))
+ deps <- mkDependencies
+ (thisInstalledUnitId (hsc_dflags hsc_env))
+ pluginModules tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
@@ -196,6 +206,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
(imp_trust_own_pkg imports) safe_mode usages mod_details
+
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
@@ -283,6 +294,7 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_opt_hash = fingerprint0,
mi_hpc_hash = fingerprint0,
mi_exp_hash = fingerprint0,
+ mi_plugin_hash = fingerprint0,
mi_used_th = used_th,
mi_orphan_hash = fingerprint0,
mi_orphan = False, -- Always set by addFingerprints, but
@@ -667,6 +679,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+ plugin_hash <- fingerprintPlugins hsc_env
+
-- the ABI hash depends on:
-- - decls
-- - export list
@@ -704,6 +718,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
mi_flag_hash = flag_hash,
mi_opt_hash = opt_hash,
mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
mi_orphan = not ( all ifRuleAuto orph_rules
-- See Note [Orphans and auto-generated rules]
&& null orph_insts
@@ -1093,6 +1108,16 @@ data RecompileRequired
-- to force recompilation; the String says what (one-line summary)
deriving Eq
+instance Semigroup RecompileRequired where
+ UpToDate <> r = r
+ mc <> _ = mc
+
+instance Monoid RecompileRequired where
+ mempty = UpToDate
+#if __GLASGOW_HASKELL__ < 840
+ mappend = (Data.Semigroup.<>)
+#endif
+
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
recompileRequired _ = True
@@ -1219,6 +1244,9 @@ 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
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
-- Source code unchanged and no errors yet... carry on
--
@@ -1236,13 +1264,51 @@ checkVersions hsc_env mod_summary iface
; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
; return (recomp, Just iface)
- }}}}}}}}
+ }}}}}}}}}
where
this_pkg = thisPackage (hsc_dflags hsc_env)
-- This is a bit of a hack really
mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
+-- | Check if any plugins are requesting recompilation
+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
+ return (pluginRecompileToRecompileRequired old_fingerprint res)
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+ fingerprintPlugins' (plugins (hsc_dflags hsc_env))
+
+fingerprintPlugins' :: [LoadedPlugin] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+ res <- mconcat <$> mapM checkPlugin 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
+
+
+
+checkPlugin :: LoadedPlugin -> IO PluginRecompile
+checkPlugin (LoadedPlugin plugin _ opts) = pluginRecompile plugin opts
+
+pluginRecompileToRecompileRequired :: Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp pr =
+ case pr of
+ NoForceRecompile -> UpToDate
+ ForceRecompile -> RecompBecause "Plugin forced recompilation"
+ MaybeRecompile fp -> if fp == old_fp then UpToDate
+ else RecompBecause "Plugin fingerprint changed"
+
+
-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 90a099f9a7..21fe359d3c 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -105,17 +105,17 @@ loadPlugins hsc_env
dflags = hsc_dflags hsc_env
to_load = pluginModNames dflags
- attachOptions mod_nm plug = LoadedPlugin plug mod_nm (reverse options)
+ attachOptions mod_nm (plug, mod) = LoadedPlugin plug mod (reverse options)
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
-
loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env
+
loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+ fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
hsc_env mod_name
-- #14335
@@ -127,7 +127,7 @@ checkExternalInterpreter hsc_env =
where
dflags = hsc_dflags hsc_env
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, Module)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
@@ -139,7 +139,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
[ text "The module", ppr mod_name
, text "did not export the plugin name"
, ppr plugin_rdr_name ]) ;
- Just name ->
+ Just (name, mod) ->
do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
@@ -149,7 +149,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
[ text "The value", ppr name
, text "did not have the type"
, ppr pluginTyConName, text "as required"])
- Just plugin -> return plugin } } }
+ Just plugin -> return (plugin, mod) } } }
-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
@@ -256,7 +256,9 @@ lessUnsafeCoerce dflags context what = do
-- loaded very partially: just enough that it can be used, without its
-- rules and instances affecting (and being linked from!) the module
-- being compiled. This was introduced by 57d6798.
-lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
+--
+-- Need the module as well to record information in the interface file
+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, Module))
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
-- First find the package the module resides in by searching exposed packages and home modules
found_module <- findPluginModule hsc_env mod_name
@@ -274,7 +276,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
imp_spec = ImpSpec decl_spec ImpAll
env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
case lookupGRE_RdrName rdr_name env of
- [gre] -> return (Just (gre_name gre))
+ [gre] -> return (Just (gre_name gre, mi_module iface))
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index d62b5929d7..e17e2794b4 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -861,6 +861,7 @@ data ModIface
-- excluding optimisation flags
mi_opt_hash :: !Fingerprint, -- ^ Hash of optimisation flags
mi_hpc_hash :: !Fingerprint, -- ^ Hash of hpc flags
+ mi_plugin_hash :: !Fingerprint, -- ^ Hash of plugins
mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans
mi_finsts :: !WhetherHasFamInst,
@@ -1023,6 +1024,7 @@ instance Binary ModIface where
mi_flag_hash = flag_hash,
mi_opt_hash = opt_hash,
mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
@@ -1051,6 +1053,7 @@ instance Binary ModIface where
put_ bh flag_hash
put_ bh opt_hash
put_ bh hpc_hash
+ put_ bh plugin_hash
put_ bh orphan
put_ bh hasFamInsts
lazyPut bh deps
@@ -1081,6 +1084,7 @@ instance Binary ModIface where
flag_hash <- get bh
opt_hash <- get bh
hpc_hash <- get bh
+ plugin_hash <- get bh
orphan <- get bh
hasFamInsts <- get bh
deps <- lazyGet bh
@@ -1110,6 +1114,7 @@ instance Binary ModIface where
mi_flag_hash = flag_hash,
mi_opt_hash = opt_hash,
mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
@@ -1149,6 +1154,7 @@ emptyModIface mod
mi_flag_hash = fingerprint0,
mi_opt_hash = fingerprint0,
mi_hpc_hash = fingerprint0,
+ mi_plugin_hash = fingerprint0,
mi_orphan = False,
mi_finsts = False,
mi_hsc_src = HsSrcFile,
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index cd391a3c7b..85c5d07882 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -1,18 +1,30 @@
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
module Plugins (
FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction,
- Plugin(..), CommandLineOption, LoadedPlugin(..),
+ Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName,
defaultPlugin, withPlugins, withPlugins_
+ , PluginRecompile(..)
+ , purePlugin, impurePlugin, flagRecompile
) where
import GhcPrelude
import CoreMonad ( CoreToDo, CoreM )
-import TcRnTypes ( TcPlugin)
+import qualified TcRnTypes (TcPlugin)
import DynFlags
import GhcMonad
import DriverPhases
-import Module ( ModuleName )
+import Module ( ModuleName, Module(moduleName))
+import Fingerprint
+import Data.List
+import Outputable (Outputable(..), text, (<+>))
+
+#if __GLASGOW_HASKELL__ < 840
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
+#endif
import Control.Monad
@@ -28,32 +40,70 @@ type CommandLineOption = String
-- Nonetheless, this API is preliminary and highly likely to change in
-- the future.
data Plugin = Plugin {
- installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+ installCoreToDos :: CorePlugin
-- ^ Modify the Core pipeline that will be used for compilation.
-- This is called as the Core pipeline is built for every module
-- being compiled, and plugins get the opportunity to modify the
-- pipeline in a nondeterministic order.
- , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin
+ , tcPlugin :: TcPlugin
-- ^ An optional typechecker plugin, which may modify the
-- behaviour of the constraint solver.
+ , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
+ -- ^ Specify how the plugin should affect recompilation.
}
-- | A plugin with its arguments. The result of loading the plugin.
data LoadedPlugin = LoadedPlugin {
lpPlugin :: Plugin
-- ^ the actual callable plugin
- , lpModuleName :: ModuleName
- -- ^ the qualified name of the module containing the plugin
+ , lpModule :: Module
+ -- ^ The module the plugin is defined in
, lpArguments :: [CommandLineOption]
-- ^ command line arguments for the plugin
}
+lpModuleName :: LoadedPlugin -> ModuleName
+lpModuleName = moduleName . lpModule
+
+
+data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
+
+instance Outputable PluginRecompile where
+ ppr ForceRecompile = text "ForceRecompile"
+ ppr NoForceRecompile = text "NoForceRecompile"
+ ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp
+
+instance Semigroup PluginRecompile where
+ ForceRecompile <> _ = ForceRecompile
+ NoForceRecompile <> r = r
+ MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp
+ MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp'])
+ MaybeRecompile _fp <> ForceRecompile = ForceRecompile
+
+instance Monoid PluginRecompile where
+ mempty = NoForceRecompile
+#if __GLASGOW_HASKELL__ < 840
+ mappend = (Data.Semigroup.<>)
+#endif
+
+type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
+
+purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
+purePlugin _args = return NoForceRecompile
+
+impurePlugin _args = return ForceRecompile
+
+flagRecompile =
+ return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort
+
-- | Default plugin: does nothing at all! For compatibility reasons
-- you should base all your plugin definitions on this default value.
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
+ , pluginRecompile = impurePlugin
}
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index a9be6c1f50..e5b449b516 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -14,7 +14,7 @@ module CoreMonad (
pprPassDetails,
-- * Plugins
- PluginPass, bindsOnlyPass,
+ CorePluginPass, bindsOnlyPass,
-- * Counting
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
@@ -108,7 +108,7 @@ data CoreToDo -- These are diff core-to-core passes,
= CoreDoSimplify -- The core-to-core simplifier.
Int -- Max iterations
SimplMode
- | CoreDoPluginPass String PluginPass
+ | CoreDoPluginPass String CorePluginPass
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
@@ -239,7 +239,7 @@ runMaybe Nothing _ = CoreDoNothing
-}
-- | A description of the plugin pass itself
-type PluginPass = ModGuts -> CoreM ModGuts
+type CorePluginPass = ModGuts -> CoreM ModGuts
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass pass guts
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index fe6d44625a..70a13cc110 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -52,7 +52,7 @@ import Vectorise ( vectorise )
import SrcLoc
import Util
import Module
-import Plugins ( withPlugins,installCoreToDos )
+import Plugins ( withPlugins, installCoreToDos )
import DynamicLoading -- ( initializePlugins )
import Maybes
@@ -86,7 +86,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
; dflags' <- liftIO $ initializePlugins hsc_env'
(hsc_dflags hsc_env')
; all_passes <- withPlugins dflags'
- installCoreToDos builtin_passes
+ installCoreToDos
+ builtin_passes
; runCorePasses all_passes guts }
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index 12043a0542..d8eaab9419 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -600,6 +600,63 @@ the plugin to create equality axioms for use in evidence terms, but GHC
does not check their consistency, and inconsistent axiom sets may lead
to segfaults or other runtime misbehaviour.
+.. _plugin_recompilation:
+
+Controlling Recompilation
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+By default, modules compiled with plugins are always recompiled even if the source file is
+unchanged. This most conservative option is taken due to the ability of plugins
+to perform arbitrary IO actions. In order to control the recompilation behaviour
+you can modify the ``pluginRecompile`` field in ``Plugin``. ::
+
+ plugin :: Plugin
+ plugin = defaultPlugin {
+ installCoreToDos = install,
+ pluginRecompile = purePlugin
+ }
+
+By inspecting the example ``plugin`` defined above, we can see that it is pure. This
+means that if the two modules have the same fingerprint then the plugin
+will always return the same result. Declaring a plugin as pure means that
+the plugin will never cause a module to be recompiled.
+
+In general, the ``pluginRecompile`` field has the following type::
+
+ pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
+
+The ``PluginRecompile`` data type is an enumeration determining how the plugin
+should affect recompilation. ::
+ data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
+
+A plugin which declares itself impure using ``ForceRecompile`` will always
+trigger a recompilation of the current module. ``NoForceRecompile`` is used
+for "pure" plugins which don't need to be rerun unless a module would ordinarily
+be recompiled. ``MaybeRecompile`` computes a ``Fingerprint`` and if this ``Fingerprint``
+is different to a previously computed ``Fingerprint`` for the plugin, then
+we recompile the module.
+
+As such, ``purePlugin`` is defined as a function which always returns ``NoForceRecompile``. ::
+
+ purePlugin :: [CommandLineOption] -> IO PluginRecompile
+ purePlugin _ = return NoForceRecompile
+
+Users can use the same functions that GHC uses internally to compute fingerprints.
+The `GHC.Fingerprint
+<https://hackage.haskell.org/package/base-4.10.1.0/docs/GHC-Fingerprint.html>`_ module provides useful functions for constructing fingerprints. For example, combining
+together ``fingerprintFingerprints`` and ``fingerprintString`` provides an easy to
+to naively fingerprint the arguments to a plugin. ::
+
+ pluginFlagRecompile :: [CommandLineOption] -> IO PluginRecompile
+ pluginFlagRecompile =
+ return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort
+
+``defaultPlugin`` defines ``pluginRecompile`` to be ``impurePlugin`` which
+is the most conservative and backwards compatible option. ::
+
+ impurePlugin :: [CommandLineOption] -> IO PluginRecompile
+ impurePlugin _ = return ForceRecompile
+
.. _frontend_plugins:
Frontend plugins
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index 1ff8d40e8b..3e983fded6 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -50,5 +50,30 @@ T11244:
.PHONY: T12567a
T12567a:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make T12567a.hs -package-db simple-plugin/pkg.T12567a/local.package.conf -hide-all-plugin-packages -plugin-package simple-plugin 1>&2
- "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make T12567a.hs -package-db simple-plugin/pkg.T12567a/local.package.conf -hide-all-plugin-packages -plugin-package simple-plugin 2>&1 | grep "T12567a.hs, T12567a.o" 1>&2
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make T12567a.hs -package-db simple-plugin/pkg.T12567a/local.package.conf -hide-all-plugin-packages -plugin-package simple-plugin 1>&2
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make T12567b.hs -package-db simple-plugin/pkg.T12567a/local.package.conf -hide-all-plugin-packages -plugin-package simple-plugin 1>&2
+
+.PHONY: T14335
+T14335:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -fexternal-interpreter --make -v0 plugins01.hs -package-db simple-plugin/pkg.plugins01/local.package.conf -fplugin Simple.Plugin -fplugin-opt Simple.Plugin:Irrelevant_Option -hide-all-plugin-packages -plugin-package simple-plugin
+ ./plugins01
+
+# Shouldn't recompile the module
+.PHONY: plugin-recomp-pure
+plugin-recomp-pure:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin PurePlugin
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin PurePlugin
+
+# Should recompile the module
+.PHONY: plugin-recomp-impure
+plugin-recomp-impure:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin ImpurePlugin
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin ImpurePlugin
+
+# Should not recompile the module the first time but should the second time
+.PHONY: plugin-recomp-flags
+plugin-recomp-flags:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin FingerprintPlugin -fplugin-opt FingerprintPlugin:0
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin FingerprintPlugin -fplugin-opt FingerprintPlugin:0
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin FingerprintPlugin -fplugin-opt FingerprintPlugin:1
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) plugin-recomp-test.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin FingerprintPlugin -fplugin-opt FingerprintPlugin:1
diff --git a/testsuite/tests/plugins/T12567a.stderr b/testsuite/tests/plugins/T12567a.stderr
index aee35e3528..efc75384e6 100644
--- a/testsuite/tests/plugins/T12567a.stderr
+++ b/testsuite/tests/plugins/T12567a.stderr
@@ -2,9 +2,4 @@
Simple Plugin Passes Queried
Got options:
Simple Plugin Pass Run
-[1 of 1] Compiling T12567a ( T12567a.hs, T12567a.o ) [Simple.Plugin changed]
-[1 of 2] Compiling T12567a ( T12567a.hs, T12567a.o ) [Simple.Plugin changed]
-Simple Plugin Passes Queried
-Got options:
-Simple Plugin Pass Run
[2 of 2] Compiling T12567b ( T12567b.hs, T12567b.o )
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 57866371b3..94d0e2d053 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -74,3 +74,21 @@ test('T14335',
compile_fail,
['-package-db simple-plugin/pkg.plugins01/local.package.conf -fplugin Simple.Plugin \
-fexternal-interpreter -package simple-plugin ' + config.plugin_way_flags])
+
+test('plugin-recomp-pure',
+ [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C plugin-recomp package.plugins01 TOP={top}')
+ ],
+ run_command, ['$MAKE -s --no-print-directory plugin-recomp-pure'])
+
+test('plugin-recomp-impure',
+ [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C plugin-recomp package.plugins01 TOP={top}')
+ ],
+ run_command, ['$MAKE -s --no-print-directory plugin-recomp-impure'])
+
+test('plugin-recomp-flags',
+ [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C plugin-recomp package.plugins01 TOP={top}')
+ ],
+ run_command, ['$MAKE -s --no-print-directory plugin-recomp-flags'])
diff --git a/testsuite/tests/plugins/plugin-recomp-flags.stderr b/testsuite/tests/plugins/plugin-recomp-flags.stderr
new file mode 100644
index 0000000000..a7f0da692a
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-flags.stderr
@@ -0,0 +1,6 @@
+Simple Plugin Passes Queried
+Got options: 0
+Simple Plugin Pass Run
+Simple Plugin Passes Queried
+Got options: 1
+Simple Plugin Pass Run
diff --git a/testsuite/tests/plugins/plugin-recomp-flags.stdout b/testsuite/tests/plugins/plugin-recomp-flags.stdout
new file mode 100644
index 0000000000..342fa3e0f8
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-flags.stdout
@@ -0,0 +1,4 @@
+[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o )
+Linking plugin-recomp-test ...
+[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Plugin fingerprint changed]
+Linking plugin-recomp-test ...
diff --git a/testsuite/tests/plugins/plugin-recomp-impure.stderr b/testsuite/tests/plugins/plugin-recomp-impure.stderr
new file mode 100644
index 0000000000..a1edc3bda5
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-impure.stderr
@@ -0,0 +1,6 @@
+Simple Plugin Passes Queried
+Got options:
+Simple Plugin Pass Run
+Simple Plugin Passes Queried
+Got options:
+Simple Plugin Pass Run
diff --git a/testsuite/tests/plugins/plugin-recomp-impure.stdout b/testsuite/tests/plugins/plugin-recomp-impure.stdout
new file mode 100644
index 0000000000..d282cfea8f
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-impure.stdout
@@ -0,0 +1,4 @@
+[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o )
+Linking plugin-recomp-test ...
+[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Plugin forced recompilation]
+Linking plugin-recomp-test ...
diff --git a/testsuite/tests/plugins/plugin-recomp-pure.stderr b/testsuite/tests/plugins/plugin-recomp-pure.stderr
new file mode 100644
index 0000000000..84e15cfa91
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-pure.stderr
@@ -0,0 +1,3 @@
+Simple Plugin Passes Queried
+Got options:
+Simple Plugin Pass Run
diff --git a/testsuite/tests/plugins/plugin-recomp-pure.stdout b/testsuite/tests/plugins/plugin-recomp-pure.stdout
new file mode 100644
index 0000000000..a6828318a0
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-pure.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o )
+Linking plugin-recomp-test ...
diff --git a/testsuite/tests/plugins/plugin-recomp-test.hs b/testsuite/tests/plugins/plugin-recomp-test.hs
new file mode 100644
index 0000000000..2cc84a9eac
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp-test.hs
@@ -0,0 +1,8 @@
+-- Intended to test that the plugins have basic functionality --
+-- * Can modify the program
+-- * Get to see command line options
+module Main where
+
+main = do
+ putStrLn "Program Started"
+ putStrLn "Program Ended"
diff --git a/testsuite/tests/plugins/plugin-recomp/Common.hs b/testsuite/tests/plugins/plugin-recomp/Common.hs
new file mode 100644
index 0000000000..dc49025c60
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/Common.hs
@@ -0,0 +1,17 @@
+module Common where
+
+import GhcPlugins
+
+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+install options todos = do
+ putMsgS $ "Simple Plugin Passes Queried"
+ putMsgS $ "Got options: " ++ unwords options
+
+ -- Create some actual passes to continue the test.
+ return $ CoreDoPluginPass "Main pass" mainPass
+ : todos
+
+mainPass :: ModGuts -> CoreM ModGuts
+mainPass guts = do
+ putMsgS "Simple Plugin Pass Run"
+ return guts
diff --git a/testsuite/tests/plugins/plugin-recomp/FingerprintPlugin.hs b/testsuite/tests/plugins/plugin-recomp/FingerprintPlugin.hs
new file mode 100644
index 0000000000..584962470a
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/FingerprintPlugin.hs
@@ -0,0 +1,10 @@
+module FingerprintPlugin where
+
+import GhcPlugins
+import Common
+
+plugin :: Plugin
+plugin = defaultPlugin {
+ installCoreToDos = install,
+ pluginRecompile = flagRecompile
+ }
diff --git a/testsuite/tests/plugins/plugin-recomp/ImpurePlugin.hs b/testsuite/tests/plugins/plugin-recomp/ImpurePlugin.hs
new file mode 100644
index 0000000000..0ccb626a15
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/ImpurePlugin.hs
@@ -0,0 +1,10 @@
+module ImpurePlugin where
+
+import GhcPlugins
+import Common
+
+plugin :: Plugin
+plugin = defaultPlugin {
+ installCoreToDos = install,
+ pluginRecompile = impurePlugin
+ }
diff --git a/testsuite/tests/plugins/plugin-recomp/LICENSE b/testsuite/tests/plugins/plugin-recomp/LICENSE
new file mode 100644
index 0000000000..6297f71b3f
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/LICENSE
@@ -0,0 +1,10 @@
+Copyright (c) 2008, Max Bolingbroke
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+ * Neither the name of Max Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/testsuite/tests/plugins/plugin-recomp/Makefile b/testsuite/tests/plugins/plugin-recomp/Makefile
new file mode 100644
index 0000000000..ae5c24e87f
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/Makefile
@@ -0,0 +1,20 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean.%:
+ rm -rf pkg.$*
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package.%:
+ $(MAKE) -s --no-print-directory clean.$*
+ mkdir pkg.$*
+ "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
+
+ "$(GHC_PKG)" init pkg.$*/local.package.conf
+
+ pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling)
+ pkg.$*/setup build --distdir pkg.$*/dist -v0
+ pkg.$*/setup install --distdir pkg.$*/dist -v0
diff --git a/testsuite/tests/plugins/plugin-recomp/PurePlugin.hs b/testsuite/tests/plugins/plugin-recomp/PurePlugin.hs
new file mode 100644
index 0000000000..c106aa3400
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/PurePlugin.hs
@@ -0,0 +1,10 @@
+module PurePlugin where
+
+import GhcPlugins
+import Common
+
+plugin :: Plugin
+plugin = defaultPlugin {
+ installCoreToDos = install,
+ pluginRecompile = purePlugin
+ }
diff --git a/testsuite/tests/plugins/plugin-recomp/Setup.hs b/testsuite/tests/plugins/plugin-recomp/Setup.hs
new file mode 100644
index 0000000000..e8ef27dbba
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/testsuite/tests/plugins/plugin-recomp/plugin-recomp.cabal b/testsuite/tests/plugins/plugin-recomp/plugin-recomp.cabal
new file mode 100644
index 0000000000..dabaf72e03
--- /dev/null
+++ b/testsuite/tests/plugins/plugin-recomp/plugin-recomp.cabal
@@ -0,0 +1,20 @@
+Name: plugin-recompilation
+Version: 0.1
+Synopsis: Testing plugin recompilation
+Cabal-Version: >= 1.2
+Build-Type: Simple
+License: BSD3
+License-File: LICENSE
+Author: Matthew Pickering
+Homepage: http://blog.omega-prime.co.uk
+
+Library
+ Extensions: CPP
+ Build-Depends:
+ base,
+ ghc >= 6.11
+ Exposed-Modules:
+ PurePlugin
+ ImpurePlugin
+ FingerprintPlugin
+ Common
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
index e8c2435849..94cb74b151 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
@@ -16,14 +16,15 @@ import qualified Language.Haskell.TH as TH
plugin :: Plugin
plugin = defaultPlugin {
- installCoreToDos = install
+ installCoreToDos = install,
+ pluginRecompile = purePlugin
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install options todos = do
putMsgS $ "Simple Plugin Passes Queried"
putMsgS $ "Got options: " ++ unwords options
-
+
-- Create some actual passes to continue the test.
return $ CoreDoPluginPass "Main pass" mainPass
: todos
@@ -36,7 +37,7 @@ findNameBind target (NonRec b e) = findNameBndr target b
findNameBind target (Rec bes) = mconcat (map (findNameBndr target . fst) bes)
findNameBndr :: String -> CoreBndr -> First Name
-findNameBndr target b
+findNameBndr target b
= if getOccString (varName b) == target
then First (Just (varName b))
else First Nothing