Commit f8e3cd3b authored by Matthew Pickering's avatar Matthew Pickering
Browse files

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: lazac's avatarBoldizsar Nemeth <nboldi@elte.hu>
parent 8dab89b4
...@@ -179,6 +179,7 @@ import Platform ...@@ -179,6 +179,7 @@ import Platform
import PlatformConstants import PlatformConstants
import Module import Module
import PackageConfig import PackageConfig
import {-# SOURCE #-} Plugins
import {-# SOURCE #-} Hooks import {-# SOURCE #-} Hooks
import {-# SOURCE #-} PrelNames ( mAIN ) import {-# SOURCE #-} PrelNames ( mAIN )
import {-# SOURCE #-} Packages (PackageState, emptyPackageState) import {-# SOURCE #-} Packages (PackageState, emptyPackageState)
...@@ -924,6 +925,12 @@ data DynFlags = DynFlags { ...@@ -924,6 +925,12 @@ data DynFlags = DynFlags {
frontendPluginOpts :: [String], frontendPluginOpts :: [String],
-- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
-- order that they're specified on the command line. -- 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 -- GHC API hooks
hooks :: Hooks, hooks :: Hooks,
...@@ -1761,6 +1768,7 @@ defaultDynFlags mySettings myLlvmTargets = ...@@ -1761,6 +1768,7 @@ defaultDynFlags mySettings myLlvmTargets =
pluginModNames = [], pluginModNames = [],
pluginModNameOpts = [], pluginModNameOpts = [],
frontendPluginOpts = [], frontendPluginOpts = [],
plugins = [],
hooks = emptyHooks, hooks = emptyHooks,
outputFile = Nothing, outputFile = Nothing,
......
...@@ -2,9 +2,9 @@ ...@@ -2,9 +2,9 @@
-- | Dynamically lookup up values from modules and loading them. -- | Dynamically lookup up values from modules and loading them.
module DynamicLoading ( module DynamicLoading (
initializePlugins,
#if defined(GHCI) #if defined(GHCI)
-- * Loading plugins -- * Loading plugins
loadPlugins,
loadFrontendPlugin, loadFrontendPlugin,
-- * Force loading information -- * Force loading information
...@@ -20,11 +20,13 @@ module DynamicLoading ( ...@@ -20,11 +20,13 @@ module DynamicLoading (
getHValueSafely, getHValueSafely,
lessUnsafeCoerce lessUnsafeCoerce
#else #else
pluginError, pluginError
#endif #endif
) where ) where
import GhcPrelude import GhcPrelude
import HscTypes ( HscEnv )
import DynFlags
#if defined(GHCI) #if defined(GHCI)
import Linker ( linkModule, getHValue ) import Linker ( linkModule, getHValue )
...@@ -38,8 +40,7 @@ import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) ...@@ -38,8 +40,7 @@ import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..)
, gre_name, mkRdrQual ) , gre_name, mkRdrQual )
import OccName ( OccName, mkVarOcc ) import OccName ( OccName, mkVarOcc )
import RnNames ( gresFromAvails ) import RnNames ( gresFromAvails )
import DynFlags import Plugins
import Plugins ( Plugin, FrontendPlugin, CommandLineOption )
import PrelNames ( pluginTyConName, frontendPluginTyConName ) import PrelNames ( pluginTyConName, frontendPluginTyConName )
import HscTypes import HscTypes
...@@ -65,12 +66,35 @@ import Module ( ModuleName, moduleNameString ) ...@@ -65,12 +66,35 @@ import Module ( ModuleName, moduleNameString )
import Panic import Panic
import Data.List ( intercalate ) 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 #endif
#if defined(GHCI) #if defined(GHCI)
loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])] loadPlugins :: HscEnv -> IO [LoadedPlugin]
loadPlugins hsc_env loadPlugins hsc_env
= do { plugins <- mapM (loadPlugin hsc_env) to_load = do { plugins <- mapM (loadPlugin hsc_env) to_load
; return $ zipWith attachOptions to_load plugins } ; return $ zipWith attachOptions to_load plugins }
...@@ -78,7 +102,7 @@ loadPlugins hsc_env ...@@ -78,7 +102,7 @@ loadPlugins hsc_env
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
to_load = pluginModNames dflags to_load = pluginModNames dflags
attachOptions mod_nm plug = (mod_nm, plug, options) attachOptions mod_nm plug = LoadedPlugin plug mod_nm (reverse options)
where where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ] , opt_mod_nm == mod_nm ]
......
...@@ -169,6 +169,7 @@ import System.IO (fixIO) ...@@ -169,6 +169,7 @@ import System.IO (fixIO)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as S import qualified Data.Set as S
import Data.Set (Set) import Data.Set (Set)
import DynamicLoading (initializePlugins)
#include "HsVersions.h" #include "HsVersions.h"
...@@ -671,15 +672,18 @@ hscIncrementalCompile :: Bool ...@@ -671,15 +672,18 @@ hscIncrementalCompile :: Bool
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do = 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 -- One-shot mode needs a knot-tying mutable variable for interface
-- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
-- See also Note [hsc_type_env_var hack] -- See also Note [hsc_type_env_var hack]
type_env_var <- newIORef emptyNameEnv type_env_var <- newIORef emptyNameEnv
let mod = ms_mod mod_summary let mod = ms_mod mod_summary
hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env')) hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
= hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
| otherwise | otherwise
= hsc_env' = hsc_env''
-- NB: enter Hsc monad here so that we don't bail out early with -- 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 -- -Werror on typechecker warnings; we also want to run the desugarer
......
{-# LANGUAGE RankNTypes #-}
module Plugins ( module Plugins (
FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction, FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction,
Plugin(..), CommandLineOption, Plugin(..), CommandLineOption, LoadedPlugin(..),
defaultPlugin defaultPlugin, withPlugins, withPlugins_
) where ) where
import GhcPrelude import GhcPrelude
import CoreMonad ( CoreToDo, CoreM ) import CoreMonad ( CoreToDo, CoreM )
import TcRnTypes ( TcPlugin ) import TcRnTypes ( TcPlugin)
import DynFlags
import GhcMonad import GhcMonad
import DriverPhases import DriverPhases
import Module ( ModuleName )
import Control.Monad
-- | Command line options gathered from the -PModule.Name:stuff syntax -- | Command line options gathered from the -PModule.Name:stuff syntax
-- are given to you as this type -- are given to you as this type
type CommandLineOption = String 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 -- constructing one of these directly, and just modify some fields of
-- 'defaultPlugin' instead: this is to try and preserve source-code -- 'defaultPlugin' instead: this is to try and preserve source-code
-- compatibility when we add fields to this. -- compatibility when we add fields to this.
...@@ -34,6 +38,16 @@ data Plugin = Plugin { ...@@ -34,6 +38,16 @@ data Plugin = Plugin {
-- behaviour of the constraint solver. -- 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 -- | Default plugin: does nothing at all! For compatibility reasons
-- you should base all your plugin definitions on this default value. -- you should base all your plugin definitions on this default value.
defaultPlugin :: Plugin defaultPlugin :: Plugin
...@@ -42,6 +56,21 @@ defaultPlugin = Plugin { ...@@ -42,6 +56,21 @@ defaultPlugin = Plugin {
, tcPlugin = const Nothing , 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 () type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
data FrontendPlugin = FrontendPlugin { data FrontendPlugin = FrontendPlugin {
frontend :: FrontendPluginAction 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 ) ...@@ -51,6 +51,8 @@ import Vectorise ( vectorise )
import SrcLoc import SrcLoc
import Util import Util
import Module import Module
import Plugins ( withPlugins,installCoreToDos )
import DynamicLoading -- ( initializePlugins )
import Maybes import Maybes
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
...@@ -58,14 +60,6 @@ import UniqFM ...@@ -58,14 +60,6 @@ import UniqFM
import Outputable import Outputable
import Control.Monad import Control.Monad
import qualified GHC.LanguageExtensions as LangExt 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 ...@@ -87,7 +81,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
; ;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
orph_mods print_unqual loc $ 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 } ; runCorePasses all_passes guts }
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
...@@ -373,24 +371,6 @@ getCoreToDo dflags ...@@ -373,24 +371,6 @@ getCoreToDo dflags
flatten_todos passes ++ flatten_todos rest flatten_todos passes ++ flatten_todos rest
flatten_todos (todo : rest) = todo : 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] {- Note [Inline in InitialPhase]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
......
...@@ -58,11 +58,7 @@ import RnFixity ( lookupFixityRn ) ...@@ -58,11 +58,7 @@ import RnFixity ( lookupFixityRn )
import MkId import MkId
import TidyPgm ( globaliseAndTidyId ) import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy ) import TysWiredIn ( unitTy, mkListTy )
#if defined(GHCI) import Plugins ( tcPlugin, LoadedPlugin(..))
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
#endif
import DynFlags import DynFlags
import HsSyn import HsSyn
import IfaceSyn ( ShowSub(..), showToHeader ) import IfaceSyn ( ShowSub(..), showToHeader )
...@@ -2670,7 +2666,7 @@ Type Checker Plugins ...@@ -2670,7 +2666,7 @@ Type Checker Plugins
withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m = withTcPlugins hsc_env m =
do plugins <- liftIO (loadTcPlugins hsc_env) do let plugins = getTcPlugins (hsc_dflags hsc_env)
case plugins of case plugins of
[] -> m -- Common fast case [] -> m -- Common fast case
_ -> do ev_binds_var <- newTcEvBinds _ -> do ev_binds_var <- newTcEvBinds
...@@ -2688,13 +2684,6 @@ withTcPlugins hsc_env m = ...@@ -2688,13 +2684,6 @@ withTcPlugins hsc_env m =
do s <- runTcPluginM start ev_binds_var do s <- runTcPluginM start ev_binds_var
return (solve s, stop s) return (solve s, stop s)
loadTcPlugins :: HscEnv -> IO [TcPlugin] getTcPlugins :: DynFlags -> [TcPlugin]
#if !defined(GHCI) getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
loadTcPlugins _ = return [] where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p)
#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
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