[Git][ghc/ghc][wip/add-ddump-specialisations] Late plugins
Finley McIlwaine (@FinleyMcIlwaine)
gitlab at gitlab.haskell.org
Mon Nov 20 18:49:34 UTC 2023
Finley McIlwaine pushed to branch wip/add-ddump-specialisations at Glasgow Haskell Compiler / GHC
Commits:
4bec35fb by Finley McIlwaine at 2023-11-20T10:49:23-08:00
Late plugins
- - - - -
3 changed files:
- compiler/GHC/Core/LateCC.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Plugins.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
=====================================
@@ -289,6 +289,7 @@ import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Cmm.Config (CmmConfig)
+import GHC.Types.CostCentre.State (newCostCentreState)
{- **********************************************************************
@@ -1794,40 +1795,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
@@ -1840,7 +1862,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, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
@@ -1856,7 +1878,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
(myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
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
=====================================
@@ -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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bec35fb31bd4858a3a5fa3c0aff1a1bc59ef330
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bec35fb31bd4858a3a5fa3c0aff1a1bc59ef330
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/20231120/fa3fd23c/attachment-0001.html>
More information about the ghc-commits
mailing list