Implement "An API for deciding whether plugins should cause recompilation"
authorMatthew Pickering <matthew.pickering@tweag.io>
Sun, 27 May 2018 15:57:27 +0000 (11:57 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 30 May 2018 22:06:33 +0000 (18:06 -0400)
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

29 files changed:
compiler/deSugar/Desugar.hs
compiler/deSugar/DsUsage.hs
compiler/iface/LoadIface.hs
compiler/iface/MkIface.hs
compiler/main/DynamicLoading.hs
compiler/main/HscTypes.hs
compiler/main/Plugins.hs
compiler/simplCore/CoreMonad.hs
compiler/simplCore/SimplCore.hs
docs/users_guide/extending_ghc.rst
testsuite/tests/plugins/Makefile
testsuite/tests/plugins/T12567a.stderr
testsuite/tests/plugins/all.T
testsuite/tests/plugins/plugin-recomp-flags.stderr [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-flags.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-impure.stderr [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-impure.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-pure.stderr [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-pure.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp-test.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/Common.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/FingerprintPlugin.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/ImpurePlugin.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/LICENSE [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/Makefile [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/PurePlugin.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/Setup.hs [new file with mode: 0644]
testsuite/tests/plugins/plugin-recomp/plugin-recomp.cabal [new file with mode: 0644]
testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs

index e8ce029..ce12a56 100644 (file)
@@ -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
index 2eebca8..c8a0424 100644 (file)
@@ -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]
index 8f0e958..0845208 100644 (file)
@@ -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")
index bb19a9e..3375abd 100644 (file)
@@ -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
index 90a099f..21fe359 100644 (file)
@@ -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"
 
index d62b592..e17e279 100644 (file)
@@ -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,
index cd391a3..85c5d07 100644 (file)
@@ -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
index a9be6c1..e5b449b 100644 (file)
@@ -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
index fe6d446..70a13cc 100644 (file)
@@ -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
index 12043a0..d8eaab9 100644 (file)
@@ -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
index 1ff8d40..3e983fd 100644 (file)
@@ -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
index aee35e3..efc7538 100644 (file)
@@ -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 )
index 5786637..94d0e2d 100644 (file)
@@ -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 (file)
index 0000000..a7f0da6
--- /dev/null
@@ -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 (file)
index 0000000..342fa3e
--- /dev/null
@@ -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 (file)
index 0000000..a1edc3b
--- /dev/null
@@ -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 (file)
index 0000000..d282cfe
--- /dev/null
@@ -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 (file)
index 0000000..84e15cf
--- /dev/null
@@ -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 (file)
index 0000000..a682831
--- /dev/null
@@ -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 (file)
index 0000000..2cc84a9
--- /dev/null
@@ -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 (file)
index 0000000..dc49025
--- /dev/null
@@ -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 (file)
index 0000000..5849624
--- /dev/null
@@ -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 (file)
index 0000000..0ccb626
--- /dev/null
@@ -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 (file)
index 0000000..6297f71
--- /dev/null
@@ -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 (file)
index 0000000..ae5c24e
--- /dev/null
@@ -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 (file)
index 0000000..c106aa3
--- /dev/null
@@ -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 (file)
index 0000000..e8ef27d
--- /dev/null
@@ -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 (file)
index 0000000..dabaf72
--- /dev/null
@@ -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
index e8c2435..94cb74b 100644 (file)
@@ -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