Commit f8e3cd3b authored by Matthew Pickering's avatar Matthew Pickering

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/D4410Co-authored-by: lazac's avatarBoldizsar Nemeth <nboldi@elte.hu>
parent 8dab89b4
......@@ -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,
......
......@@ -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 ]
......
......@@ -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
......
{-# 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
......
-- 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
......@@ -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
......
......@@ -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)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment