From 1c79526a0ee0060dc692478926f6d0228c853a33 Mon Sep 17 00:00:00 2001
From: Finley McIlwaine <finleymcilwaine@gmail.com>
Date: Mon, 20 Nov 2023 10:49:23 -0800
Subject: [PATCH] Late plugins
---
compiler/GHC/Core/LateCC.hs | 17 ++++-----
compiler/GHC/Driver/Main.hs | 70 ++++++++++++++++++++++------------
compiler/GHC/Driver/Plugins.hs | 10 +++++
3 files changed, 63 insertions(+), 34 deletions(-)
diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs
index efa99564cbbc..32db6c4b540e 100644
--- a/compiler/GHC/Core/LateCC.hs
+++ b/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
}
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0c7464087aa0..45df4946e04c 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/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,61 @@ 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 {-# 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" #-}
+ 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 +1849,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 +1867,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
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index ddf47c05ce48..017fdf743c50 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -89,8 +89,11 @@ 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.CostCentre
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 +160,11 @@ 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.
+
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary
@@ -260,6 +268,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 +289,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
--
GitLab