summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-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
9 files changed, 168 insertions, 29 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
View Lorry Controller Status