[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Late plugins
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Dec 18 10:10:39 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
1c79526a by Finley McIlwaine at 2023-12-15T12:24:40-08:00
Late plugins
- - - - -
000c3302 by Finley McIlwaine at 2023-12-15T12:24:40-08:00
withTiming on LateCCs and late plugins
- - - - -
be4551ac by Finley McIlwaine at 2023-12-15T12:24:40-08:00
add test for late plugins
- - - - -
7c29da9f by Finley McIlwaine at 2023-12-15T12:24:40-08:00
Document late plugins
- - - - -
a3b40b75 by ur4t at 2023-12-18T05:10:14-05:00
GHCi: fix improper location of ghci_history file
Fixes #24266
- - - - -
10 changed files:
- compiler/GHC/Core/LateCC.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Plugins.hs
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/extending_ghc.rst
- ghc/GHCi/UI.hs
- testsuite/tests/plugins/Makefile
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/late-plugin/LatePlugin.hs
- + testsuite/tests/plugins/test-late-plugin.hs
Changes:
=====================================
compiler/GHC/Core/LateCC.hs
=====================================
@@ -71,34 +71,32 @@ addLateCostCentresMG guts = do
let env :: Env
env = Env
{ thisModule = mg_module guts
- , ccState = newCostCentreState
, countEntries = gopt Opt_ProfCountEntries dflags
, collectCCs = False -- See Note [Collecting late cost centres]
}
- let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))
+ let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts))
}
return guts'
-addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)
+addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre, CostCentreState)
addLateCostCentresPgm dflags logger mod binds =
withTiming logger
(text "LateCC"<+>brackets (ppr mod))
- (\(a,b) -> a `seqList` (b `seq` ())) $ do
+ (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do
let env = Env
{ thisModule = mod
- , ccState = newCostCentreState
, countEntries = gopt Opt_ProfCountEntries dflags
, collectCCs = True -- See Note [Collecting late cost centres]
}
- (binds', ccs) = addLateCostCentres env binds
+ (binds', ccs, cc_state) = addLateCostCentres env binds
when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $
putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))
- return (binds', ccs)
+ return (binds', ccs, cc_state)
-addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)
+addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, S.Set CostCentre, CostCentreState)
addLateCostCentres env binds =
let (binds', state) = runState (mapM (doBind env) binds) initLateCCState
- in (binds',lcs_ccs state)
+ in (binds', lcs_ccs state, lcs_state state)
doBind :: Env -> CoreBind -> M CoreBind
@@ -161,7 +159,6 @@ addCC !env cc = do
data Env = Env
{ thisModule :: !Module
, countEntries:: !Bool
- , ccState :: !CostCentreState
, collectCCs :: !Bool
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -297,6 +297,7 @@ import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Cmm.Config (CmmConfig)
+import GHC.Types.CostCentre.State (newCostCentreState)
{- **********************************************************************
@@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts location output_filename = do
- let CgGuts{ -- This is the last use of the ModGuts in a compilation.
- -- From now on, we just use the bits we need.
- cg_module = this_mod,
+ let CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
- cg_ccs = local_ccs,
- cg_tycons = tycons,
- cg_foreign = foreign_stubs0,
- cg_foreign_files = foreign_files,
- cg_dep_pkgs = dependencies,
- cg_hpc_info = hpc_info,
- cg_spt_entries = spt_entries
+ cg_ccs = local_ccs
} = cgguts
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
- hooks = hsc_hooks hsc_env
- tmpfs = hsc_tmpfs hsc_env
- llvm_config = hsc_llvm_config hsc_env
- profile = targetProfile dflags
- data_tycons = filter isDataTyCon tycons
- -- cg_tycons includes newtypes, for the benefit of External Core,
- -- but we don't generate any code for newtypes
+
-------------------
-- Insert late cost centres if enabled.
-- If `-fprof-late-inline` is enabled we can skip this, as it will have added
-- a superset of cost centres we would add here already.
- (late_cc_binds, late_local_ccs) <-
+ (late_cc_binds, late_local_ccs, cc_state) <-
if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)
- then {-# SCC lateCC #-} do
- (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds
- return ( binds, (S.toList late_ccs `mappend` local_ccs ))
+ then
+ withTiming
+ logger
+ (text "LateCCs"<+>brackets (ppr this_mod))
+ (const ())
+ $ {-# SCC lateCC #-} do
+ (binds, late_ccs, cc_state) <- addLateCostCentresPgm dflags logger this_mod core_binds
+ return ( binds, (S.toList late_ccs `mappend` local_ccs ), cc_state)
else
- return (core_binds, local_ccs)
+ return (core_binds, local_ccs, newCostCentreState)
+
+ -------------------
+ -- Run late plugins
+ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ ( CgGuts
+ { cg_tycons = tycons,
+ cg_foreign = foreign_stubs0,
+ cg_foreign_files = foreign_files,
+ cg_dep_pkgs = dependencies,
+ cg_hpc_info = hpc_info,
+ cg_spt_entries = spt_entries,
+ cg_binds = late_binds,
+ cg_ccs = late_local_ccs'
+ }
+ , _
+ ) <-
+ {-# SCC latePlugins #-}
+ withTiming
+ logger
+ (text "LatePlugins"<+>brackets (ppr this_mod))
+ (const ()) $
+ withPlugins (hsc_plugins hsc_env)
+ (($ hsc_env) . latePlugin)
+ ( cgguts
+ { cg_binds = late_cc_binds
+ , cg_ccs = late_local_ccs
+ }
+ , cc_state
+ )
+
+ let
+ hooks = hsc_hooks hsc_env
+ tmpfs = hsc_tmpfs hsc_env
+ llvm_config = hsc_llvm_config hsc_env
+ profile = targetProfile dflags
+ data_tycons = filter isDataTyCon tycons
+ -- cg_tycons includes newtypes, for the benefit of External Core,
+ -- but we don't generate any code for newtypes
@@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
(hsc_logger hsc_env)
cp_cfg
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
- this_mod location late_cc_binds data_tycons
+ this_mod location late_binds data_tycons
----------------- Convert to STG ------------------
(stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
@@ -1845,7 +1876,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
let cost_centre_info =
- (late_local_ccs ++ caf_ccs, caf_cc_stacks)
+ (late_local_ccs' ++ caf_ccs, caf_cc_stacks)
platform = targetPlatform dflags
prof_init
| sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -58,6 +58,10 @@ module GHC.Driver.Plugins (
-- | hole fit plugins allow plugins to change the behavior of valid hole
-- fit suggestions
, HoleFitPluginR
+ -- ** Late plugins
+ -- | Late plugins can access and modify the core of a module after
+ -- optimizations have been applied and after interface creation.
+ , LatePlugin
-- * Internal
, PluginWithArgs(..), pluginsWithArgs, pluginRecompile'
@@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo )
import GHC.Hs
import GHC.Types.Error (Messages)
import GHC.Linker.Types
+import GHC.Types.CostCentre.State
import GHC.Types.Unique.DFM
+import GHC.Unit.Module.ModGuts (CgGuts)
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -157,6 +163,13 @@ data Plugin = Plugin {
--
-- @since 8.10.1
+ , latePlugin :: LatePlugin
+ -- ^ A plugin that runs after interface creation and after late cost centre
+ -- insertion. Useful for transformations that should not impact interfaces
+ -- or optimization at all.
+ --
+ -- @since 9.10.1
+
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary
@@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin
type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin
type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
+type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
@@ -280,6 +294,7 @@ defaultPlugin = Plugin {
, defaultingPlugin = const Nothing
, holeFitPlugin = const Nothing
, driverPlugin = const return
+ , latePlugin = \_ -> const return
, pluginRecompile = impurePlugin
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -126,6 +126,9 @@ Compiler
- The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`,
as ``forall`` is no longer parsed as an identifier.
+- Late plugins have been added. These are plugins which can access and/or modify
+ the core of a module after optimization and after interface creation. See :ghc-ticket:`24254`.
+
GHCi
~~~~
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -510,6 +510,58 @@ in a module it compiles:
return bndr
printBind _ bndr = return bndr
+.. _late-plugins:
+
+Late Plugins
+^^^^^^^^^^^^
+
+If the ``CoreProgram`` of a module is modified in a normal core plugin, the
+modified bindings can end up in unfoldings the interface file for the module.
+This may be undesireable, as the plugin could make changes which affect inlining
+or optimization.
+
+Late plugins can be used to avoid introducing such changes into the interface
+file. Late plugins are a bit different from typical core plugins:
+
+1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed
+ the ``HscEnv`` and they run in ``IO``.
+2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted
+ form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in
+ the ``CgGuts`` given to a late plugin will already be fully optimized.
+3. They must maintain a ``CostCentreState`` and track any cost centres they
+ introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is
+ because the automatic collection of cost centres happens before the late
+ plugin stage. If a late plugin does not introduce any cost centres, it may
+ simply return the given cost centre state.
+
+Here is a very simply example of a late plugin that changes the value of a
+binding in a module. If it finds a non-recursive top-level binding named
+``testBinding`` with type ``Int``, it will change its value to the ``Int``
+expression ``111111``.
+
+::
+
+ plugin :: Plugin
+ plugin = defaultPlugin { latePlugin = lateP }
+
+ lateP :: LatePlugin
+ lateP _ _ (cg_guts, cc_state) = do
+ binds' <- editCoreBinding (cg_binds cg_guts)
+ return (cg_guts { cg_binds = binds' }, cc_state)
+
+ editCoreBinding :: CoreProgram -> IO CoreProgram
+ editCoreBinding pgm = pure . go
+ where
+ go :: [CoreBind] -> [CoreBind]
+ go (b@(NonRec v e) : bs)
+ | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy =
+ NonRec v (mkUncheckedIntExpr 111111) : bs
+ go (b:bs) = b : go bs
+ go [] = []
+
+Since this is a late plugin, the changed binding value will not end up in the
+interface file.
+
.. _getting-annotations:
Using Annotations
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -639,30 +639,27 @@ ghciLogAction lastErrLocations old_log_action
_ -> return ()
_ -> return ()
--- | Takes a file name and prefixes it with the appropriate
--- GHC appdir.
--- Uses ~/.ghc (getAppUserDataDirectory) if it exists
--- If it doesn't, then it uses $XDG_DATA_HOME/ghc
--- Earlier we always used to use ~/.ghc, but we want
--- to gradually move to $XDG_DATA_HOME to respect the XDG specification
---
--- As a migration strategy, we will only create new directories in
--- the appropriate XDG location. However, we will use the old directory
--- if it already exists.
-getAppDataFile :: FilePath -> IO (Maybe FilePath)
-getAppDataFile file = do
- let new_path = tryIO (getXdgDirectory XdgConfig "ghc") >>= \case
- Left _ -> pure Nothing
- Right dir -> flip catchIO (const $ return Nothing) $ do
- createDirectoryIfMissing False dir
- pure $ Just $ dir </> file
-
- e_old_path <- tryIO (getAppUserDataDirectory "ghc")
- case e_old_path of
- Right old_path -> doesDirectoryExist old_path >>= \case
- True -> pure $ Just $ old_path </> file
- False -> new_path
- Left _ -> new_path
+-- | Takes a file name and prefixes it with the appropriate GHC appdir.
+-- ~/.ghc (getAppUserDataDirectory) is used if it exists, or XDG directories
+-- are used to respect the XDG specification.
+-- As a migration strategy, currently we will only create new directories in
+-- the appropriate XDG location.
+getAppDataFile :: XdgDirectory -> FilePath -> IO (Maybe FilePath)
+getAppDataFile xdgDir file = do
+ xdgAppDir <-
+ tryIO (getXdgDirectory xdgDir "ghc") >>= \case
+ Left _ -> pure Nothing
+ Right dir -> flip catchIO (const $ pure Nothing) $ do
+ createDirectoryIfMissing False dir
+ pure $ Just dir
+ appDir <-
+ tryIO (getAppUserDataDirectory "ghc") >>= \case
+ Right dir ->
+ doesDirectoryExist dir >>= \case
+ True -> pure $ Just dir
+ False -> pure xdgAppDir
+ Left _ -> pure xdgAppDir
+ pure $ appDir >>= \dir -> Just $ dir </> file
runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
@@ -670,13 +667,12 @@ runGHCi paths maybe_exprs = do
let
ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
- app_user_dir = liftIO $ getAppDataFile "ghci.conf"
+ appDataCfg = liftIO $ getAppDataFile XdgConfig "ghci.conf"
- home_dir = do
- either_dir <- liftIO $ tryIO (getEnv "HOME")
- case either_dir of
- Right home -> return (Just (home </> ".ghci"))
- _ -> return Nothing
+ homeCfg = do
+ liftIO $ tryIO (getEnv "HOME") >>= \case
+ Right home -> pure $ Just $ home </> ".ghci"
+ _ -> pure Nothing
canonicalizePath' :: FilePath -> IO (Maybe FilePath)
canonicalizePath' fp = liftM Just (canonicalizePath fp)
@@ -710,7 +706,7 @@ runGHCi paths maybe_exprs = do
then pure []
else do
userCfgs <- do
- paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
+ paths <- catMaybes <$> sequence [ appDataCfg, homeCfg ]
checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths
@@ -797,12 +793,12 @@ runGHCiInput f = do
dflags <- getDynFlags
let ghciHistory = gopt Opt_GhciHistory dflags
let localGhciHistory = gopt Opt_LocalGhciHistory dflags
- currentDirectory <- liftIO $ getCurrentDirectory
+ currentDirectory <- liftIO getCurrentDirectory
histFile <- case (ghciHistory, localGhciHistory) of
- (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
- (True, _) -> liftIO $ getAppDataFile "ghci_history"
- _ -> return Nothing
+ (True, True) -> pure $ Just $ currentDirectory </> ".ghci_history"
+ (True, _) -> liftIO $ getAppDataFile XdgData "ghci_history"
+ _ -> pure Nothing
runInputT
(setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
=====================================
testsuite/tests/plugins/Makefile
=====================================
@@ -224,3 +224,13 @@ plugins-external:
cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin)
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs
./plugins-external
+
+# Runs a plugin that is both a core plugin and a late plugin, then makes sure
+# only the changes from the core plugin end up in the interface files.
+test-late-plugin:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs
+ SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \
+ ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \
+ ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \
+ echo "$$ContainsLateBinding" ; \
+ [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ]
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -358,3 +358,8 @@ test('test-log-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])
+
+test('test-late-plugin',
+ [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout],
+ makefile_test,
+ [])
=====================================
testsuite/tests/plugins/late-plugin/LatePlugin.hs
=====================================
@@ -0,0 +1,50 @@
+module LatePlugin where
+
+import Data.Bool
+import GHC.Core
+import GHC.Core.TyCo.Compare
+import GHC.Driver.Monad
+import GHC.Plugins
+import GHC.Types.Avail
+import GHC.Types.Var
+import GHC.Types.Id
+import System.IO
+
+-- | Both a core plugin and a late plugin. The Core plugin edits the binding in
+-- the test file (testBinding) to be the integer "111111". The late plugin then
+-- edits the binding to be the integer "222222". Then we make sure the "222222"
+-- did not make it in the interface file and the "111111" did.
+plugin :: Plugin
+plugin =
+ defaultPlugin
+ { installCoreToDos = earlyP
+ , latePlugin = lateP
+ }
+
+earlyP :: CorePlugin
+earlyP _ todos = do
+ return
+ . (: todos)
+ $ CoreDoPluginPass "earlyP"
+ $ \mgs -> liftIO $ do
+ binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs)
+ return mgs { mg_binds = binds' }
+
+lateP :: LatePlugin
+lateP _ opts (cg_guts, cc_state) = do
+ binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts)
+ return (cg_guts { cg_binds = binds' }, cc_state)
+
+editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram
+editCoreBinding early modName pgm = do
+ putStrLn $
+ bool "late " "early " early ++ "plugin running on module " ++
+ moduleNameString modName
+ pure $ go pgm
+ where
+ go :: [CoreBind] -> [CoreBind]
+ go (b@(NonRec v e) : bs)
+ | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy =
+ NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs
+ go (b:bs) = b : go bs
+ go [] = []
=====================================
testsuite/tests/plugins/test-late-plugin.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -fplugin=LatePlugin #-}
+
+module TestLatePlugin (testBinding) where
+
+import GHC.Exts
+
+-- This file is edited by a core plugin at the beginning of the core pipeline so
+-- that the value of testBinding becomes 111111. Then, a late plugin edits the
+-- binding to set testBinding to 222222. The test then checks that the early
+-- binding value is what makes it into the interface file, just to be sure that
+-- changes from late plugins do not end up in interface files.
+
+testBinding :: Int
+testBinding = -1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88346e1951317ac6f712ea7bb50424e835c52195...a3b40b75a2b6bb57cec10b0cf931a896079f17fb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88346e1951317ac6f712ea7bb50424e835c52195...a3b40b75a2b6bb57cec10b0cf931a896079f17fb
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/20231218/ed3bcf65/attachment-0001.html>
More information about the ghc-commits
mailing list