[Git][ghc/ghc][wip/plugin-init] Rework plugin initialisation points
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Jan 27 09:28:32 UTC 2023
Matthew Pickering pushed to branch wip/plugin-init at Glasgow Haskell Compiler / GHC
Commits:
7d3e5ae6 by Aaron Allen at 2023-01-27T09:28:19+00:00
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 at gmail.com>
- - - - -
16 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Runtime/Loader.hs
- ghc/Main.hs
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs
- testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs
- + testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs
- testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal
- testsuite/tests/plugins/plugins04.stderr
- testsuite/tests/plugins/test-hooks-plugin.hs
- + testsuite/tests/plugins/test-log-hooks-plugin.hs
- + testsuite/tests/plugins/test-log-hooks-plugin.stderr
- + testsuite/tests/plugins/test-phase-hooks-plugin.hs
- + testsuite/tests/plugins/test-phase-hooks-plugin.stderr
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -662,6 +662,9 @@ createBuildPlan mod_graph maybe_top_mod =
-- 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
@@ -2828,13 +2831,11 @@ label_self thread_name = do
runPipelines :: Int -> 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
- 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines
- _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines
+ 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 =
=====================================
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 ()
=====================================
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
=====================================
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,
@@ -71,6 +71,11 @@ import Unsafe.Coerce ( unsafeCoerce )
import GHC.Linker.Types
import GHC.Types.Unique.DFM
import Data.List (unzip4)
+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
=====================================
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)
@@ -256,16 +256,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
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -321,3 +321,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])
=====================================
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
=====================================
testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → 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
=====================================
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
=====================================
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
=====================================
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
=====================================
testsuite/tests/plugins/test-hooks-plugin.hs
=====================================
@@ -1,4 +1,4 @@
-{-# OPTIONS -fplugin=Hooks.Plugin #-}
+{-# OPTIONS -fplugin=Hooks.MetaPlugin #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
=====================================
testsuite/tests/plugins/test-log-hooks-plugin.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = pure "type error"
=====================================
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"
=====================================
testsuite/tests/plugins/test-phase-hooks-plugin.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE CPP #-}
+module Main where
+
+main :: IO ()
+main = pure ()
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d3e5ae66b399288afaeddabebaca99b3d0b54ea
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d3e5ae66b399288afaeddabebaca99b3d0b54ea
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230127/39f2e0a8/attachment-0001.html>
More information about the ghc-commits
mailing list