diff options
author | Aaron Allen <aaron@flipstone.com> | 2022-06-19 21:10:57 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-05-05 18:42:31 -0400 |
commit | 18a7d03d46706d2217235d26a72e6f1e82c62192 (patch) | |
tree | 4a5f944dd1071effdafb8ade44d7682c00aa307b | |
parent | a5174a591b890544b065a3fcb5923f51e61283f2 (diff) | |
download | haskell-18a7d03d46706d2217235d26a72e6f1e82c62192.tar.gz |
Rework plugin initialisation points
In general this patch pushes plugin initialisation points to earlier in
the pipeline. As plugins can modify the `HscEnv`, it's imperative that
the plugins are initialised as soon as possible and used thereafter.
For example, there are some new tests which modify hsc_logger and other
hooks which failed to fire before (and now do)
One consequence of this change is that the error for specifying the
usage of a HPT plugin from the command line has changed, because it's
now attempted to be loaded at initialisation rather than causing a
cyclic module import.
Closes #21279
Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 6 | ||||
-rw-r--r-- | ghc/Main.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/plugins/all.T | 14 | ||||
-rw-r--r-- | testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs | 24 | ||||
-rw-r--r-- | testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs (renamed from testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs) | 2 | ||||
-rw-r--r-- | testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs | 30 | ||||
-rw-r--r-- | testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal | 2 | ||||
-rw-r--r-- | testsuite/tests/plugins/plugins04.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/plugins/test-hooks-plugin.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/plugins/test-log-hooks-plugin.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/plugins/test-log-hooks-plugin.stderr | 9 | ||||
-rw-r--r-- | testsuite/tests/plugins/test-phase-hooks-plugin.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/plugins/test-phase-hooks-plugin.stderr | 5 |
16 files changed, 130 insertions, 22 deletions
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index c047056ea6..2cc762b9cd 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -694,6 +694,9 @@ data WorkerLimit -- produced by calling 'depanal'. load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag load' mhmi_cache how_much mHscMessage mod_graph = do + -- In normal usage plugins are initialised already by ghc/Main.hs this is protective + -- for any client who might interact with GHC via load'. + initializeSessionPlugins modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession @@ -2852,13 +2855,11 @@ label_self thread_name = do runPipelines :: WorkerLimit -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines runPipelines _ _ _ [] = return () -runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do +runPipelines n_job hsc_env mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" - - plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of - NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env mHscMessager all_pipelines runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index e539c3fcbf..f709ad801c 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -244,6 +244,7 @@ compileOne' mHscMessage addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] + -- Initialise plugins here for any plugins enabled locally for a module. plugin_hsc_env <- initializePlugins hsc_env let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary @@ -526,7 +527,11 @@ findHSLib platform ws dirs lib = do -- Compile files in one-shot mode. oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do +oneShot orig_hsc_env stop_phase srcs = do + -- In oneshot mode, initialise plugins specified on command line + -- we also initialise in ghc/Main but this might be used as an entry point by API clients who + -- should initialise their own plugins but may not. + hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of StopPreprocess -> return () diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 75f33834e2..7694975e80 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -62,7 +62,6 @@ import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Types.SourceError import GHC.Unit.Finder -import GHC.Runtime.Loader import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways @@ -82,6 +81,7 @@ import GHC.StgToJS.Linker.Linker (embedJsFile) import Language.Haskell.Syntax.Module.Name import GHC.Unit.Home.ModInfo +import GHC.Runtime.Loader (initializePlugins) newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -724,9 +724,11 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do new_includes = addImplicitQuoteInclude paths [current_dir] paths = includePaths dflags0 dflags = dflags0 { includePaths = new_includes } - hsc_env = hscSetFlags dflags hsc_env0 - + hsc_env1 = hscSetFlags dflags hsc_env0 + -- Initialise plugins as the flags passed into runHscPhase might have local plugins just + -- specific to this module. + hsc_env <- initializePlugins hsc_env1 -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do @@ -786,18 +788,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- run the compiler! let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what - plugin_hsc_env' <- initializePlugins hsc_env -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } - status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) - return (plugin_hsc_env, mod_summary, status) + return (hsc_env', mod_summary, status) -- | Calculate the ModLocation from the provided DynFlags. This function is only used -- in one-shot mode and therefore takes into account the effect of -o/-ohi flags diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 29f61fe591..3349ed0020 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -2,7 +2,7 @@ -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader ( - initializePlugins, + initializePlugins, initializeSessionPlugins, -- * Loading plugins loadFrontendPlugin, @@ -74,7 +74,11 @@ import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types import Data.List (unzip4) import GHC.Iface.Errors.Ppr +import GHC.Driver.Monad +-- | Initialise plugins specified by the current DynFlags and update the session. +initializeSessionPlugins :: GhcMonad m => m () +initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before diff --git a/ghc/Main.hs b/ghc/Main.hs index ef3de102c0..5b1f33bb4e 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -41,7 +41,7 @@ import GHC.Platform.Host import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif -import GHC.Runtime.Loader ( loadFrontendPlugin ) +import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins ) import GHC.Unit.Env import GHC.Unit (UnitId, homeUnitDepends) @@ -257,16 +257,23 @@ main' postLoadMode units dflags0 args flagWarnings = do -- we've finished manipulating the DynFlags, update the session _ <- GHC.setSessionDynFlags dflags5 dflags6 <- GHC.getSessionDynFlags - hsc_env <- GHC.getSession + + -- Must do this before loading plugins + liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) + + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + initializeSessionPlugins + hsc_env <- getSession logger <- getLogger + ---------------- Display configuration ----------- case verbosity dflags6 of v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env | v >= 5 -> liftIO $ dumpUnits hsc_env | otherwise -> return () - liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs units diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T index ef0096f064..c782ad13cd 100644 --- a/testsuite/tests/plugins/all.T +++ b/testsuite/tests/plugins/all.T @@ -317,3 +317,17 @@ test('plugins-external', pre_cmd('$MAKE -s --no-print-directory -C shared-plugin package.plugins01 TOP={top}'), when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], makefile_test, []) + +test('test-phase-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-phase-hooks-plugin TOP={top}'), + + when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], + compile, + ['-package-db hooks-plugin/pkg.test-phase-hooks-plugin/local.package.conf -fplugin Hooks.PhasePlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-log-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], + compile_fail, + ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs new file mode 100644 index 0000000000..10591240f9 --- /dev/null +++ b/testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs @@ -0,0 +1,24 @@ +module Hooks.LogPlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Utils.Logger +import GHC.Driver.Pipeline.Execute +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let logger = hsc_logger hsc_env + logger' = pushLogHook logHook logger + hsc_env' = hsc_env { hsc_logger = logger' } + return hsc_env' + +logHook :: LogAction -> LogAction +logHook action logFlags messageClass srcSpan msgDoc = do + putStrLn "Log hook called" + action logFlags messageClass srcSpan msgDoc diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs index bf717b26c0..29c1dab2b7 100644 --- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs +++ b/testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-} -module Hooks.Plugin (plugin) where +module Hooks.MetaPlugin (plugin) where import GHC.Types.SourceText import GHC.Plugins diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs new file mode 100644 index 0000000000..51cff77404 --- /dev/null +++ b/testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +module Hooks.PhasePlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Driver.Pipeline.Execute +import GHC.Driver.Pipeline.Phases +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let hooks = hsc_hooks hsc_env + hooks' = hooks { runPhaseHook = Just fakeRunPhaseHook } + hsc_env' = hsc_env { hsc_hooks = hooks' } + return hsc_env' + +fakeRunPhaseHook :: PhaseHook +fakeRunPhaseHook = PhaseHook $ \tPhase -> do + liftIO $ case tPhase of + T_Cpp{} -> putStrLn "Cpp hook fired" + T_Hsc{} -> putStrLn "Hsc hook fired" + T_FileArgs{} -> putStrLn "FileArgs hook fired" + _ -> pure () + runPhase tPhase diff --git a/testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal b/testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal index 3c1cf61184..b19ad6f18e 100644 --- a/testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal +++ b/testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal @@ -4,6 +4,6 @@ version: 0.1 build-type: Simple library - exposed-modules: Hooks.Plugin + exposed-modules: Hooks.MetaPlugin, Hooks.PhasePlugin, Hooks.LogPlugin build-depends: base, ghc default-language: Haskell2010 diff --git a/testsuite/tests/plugins/plugins04.stderr b/testsuite/tests/plugins/plugins04.stderr index 67922911fb..a56ed56856 100644 --- a/testsuite/tests/plugins/plugins04.stderr +++ b/testsuite/tests/plugins/plugins04.stderr @@ -1,2 +1 @@ -Module graph contains a cycle: - module ‘HomePackagePlugin’ (./HomePackagePlugin.hs) imports itself +attempting to use module ‘main:HomePackagePlugin’ (./HomePackagePlugin.hs) which is not loaded diff --git a/testsuite/tests/plugins/test-hooks-plugin.hs b/testsuite/tests/plugins/test-hooks-plugin.hs index bf324f9966..c7bfa9dbce 100644 --- a/testsuite/tests/plugins/test-hooks-plugin.hs +++ b/testsuite/tests/plugins/test-hooks-plugin.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fplugin=Hooks.Plugin #-} +{-# OPTIONS -fplugin=Hooks.MetaPlugin #-} {-# LANGUAGE TemplateHaskell #-} module Main where diff --git a/testsuite/tests/plugins/test-log-hooks-plugin.hs b/testsuite/tests/plugins/test-log-hooks-plugin.hs new file mode 100644 index 0000000000..f0308a3fe6 --- /dev/null +++ b/testsuite/tests/plugins/test-log-hooks-plugin.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure "type error" diff --git a/testsuite/tests/plugins/test-log-hooks-plugin.stderr b/testsuite/tests/plugins/test-log-hooks-plugin.stderr new file mode 100644 index 0000000000..dba4679f52 --- /dev/null +++ b/testsuite/tests/plugins/test-log-hooks-plugin.stderr @@ -0,0 +1,9 @@ +Log hook called + +test-log-hooks-plugin.hs:4:13: error: [GHC-83865] + • Couldn't match type ‘[Char]’ with ‘()’ + Expected: () + Actual: String + • In the first argument of ‘pure’, namely ‘"type error"’ + In the expression: pure "type error" + In an equation for ‘main’: main = pure "type error" diff --git a/testsuite/tests/plugins/test-phase-hooks-plugin.hs b/testsuite/tests/plugins/test-phase-hooks-plugin.hs new file mode 100644 index 0000000000..9271fad67b --- /dev/null +++ b/testsuite/tests/plugins/test-phase-hooks-plugin.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} +module Main where + +main :: IO () +main = pure () diff --git a/testsuite/tests/plugins/test-phase-hooks-plugin.stderr b/testsuite/tests/plugins/test-phase-hooks-plugin.stderr new file mode 100644 index 0000000000..ae1b36330d --- /dev/null +++ b/testsuite/tests/plugins/test-phase-hooks-plugin.stderr @@ -0,0 +1,5 @@ +FileArgs hook fired +Cpp hook fired +FileArgs hook fired +FileArgs hook fired +Hsc hook fired |