Only load plugins once

Summary: This is part of D4342 which is worthwhile to merge on its own.

Reviewers: nboldi, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4410



Co-authored-by: Boldizsar Nemeth <nboldi@elte.hu>

compiler/main/DynFlags.hs

@@ -179,6 +179,7 @@ import Platform
 import PlatformConstants
 import Module
 import PackageConfig
+import {-# SOURCE #-} Plugins
 import {-# SOURCE #-} Hooks
 import {-# SOURCE #-} PrelNames ( mAIN )
 import {-# SOURCE #-} Packages (PackageState, emptyPackageState)
@@ -924,6 +925,12 @@ data DynFlags = DynFlags {
   frontendPluginOpts    :: [String],
     -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
     -- order that they're specified on the command line.
+  plugins               :: [LoadedPlugin],
+    -- ^ plugins loaded after processing arguments. What will be loaded here
+    -- is directed by pluginModNames. Arguments are loaded from
+    -- pluginModNameOpts. The purpose of this field is to cache the plugins so
+    -- they don't have to be loaded each time they are needed.
+    -- See 'DynamicLoading.initializePlugins'.
 
   -- GHC API hooks
   hooks                 :: Hooks,
@@ -1761,6 +1768,7 @@ defaultDynFlags mySettings myLlvmTargets =
         pluginModNames          = [],
         pluginModNameOpts       = [],
         frontendPluginOpts      = [],
+        plugins                 = [],
         hooks                   = emptyHooks,
 
         outputFile              = Nothing,

compiler/main/DynamicLoading.hs

@@ -2,9 +2,9 @@
 
 -- | Dynamically lookup up values from modules and loading them.
 module DynamicLoading (
+        initializePlugins,
 #if defined(GHCI)
         -- * Loading plugins
-        loadPlugins,
         loadFrontendPlugin,
 
         -- * Force loading information
@@ -20,11 +20,13 @@ module DynamicLoading (
         getHValueSafely,
         lessUnsafeCoerce
 #else
-        pluginError,
+        pluginError
 #endif
     ) where
 
 import GhcPrelude
+import HscTypes         ( HscEnv )
+import DynFlags
 
 #if defined(GHCI)
 import Linker           ( linkModule, getHValue )
@@ -38,8 +40,7 @@ import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)
                         , gre_name, mkRdrQual )
 import OccName          ( OccName, mkVarOcc )
 import RnNames          ( gresFromAvails )
-import DynFlags
-import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )
+import Plugins
 import PrelNames        ( pluginTyConName, frontendPluginTyConName )
 
 import HscTypes
@@ -65,12 +66,35 @@ import Module           ( ModuleName, moduleNameString )
 import Panic
 
 import Data.List        ( intercalate )
+import Control.Monad    ( unless )
+
+#endif
 
+-- | Loads the plugins specified in the pluginModNames field of the dynamic
+-- flags. Should be called after command line arguments are parsed, but before
+-- actual compilation starts. Idempotent operation. Should be re-called if
+-- pluginModNames or pluginModNameOpts changes.
+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
+initializePlugins hsc_env df
+#if !defined(GHCI)
+  = do let pluginMods = pluginModNames df
+       unless (null pluginMods) (pluginError pluginMods)
+       return df
+#else
+  | map lpModuleName (plugins df) == pluginModNames df -- plugins not changed
+     && all (\p -> lpArguments p == argumentsForPlugin p (pluginModNameOpts df))
+            (plugins df) -- arguments not changed
+  = return df -- no need to reload plugins
+  | otherwise
+  = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
+       return $ df { plugins = loadedPlugins }
+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
 #endif
 
+
 #if defined(GHCI)
 
-loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
+loadPlugins :: HscEnv -> IO [LoadedPlugin]
 loadPlugins hsc_env
   = do { plugins <- mapM (loadPlugin hsc_env) to_load
        ; return $ zipWith attachOptions to_load plugins }
@@ -78,7 +102,7 @@ loadPlugins hsc_env
     dflags  = hsc_dflags hsc_env
     to_load = pluginModNames dflags
 
-    attachOptions mod_nm plug = (mod_nm, plug, options)
+    attachOptions mod_nm plug = LoadedPlugin plug mod_nm (reverse options)
       where
         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
                             , opt_mod_nm == mod_nm ]

compiler/main/HscMain.hs

@@ -169,6 +169,7 @@ import System.IO (fixIO)
 import qualified Data.Map as Map
 import qualified Data.Set as S
 import Data.Set (Set)
+import DynamicLoading (initializePlugins)
 
 #include "HsVersions.h"
 
@@ -671,15 +672,18 @@ hscIncrementalCompile :: Bool
 hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
     mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
   = do
+    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
+    let hsc_env'' = hsc_env' { hsc_dflags = dflags }
+
     -- One-shot mode needs a knot-tying mutable variable for interface
     -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
     -- See also Note [hsc_type_env_var hack]
     type_env_var <- newIORef emptyNameEnv
     let mod = ms_mod mod_summary
-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'))
-                = hsc_env' { hsc_type_env_var = Just (mod, type_env_var) }
+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
+                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
                 | otherwise
-                = hsc_env'
+                = hsc_env''
 
     -- NB: enter Hsc monad here so that we don't bail out early with
     -- -Werror on typechecker warnings; we also want to run the desugarer

compiler/main/Plugins.hs

+{-# LANGUAGE RankNTypes #-}
 module Plugins (
     FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction,
-    Plugin(..), CommandLineOption,
-    defaultPlugin
+    Plugin(..), CommandLineOption, LoadedPlugin(..),
+    defaultPlugin, withPlugins, withPlugins_
     ) where
 
 import GhcPrelude
 
 import CoreMonad ( CoreToDo, CoreM )
-import TcRnTypes ( TcPlugin )
+import TcRnTypes ( TcPlugin)
+import DynFlags
 import GhcMonad
 import DriverPhases
+import Module ( ModuleName )
 
+import Control.Monad
 
 -- | Command line options gathered from the -PModule.Name:stuff syntax
 -- are given to you as this type
 type CommandLineOption = String
 
--- | 'Plugin' is the core compiler plugin data type. Try to avoid
+-- | 'Plugin' is the compiler plugin data type. Try to avoid
 -- constructing one of these directly, and just modify some fields of
 -- 'defaultPlugin' instead: this is to try and preserve source-code
 -- compatibility when we add fields to this.
@@ -34,6 +38,16 @@ data Plugin = Plugin {
     -- behaviour of the constraint solver.
   }
 
+-- | 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
+  , lpArguments :: [CommandLineOption]
+    -- ^ command line arguments for the plugin
+  }
+
 -- | Default plugin: does nothing at all! For compatibility reasons
 -- you should base all your plugin definitions on this default value.
 defaultPlugin :: Plugin
@@ -42,6 +56,21 @@ defaultPlugin = Plugin {
       , tcPlugin         = const Nothing
     }
 
+type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
+type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
+
+-- | Perform an operation by using all of the plugins in turn.
+withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
+withPlugins df transformation input
+  = foldM (\arg (LoadedPlugin p _ opts) -> transformation p opts arg)
+          input (plugins df)
+
+-- | Perform a constant operation by using all of the plugins in turn.
+withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
+withPlugins_ df transformation input
+  = mapM_ (\(LoadedPlugin p _ opts) -> transformation p opts input)
+          (plugins df)
+
 type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
 data FrontendPlugin = FrontendPlugin {
       frontend :: FrontendPluginAction

compiler/main/Plugins.hs-boot

+-- The plugins datatype is stored in DynFlags, so it needs to be
+-- exposed without importing all of its implementation.
+module Plugins where
+
+import GhcPrelude ()
+
+data Plugin
+
+data LoadedPlugin

compiler/simplCore/SimplCore.hs

@@ -51,6 +51,8 @@ import Vectorise        ( vectorise )
 import SrcLoc
 import Util
 import Module
+import Plugins          ( withPlugins,installCoreToDos )
+import DynamicLoading  -- ( initializePlugins )
 
 import Maybes
 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
@@ -58,14 +60,6 @@ import UniqFM
 import Outputable
 import Control.Monad
 import qualified GHC.LanguageExtensions as LangExt
-
-#if defined(GHCI)
-import DynamicLoading   ( loadPlugins )
-import Plugins          ( installCoreToDos )
-#else
-import DynamicLoading   ( pluginError )
-#endif
-
 {-
 ************************************************************************
 *                                                                      *
@@ -87,7 +81,11 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod
        ;
        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
                                     orph_mods print_unqual loc $
-                           do { all_passes <- addPluginPasses builtin_passes
+                           do { hsc_env' <- getHscEnv
+                              ; dflags' <- liftIO $ initializePlugins hsc_env'
+                                                      (hsc_dflags hsc_env')
+                              ; all_passes <- withPlugins dflags'
+                                                installCoreToDos builtin_passes
                               ; runCorePasses all_passes guts }
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
@@ -373,24 +371,6 @@ getCoreToDo dflags
       flatten_todos passes ++ flatten_todos rest
     flatten_todos (todo : rest) = todo : flatten_todos rest
 
--- Loading plugins
-
-addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
-#if !defined(GHCI)
-addPluginPasses builtin_passes
-  = do { dflags <- getDynFlags
-       ; let pluginMods = pluginModNames dflags
-       ; unless (null pluginMods) (pluginError pluginMods)
-       ; return builtin_passes }
-#else
-addPluginPasses builtin_passes
-  = do { hsc_env <- getHscEnv
-       ; named_plugins <- liftIO (loadPlugins hsc_env)
-       ; foldM query_plug builtin_passes named_plugins }
-  where
-    query_plug todos (_, plug, options) = installCoreToDos plug options todos
-#endif
-
 {- Note [Inline in InitialPhase]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is

compiler/typecheck/TcRnDriver.hs

@@ -58,11 +58,7 @@ import RnFixity ( lookupFixityRn )
 import MkId
 import TidyPgm    ( globaliseAndTidyId )
 import TysWiredIn ( unitTy, mkListTy )
-#if defined(GHCI)
-import DynamicLoading ( loadPlugins )
-import Plugins ( tcPlugin )
-#endif
-
+import Plugins ( tcPlugin, LoadedPlugin(..))
 import DynFlags
 import HsSyn
 import IfaceSyn ( ShowSub(..), showToHeader )
@@ -2670,7 +2666,7 @@ Type Checker Plugins
 
 withTcPlugins :: HscEnv -> TcM a -> TcM a
 withTcPlugins hsc_env m =
-  do plugins <- liftIO (loadTcPlugins hsc_env)
+  do let plugins = getTcPlugins (hsc_dflags hsc_env)
      case plugins of
        [] -> m  -- Common fast case
        _  -> do ev_binds_var <- newTcEvBinds
@@ -2688,13 +2684,6 @@ withTcPlugins hsc_env m =
     do s <- runTcPluginM start ev_binds_var
        return (solve s, stop s)
 
-loadTcPlugins :: HscEnv -> IO [TcPlugin]
-#if !defined(GHCI)
-loadTcPlugins _ = return []
-#else
-loadTcPlugins hsc_env =
- do named_plugins <- loadPlugins hsc_env
-    return $ catMaybes $ map load_plugin named_plugins
-  where
-    load_plugin (_, plug, opts) = tcPlugin plug opts
-#endif
+getTcPlugins :: DynFlags -> [TcPlugin]
+getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
+  where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p)