From f9f17b68b144a7ecb91395c1e987bbf4f91c0180 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 15 Jul 2022 17:47:32 +0100 Subject: Fire RULES in the Specialiser The Specialiser has, for some time, fires class-op RULES in the specialiser itself: see Note [Specialisation modulo dictionary selectors] This MR beefs it up a bit, so that it fires /all/ RULES in the specialiser, not just class-op rules. See Note [Fire rules in the specialiser] The result is a bit more specialisation; see test simplCore/should_compile/T21851_2 This pushed me into a bit of refactoring. I made a new data types GHC.Core.Rules.RuleEnv, which combines - the several source of rules (local, home-package, external) - the orphan-module dependencies in a single record for `getRules` to consult. That drove a bunch of follow-on refactoring, including allowing me to remove cr_visible_orphan_mods from the CoreReader data type. I moved some of the RuleBase/RuleEnv stuff into GHC.Core.Rule. The reorganisation in the Simplifier improve compile times a bit (geom mean -0.1%), but T9961 is an outlier Metric Decrease: T9961 --- compiler/GHC/Core/InstEnv.hs | 4 +- compiler/GHC/Core/Opt/Monad.hs | 26 ++-- compiler/GHC/Core/Opt/Pipeline.hs | 23 ++-- compiler/GHC/Core/Opt/Simplify.hs | 61 +++++---- compiler/GHC/Core/Opt/Simplify/Monad.hs | 2 +- compiler/GHC/Core/Opt/Simplify/Utils.hs | 2 +- compiler/GHC/Core/Opt/Specialise.hs | 231 +++++++++++++++++++++----------- compiler/GHC/Core/Rules.hs | 155 ++++++++++++++++----- 8 files changed, 335 insertions(+), 169 deletions(-) (limited to 'compiler/GHC/Core') diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index af2045caac..9b9fd995a2 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -323,7 +323,9 @@ mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan {- Note [When exactly is an instance decl an orphan?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +(See GHC.Iface.Make.instanceToIfaceInst, which implements this.) +See Note [Orphans] in GHC.Core + Roughly speaking, an instance is an orphan if its head (after the =>) mentions nothing defined in this module. diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index e06d4ed06d..0f87a8aeb6 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -19,10 +19,10 @@ module GHC.Core.Opt.Monad ( -- ** Reading from the monad getHscEnv, getModule, - getRuleBase, getExternalRuleBase, + initRuleEnv, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, getInteractiveContext, - getVisibleOrphanMods, getUniqMask, + getUniqMask, getPrintUnqualified, getSrcSpanM, -- ** Writing to the monad @@ -45,7 +45,7 @@ import GHC.Prelude hiding ( read ) import GHC.Driver.Session import GHC.Driver.Env -import GHC.Core +import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) import GHC.Types.Annotations @@ -114,12 +114,11 @@ pprFloatOutSwitches sw data CoreReader = CoreReader { cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, + cr_rule_base :: RuleBase, -- Home package table rules cr_module :: Module, cr_print_unqual :: PrintUnqualified, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet, cr_uniq_mask :: !Char -- Mask for creating unique values } @@ -181,19 +180,17 @@ runCoreM :: HscEnv -> RuleBase -> Char -- ^ Mask -> Module - -> ModuleSet -> PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m +runCoreM hsc_env rule_base mask mod print_unqual loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_visible_orphan_mods = orph_imps, cr_print_unqual = print_unqual, cr_loc = loc, cr_uniq_mask = mask @@ -245,15 +242,18 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base +getHomeRuleBase :: CoreM RuleBase +getHomeRuleBase = read cr_rule_base + +initRuleEnv :: ModGuts -> CoreM RuleEnv +initRuleEnv guts + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; return (mkRuleEnv guts eps_rules hpt_rules) } getExternalRuleBase :: CoreM RuleBase getExternalRuleBase = eps_rule_base <$> get_eps -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods - getPrintUnqualified :: CoreM PrintUnqualified getPrintUnqualified = read cr_print_unqual diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 214e7620c2..c7834a0b31 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -22,7 +22,7 @@ import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) -import GHC.Core.Rules ( mkRuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) @@ -53,9 +53,7 @@ import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Unit.Module.Env import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.Deps import GHC.Types.Id.Info import GHC.Types.Basic @@ -78,14 +76,12 @@ import GHC.Unit.Module core2core :: HscEnv -> ModGuts -> IO ModGuts core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc - , mg_deps = deps , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars - orph_mods = mkModuleSet (mod : dep_orphs deps) uniq_mask = 's' - ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - orph_mods print_unqual loc $ + print_unqual loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') installCoreToDos @@ -121,7 +117,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod -} getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo] -getCoreToDo dflags rule_base extra_vars +-- This function builds the pipeline of optimisations +getCoreToDo dflags hpt_rule_base extra_vars = flatten_todos core_todo where phases = simplPhases dflags @@ -176,7 +173,7 @@ getCoreToDo dflags rule_base extra_vars ---------------------------- run_simplifier mode iter - = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode rule_base + = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode hpt_rule_base simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase @@ -573,11 +570,9 @@ ruleCheckPass current_phase pat guts = do logger <- getLogger withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do - rb <- getRuleBase - vis_orphs <- getVisibleOrphanMods - let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn - ++ (mg_rules guts) - let ropts = initRuleOpts dflags + rule_env <- initRuleEnv guts + let rule_fn fn = getRules rule_env fn + ropts = initRuleOpts dflags liftIO $ logDumpMsg logger "Rule check" (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e473cd24af..0c8ec92f6c 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -10,7 +10,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Core -import GHC.Core.Rules ( extendRuleBaseList, extendRuleEnv, addRuleInfo ) +import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) @@ -31,7 +31,6 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Unit.Env ( UnitEnv, ueEPS ) import GHC.Unit.External import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.Deps import GHC.Types.Id import GHC.Types.Id.Info @@ -81,7 +80,7 @@ simplifyExpr logger euc opts expr simpl_env = mkSimplEnv (se_mode opts) fam_envs top_env_cfg = se_top_env_cfg opts read_eps_rules = eps_rule_base <$> eucEPS euc - read_ruleenv = extendRuleEnv emptyRuleEnv <$> read_eps_rules + read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules ; let sz = exprSize expr @@ -132,11 +131,11 @@ simplExprGently env expr = do -- The values of this datatype are /only/ driven by the demands of that function. data SimplifyOpts = SimplifyOpts { so_dump_core_sizes :: !Bool - , so_iterations :: !Int - , so_mode :: !SimplMode + , so_iterations :: !Int + , so_mode :: !SimplMode , so_pass_result_cfg :: !(Maybe LintPassResultConfig) - , so_rule_base :: !RuleBase - , so_top_env_cfg :: !TopEnvConfig + , so_hpt_rules :: !RuleBase + , so_top_env_cfg :: !TopEnvConfig } simplifyPgm :: Logger @@ -148,11 +147,10 @@ simplifyPgm :: Logger simplifyPgm logger unit_env opts guts@(ModGuts { mg_module = this_mod , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules + , mg_binds = binds, mg_rules = local_rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration 1 [] binds rules + <- do_iteration 1 [] binds local_rules ; when (logHasDumpFlag logger Opt_D_verbose_core2core && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ @@ -169,7 +167,6 @@ simplifyPgm logger unit_env opts dump_core_sizes = so_dump_core_sizes opts mode = so_mode opts max_iterations = so_iterations opts - hpt_rule_base = so_rule_base opts top_env_cfg = so_top_env_cfg opts print_unqual = mkPrintUnqualified unit_env rdr_env active_rule = activeRule mode @@ -178,13 +175,18 @@ simplifyPgm logger unit_env opts -- the old bindings are retained until the end of all simplifier iterations !guts_no_binds = guts { mg_binds = [], mg_rules = [] } + hpt_rule_env :: RuleEnv + hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts) + -- emptyRuleBase: no EPS rules yet; we will update + -- them on each iteration to pick up the most up to date set + do_iteration :: Int -- Counts iterations -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules + -> CoreProgram -- Bindings + -> [CoreRule] -- Local rules for imported Ids -> IO (String, Int, SimplCount, ModGuts) - do_iteration iteration_no counts_so_far binds rules + do_iteration iteration_no counts_so_far binds local_rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations @@ -200,7 +202,7 @@ simplifyPgm logger unit_env opts -- number of iterations we actually completed return ( "Simplifier baled out", iteration_no - 1 , totalise counts_so_far - , guts_no_binds { mg_binds = binds, mg_rules = rules } ) + , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. @@ -209,8 +211,8 @@ simplifyPgm logger unit_env opts = do { -- Occurrence analysis let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule rules - binds + occurAnalysePgm this_mod active_unf active_rule + local_rules binds } ; Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore @@ -221,24 +223,29 @@ simplifyPgm logger unit_env opts -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings - -- Hence just before attempting to match rules we read on the EPS - -- value and then combine it when the existing rule base. + -- Hence just before attempting to match a rule we read the EPS + -- value (via read_rule_env) and then combine it with the existing rule base. -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. - eps <- ueEPS unit_env ; - let { -- Forcing this value to avoid unnessecary allocations. + eps <- ueEPS unit_env ; + let { -- base_rule_env contains + -- (a) home package rules, fixed across all iterations + -- (b) local rules (substituted) from `local_rules` arg to do_iteration + -- Forcing base_rule_env to avoid unnecessary allocations. -- Not doing so results in +25.6% allocations of LargeRecord. - ; !rule_base = extendRuleBaseList hpt_rule_base rules - ; vis_orphs = this_mod : dep_orphs deps - ; base_ruleenv = mkRuleEnv rule_base vis_orphs + ; !base_rule_env = updLocalRules hpt_rule_env local_rules + + ; read_eps_rules :: IO PackageRuleBase ; read_eps_rules = eps_rule_base <$> ueEPS unit_env - ; read_ruleenv = extendRuleEnv base_ruleenv <$> read_eps_rules + + ; read_rule_env :: IO RuleEnv + ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) ; simpl_env = mkSimplEnv mode fam_envs } ; -- Simplify the program ((binds1, rules1), counts1) <- - initSmpl logger read_ruleenv top_env_cfg sz $ + initSmpl logger read_rule_env top_env_cfg sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -246,7 +253,7 @@ simplifyPgm logger unit_env opts -- for imported Ids. Eg RULE map my_f = blah -- If we have a substitution my_f :-> other_f, we'd better -- apply it to the rule to, or it'll never match - ; rules1 <- simplImpRules env1 rules + ; rules1 <- simplImpRules env1 local_rules ; return (getTopFloatBinds floats, rules1) } ; diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index b20bf0a8ad..d67593d1bf 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -27,8 +27,8 @@ import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) -import GHC.Core ( RuleEnv(..) ) import GHC.Core.Opt.Stats +import GHC.Core.Rules import GHC.Core.Utils ( mkLamTypes ) import GHC.Types.Unique.Supply import GHC.Driver.Flags diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 88e6b409d5..31a0130969 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -53,7 +53,7 @@ import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) import GHC.Core.FVs import GHC.Core.Utils -import GHC.Core.Rules( getRules ) +import GHC.Core.Rules( RuleEnv, getRules ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 22c3e50f73..99230b3a3b 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -17,6 +17,7 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) import GHC.Core.Multiplicity +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad @@ -636,9 +637,11 @@ Hence, the invariant is this: -- | Specialise calls to type-class overloaded functions occurring in a program. specProgram :: ModGuts -> CoreM ModGuts specProgram guts@(ModGuts { mg_module = this_mod - , mg_rules = local_rules - , mg_binds = binds }) - = do { dflags <- getDynFlags + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + ; rule_env <- initRuleEnv guts + -- See Note [Fire rules in the specialiser] -- We need to start with a Subst that knows all the things -- that are in scope, so that the substitution engine doesn't @@ -650,6 +653,7 @@ specProgram guts@(ModGuts { mg_module = this_mod -- mkInScopeSetList $ -- bindersOfBinds binds , se_module = this_mod + , se_rules = rule_env , se_dflags = dflags } go [] = return ([], emptyUDs) @@ -660,7 +664,7 @@ specProgram guts@(ModGuts { mg_module = this_mod -- Specialise the bindings of this module ; (binds', uds) <- runSpecM (go binds) - ; (spec_rules, spec_binds) <- specImports top_env local_rules uds + ; (spec_rules, spec_binds) <- specImports top_env uds ; return (guts { mg_binds = spec_binds ++ binds' , mg_rules = spec_rules ++ local_rules }) } @@ -725,21 +729,15 @@ specialisation (see canSpecImport): -} specImports :: SpecEnv - -> [CoreRule] -> UsageDetails -> CoreM ([CoreRule], [CoreBind]) -specImports top_env local_rules - (MkUD { ud_binds = dict_binds, ud_calls = calls }) +specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env) -- See Note [Disabling cross-module specialisation] = return ([], wrapDictBinds dict_binds []) | otherwise - = do { hpt_rules <- getRuleBase - ; let rule_base = extendRuleBaseList hpt_rules local_rules - - ; (spec_rules, spec_binds) <- spec_imports top_env [] rule_base - dict_binds calls + = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls -- Don't forget to wrap the specialized bindings with -- bindings for the needed dictionaries. @@ -757,89 +755,91 @@ specImports top_env local_rules spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls -- See Note [Avoiding loops in specImports] -> CallDetails -- Calls for imported things - -> CoreM ( [CoreRule] -- New rules + -> CoreM ( SpecEnv -- Env contains the new rules + , [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -spec_imports top_env callers rule_base dict_binds calls +spec_imports env callers dict_binds calls = do { let import_calls = dVarEnvElts calls -- ; debugTraceMsg (text "specImports {" <+> -- vcat [ text "calls:" <+> ppr import_calls -- , text "dict_binds:" <+> ppr dict_binds ]) - ; (rules, spec_binds) <- go rule_base import_calls + ; (env, rules, spec_binds) <- go env import_calls -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) - ; return (rules, spec_binds) } + ; return (env, rules, spec_binds) } where - go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) - go _ [] = return ([], []) - go rb (cis : other_calls) + go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind]) + go env [] = return (env, [], []) + go env (cis : other_calls) = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) - ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis + ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis ; -- debugTraceMsg (text "specImport }" <+> ppr cis) - ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls - ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + ; (env, rules2, spec_binds2) <- go env other_calls + ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) } spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] - -> RuleBase -- Rules from this module -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls -- See Note [Avoiding loops in specImports] -> CallInfoSet -- Imported function and calls for it - -> CoreM ( [CoreRule] -- New rules + -> CoreM ( SpecEnv + , [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -spec_import top_env callers rb dict_binds cis@(CIS fn _) +spec_import env callers dict_binds cis@(CIS fn _) | isIn "specImport" fn callers - = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function + = return (env, [], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function | null good_calls - = return ([], []) + = return (env, [], []) | Just rhs <- canSpecImport dflags fn = do { -- Get rules from the external package state -- We keep doing this in case we "page-fault in" -- more rules as we go along - ; external_rule_base <- getExternalRuleBase - ; vis_orphs <- getVisibleOrphanMods - ; let rules_for_fn = getRules (RuleEnv [rb, external_rule_base] vis_orphs) fn + ; eps_rules <- getExternalRuleBase + ; let rule_env = se_rules env `updExternalPackageRules` eps_rules - ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) +-- ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls +-- , ppr (getRules rule_env fn), ppr rhs]) ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) - <- runSpecM $ specCalls True top_env dict_binds - rules_for_fn good_calls fn rhs + <- runSpecM $ specCalls True env dict_binds + (getRules rule_env fn) good_calls fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later -- See Note [Glom the bindings if imported functions are specialised] + new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs + new_env = env { se_rules = rule_env `addLocalRules` rules1 + , se_subst = new_subst } + -- Now specialise any cascaded calls - ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) - ; (rules2, spec_binds2) <- spec_imports top_env - (fn:callers) - (extendRuleBaseList rb rules1) - (dict_binds `thenFDBs` dict_binds1) - new_calls +-- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) + ; (env, rules2, spec_binds2) + <- spec_imports new_env (fn:callers) + (dict_binds `thenFDBs` dict_binds1) + new_calls ; let final_binds = wrapDictBinds dict_binds1 $ spec_binds2 ++ spec_binds1 - ; return (rules2 ++ rules1, final_binds) } + ; return (env, rules2 ++ rules1, final_binds) } | otherwise = do { tryWarnMissingSpecs dflags callers fn good_calls - ; return ([], [])} + ; return (env, [], [])} where - dflags = se_dflags top_env + dflags = se_dflags env good_calls = filterCalls cis dict_binds -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn -- See Note [Avoiding loops in specImports] @@ -1134,6 +1134,7 @@ data SpecEnv -- the RHS of specialised bindings (no type-let!) , se_module :: Module + , se_rules :: RuleEnv -- From the home package and this module , se_dflags :: DynFlags } @@ -1172,8 +1173,8 @@ specExpr env expr@(App {}) ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args -- Some dicts may have floated out of args_in; - -- they should be in scope for rewriteClassOps (#21689) - (fun_in', args_out') = rewriteClassOps env_args fun_in args_out + -- they should be in scope for fireRewriteRules (#21689) + (fun_in', args_out') = fireRewriteRules env_args fun_in args_out ; (fun_out', uds_fun) <- specExpr env fun_in' ; let uds_call = mkCallUDs env fun_out' args_out' ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } @@ -1208,17 +1209,19 @@ specExpr env (Let bind body) ; return (foldr Let body' binds', uds) } -- See Note [Specialisation modulo dictionary selectors] --- and Note [ClassOp/DFun selection] -rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) -rewriteClassOps env (Var f) args - | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt` - , Just (rule, expr) <- -- pprTrace "rewriteClassOps" (ppr f $$ ppr args $$ ppr (se_subst env)) $ - specLookupRule env f args (idCoreRules f) - , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] --- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True - , (fun, args) <- collectArgs expr - = rewriteClassOps env fun (args++rest_args) -rewriteClassOps _ fun args = (fun, args) +-- Note [ClassOp/DFun selection] +-- Note [Fire rules in the specialiser] +fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules env (Var f) args + | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f) + , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] + zapped_subst = Core.zapSubst (se_subst env) + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + -- simplOptExpr needed because lookupRule returns + -- (\x y. rhs) arg1 arg2 + , (fun, args) <- collectArgs expr' + = fireRewriteRules env fun (args++rest_args) +fireRewriteRules _ fun args = (fun, args) -------------- specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) @@ -1324,7 +1327,67 @@ specCase env scrut case_bndr alts where (env_rhs, args') = substBndrs env_alt args -{- +{- Note [Fire rules in the specialiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#21851) + + module A where + f :: Num b => b -> (b, b) + f x = (x + 1, snd (f x)) + {-# SPECIALIZE f :: Int -> (Int, Int) #-} + + module B (g') where + import A + + g :: Num a => a -> a + g x = fst (f x) + {-# NOINLINE[99] g #-} + + h :: Int -> Int + h = g + +Note that `f` has the CPR property, and so will worker/wrapper. + +The call to `g` in `h` will make us specialise `g @Int`. And the specialised +version of `g` will contain the call `f @Int`; but in the subsequent run of +the Simplifier, there will be a competition between: +* The user-supplied SPECIALISE rule for `f` +* The inlining of the wrapper for `f` +In fact, the latter wins -- see Note [Rewrite rules and inlining] in +GHC.Core.Opt.Simplify.Iteration. However, it a bit fragile. + +Moreover consider (test T21851_2): + + module A + f :: (Ord a, Show b) => a -> b -> blah + {-# RULE forall b. f @Int @b = wombat #-} + + wombat :: Show b => Int -> b -> blah + wombat = blah + + module B + import A + g :: forall a. Ord a => blah + g @a = ...g...f @a @Char.... + + h = ....g @Int.... + +Now, in module B, GHC will specialise `g @Int`, which will lead to a +call `f @Int @Char`. If we immediately (in the specialiser) rewrite +that to `womabat @Char`, we have a chance to specialise `wombat`. + +Conclusion: it's treat if the Specialiser fires RULEs itself. +It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is +making sure that we have a reasonably up to date EPS rule base. Currently +we load it up just once, in `initRuleEnv`, called at the beginning of +`specProgram`. + +NB: you might wonder if running rules in the specialiser (this Note) +renders Note [Rewrite rules and inlining] in the Simplifier redundant. +That is, if we run rules in the specialiser, does it matter if we make +rules "win" over inlining in the Simplifier? Yes, it does! See the +discussion in #21851. + Note [Floating dictionaries out of cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1415,13 +1478,12 @@ specBind top_lvl env (NonRec fn rhs) do_body final_binds :: [DictBind] -- See Note [From non-recursive to recursive] - final_binds - | not (isNilOL dump_dbs) - , not (null spec_defns) - = [recWithDumpedDicts pairs dump_dbs] - | otherwise - = [mkDB $ NonRec b r | (b,r) <- pairs] - ++ fromOL dump_dbs + final_binds | not (isNilOL dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ fromOL dump_dbs ; if float_all then -- Rather than discard the calls mentioning the bound variables @@ -1553,8 +1615,10 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions - = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me) + = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn)) "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $ + -- isClassOpId: class-op Ids never inline; we specialise them + -- through fireRewriteRules. So don't complain about missed opportunities -- Note [Specialisation shape] -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) @@ -1581,9 +1645,13 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool already_covered env new_rules args -- Note [Specialisations already covered] - = isJust (specLookupRule env fn args (new_rules ++ existing_rules)) - -- NB: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) + = isJust (specLookupRule env fn args (beginPhase inl_act) + (new_rules ++ existing_rules)) + -- Rules: we look both in the new_rules (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + -- inl_act: is the activation we are going to put in the new SPEC + -- rule; so we want to see if it is covered by another rule with + -- that same activation. ---------------------------------------------------------- -- Specialise to one particular call pattern @@ -1708,13 +1776,16 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs -- Convenience function for invoking lookupRule from Specialise -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] -specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -specLookupRule env fn args rules - = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules +specLookupRule :: SpecEnv -> Id -> [CoreExpr] + -> CompilerPhase -- Look up rules as if we were in this phase + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +specLookupRule env fn args phase rules + = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules where - dflags = se_dflags env - in_scope = getSubstInScope (se_subst env) - ropts = initRuleOpts dflags + dflags = se_dflags env + in_scope = getSubstInScope (se_subst env) + ropts = initRuleOpts dflags + is_active = isActive phase {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1913,10 +1984,10 @@ We want to specialise this! How? By doing the method-selection rewrite in the Specialiser. Hence 1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the - head of the application, repeatedly, via 'rewriteClassOps'. + head of the application, repeatedly, via 'fireRewriteRules'. 2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding - in 'rewriteClassOps' to do the ClassOp/DFun rewrite. + in 'fireRewriteRules' to do the ClassOp/DFun rewrite. NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able to look into the RHS of `$dC` to see the DFun. diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 428baa348e..d9bd0a912c 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -12,8 +12,10 @@ module GHC.Core.Rules ( lookupRule, -- ** RuleBase, RuleEnv + RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, + updExternalPackageRules, addLocalRules, updLocalRules, emptyRuleBase, mkRuleBase, extendRuleBaseList, - pprRuleBase, extendRuleEnv, + pprRuleBase, -- ** Checking rule applications ruleCheckProgram, @@ -22,6 +24,8 @@ module GHC.Core.Rules ( extendRuleInfo, addRuleInfo, addIdSpecialisations, + -- ** RuleBase and RuleEnv + -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, @@ -34,6 +38,8 @@ import GHC.Prelude import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env +import GHC.Unit.Module.ModGuts( ModGuts(..) ) +import GHC.Unit.Module.Deps( Dependencies(..) ) import GHC.Driver.Session( DynFlags ) import GHC.Driver.Ppr( showSDoc ) @@ -135,7 +141,7 @@ Note [Overall plumbing for rules] * At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we - generate a RuleBase for (c) by combing rules from all the modules + generate a RuleBase for (c) by combining rules from all the modules "below" us. That's why we can't just select the home-package RuleBase from HscEnv. @@ -339,12 +345,106 @@ addIdSpecialisations id rules rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +{- +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +-- See Note [Orphans] in GHC.Core +data RuleEnv + = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module + , re_home_rules :: !RuleBase -- Rule from the home package + -- (excl this module) + , re_eps_rules :: !RuleBase -- Rules from other packages + -- see Note [External package rules] + , re_visible_orphs :: !ModuleSet + } + +mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv +mkRuleEnv (ModGuts { mg_module = this_mod + , mg_deps = deps + , mg_rules = local_rules }) + eps_rules hpt_rules + = RuleEnv { re_local_rules = mkRuleBase local_rules + , re_home_rules = hpt_rules + , re_eps_rules = eps_rules + , re_visible_orphs = mkModuleSet vis_orphs } + where + vis_orphs = this_mod : dep_orphs deps + +updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv +-- Completely over-ride the external rules in RuleEnv +updExternalPackageRules rule_env eps_rules + = rule_env { re_eps_rules = eps_rules } + +updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Completely over-ride the local rules in RuleEnv +updLocalRules rule_env local_rules + = rule_env { re_local_rules = mkRuleBase local_rules } + +addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Add new local rules +addLocalRules rule_env rules + = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv + , re_home_rules = emptyNameEnv + , re_eps_rules = emptyNameEnv + , re_visible_orphs = emptyModuleSet } + getRules :: RuleEnv -> Id -> [CoreRule] +-- Given a RuleEnv and an Id, find the visible rules for that Id -- See Note [Where rules are found] -getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn - = idCoreRules fn ++ concatMap imp_rules rule_base +getRules (RuleEnv { re_local_rules = local_rules + , re_home_rules = home_rules + , re_eps_rules = eps_rules + , re_visible_orphs = orphs }) fn + + | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers + = [] -- and wrappers, which never have any rules + + | otherwise + = idCoreRules fn ++ + get local_rules ++ + find_visible home_rules ++ + find_visible eps_rules + where - imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` []) + fn_name = idName fn + find_visible rb = filter (ruleIsVisible orphs) (get rb) + get rb = lookupNameEnv rb fn_name `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True @@ -370,37 +470,28 @@ but that isn't quite right: in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase + Note [External package rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [Overall plumbing for rules], it is explained that the final +RuleBase which we must consider is combined from 4 different sources. -************************************************************************ -* * - RuleBase -* * -************************************************************************ --} - --- RuleBase itself is defined in GHC.Core, along with CoreRule - -emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv - -mkRuleBase :: [CoreRule] -> RuleBase -mkRuleBase rules = extendRuleBaseList emptyRuleBase rules +During simplifier runs, the fourth source of rules is constantly being updated +as new interfaces are loaded into the EPS. Therefore just before we check to see +if any rules match we get the EPS RuleBase and combine it with the existing RuleBase +and then perform exactly 1 lookup into the new map. -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl' extendRuleBase rule_base new_guys +It is more efficient to avoid combining the environments and store the uncombined +environments as we can instead perform 1 lookup into each environment and then combine +the results. -extendRuleBase :: RuleBase -> CoreRule -> RuleBase -extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule +Essentially we use the identity: -extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv -extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs) +> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) +> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 -pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = pprUFM rules $ \rss -> - vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- rss ] +The latter being more efficient as we don't construct an intermediate +map. +-} {- ************************************************************************ @@ -1575,7 +1666,7 @@ ruleCheckFun env fn args | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (rc_rules env fn) - match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules -- cgit v1.2.1