summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs21
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Monad.hs19
-rw-r--r--compiler/GHC/Core/Rules.hs17
-rw-r--r--testsuite/tests/simplCore/should_compile/T19790.stderr2
4 files changed, 37 insertions, 22 deletions
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 276bfee45d..a6170e185b 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -17,7 +17,7 @@ import GHC.Platform.Ways ( hasWay, Way(WayProf) )
import GHC.Core
import GHC.Core.Opt.CSE ( cseProgram )
-import GHC.Core.Rules ( mkRuleBase, unionRuleBase,
+import GHC.Core.Rules ( mkRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
getRules, initRuleOpts )
import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
@@ -591,15 +591,14 @@ simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do
simplifyExpr hsc_env expr
= withTiming logger (text "Simplify [expr]") (const ()) $
do { eps <- hscEPS hsc_env ;
- ; let rule_env = mkRuleEnv (eps_rule_base eps) []
- fi_env = ( eps_fam_inst_env eps
+ ; let fi_env = ( eps_fam_inst_env eps
, extendFamInstEnvList emptyFamInstEnv $
snd $ ic_instances $ hsc_IC hsc_env )
simpl_env = simplEnvForGHCi logger dflags
; let sz = exprSize expr
- ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $
+ ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $
simplExprGently simpl_env expr
; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
@@ -726,21 +725,23 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
FormatCore
(pprCoreBindings tagged_binds);
- -- Get any new rules, and extend the rule base
- -- See Note [Overall plumbing for rules] in GHC.Core.Rules
- -- We need to do this regularly, because simplification can
+ -- read_eps_rules:
+ -- We need to read rules from the EPS regularly because simplification can
-- 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.
+ -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.
eps <- hscEPS hsc_env ;
- let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
- ; rule_base2 = extendRuleBaseList rule_base1 rules
+ let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env
+ ; rule_base = extendRuleBaseList hpt_rule_base rules
; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
; vis_orphs = this_mod : dep_orphs deps } ;
-- Simplify the program
((binds1, rules1), counts1) <-
- initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $
+ initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $
do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 83d27f4fe5..8ee49f4968 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -28,7 +28,8 @@ import GHC.Types.Id ( Id, mkSysLocalOrCoVar )
import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo )
import GHC.Core.Type ( Type, Mult )
import GHC.Core.FamInstEnv ( FamInstEnv )
-import GHC.Core ( RuleEnv(..) )
+import GHC.Core ( RuleEnv(..), RuleBase)
+import GHC.Core.Rules
import GHC.Core.Utils ( mkLamTypes )
import GHC.Core.Coercion.Opt
import GHC.Types.Unique.Supply
@@ -79,20 +80,23 @@ data SimplTopEnv
= STE { st_flags :: DynFlags
, st_logger :: !Logger
, st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run
- , st_rules :: RuleEnv
+ , st_query_rulebase :: IO RuleBase
+ -- ^ The action to retrieve an up-to-date EPS RuleBase
+ -- See Note [Overall plumbing for rules]
+ , st_mod_rules :: RuleEnv
, st_fams :: (FamInstEnv, FamInstEnv)
, st_co_opt_opts :: !OptCoercionOpts
-- ^ Coercion optimiser options
}
-initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
+initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)
-> Int -- Size of the bindings, used to limit
-- the number of ticks we allow
-> SimplM a
-> IO (a, SimplCount)
-initSmpl logger dflags rules fam_envs size m
+initSmpl logger dflags qrb rules fam_envs size m
= do -- No init count; set to 0
let simplCount = zeroSimplCount dflags
(result, count) <- unSM m env simplCount
@@ -100,7 +104,8 @@ initSmpl logger dflags rules fam_envs size m
where
env = STE { st_flags = dflags
, st_logger = logger
- , st_rules = rules
+ , st_query_rulebase = qrb
+ , st_mod_rules = rules
, st_max_ticks = computeMaxTicks dflags size
, st_fams = fam_envs
, st_co_opt_opts = initOptCoercionOpts dflags
@@ -203,7 +208,9 @@ instance MonadIO SimplM where
return (x, sc)
getSimplRules :: SimplM RuleEnv
-getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))
+getSimplRules = SM (\st_env sc -> do
+ eps_rules <- st_query_rulebase st_env
+ return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index a365b838c4..99cfea8af2 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -10,7 +10,7 @@
module GHC.Core.Rules (
-- ** Constructing
emptyRuleBase, mkRuleBase, extendRuleBaseList,
- unionRuleBase, pprRuleBase,
+ unionRuleBase, pprRuleBase, extendRuleEnv,
-- ** Checking rule applications
ruleCheckProgram,
@@ -136,14 +136,18 @@ Note [Overall plumbing for rules]
[NB: we are inconsistent here. We should do the same for external
packages, but we don't. Same for type-class instances.]
-* So in the outer simplifier loop, we combine (b-d) into a single
+* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single
RuleBase, reading
(b) from the ModGuts,
(c) from the GHC.Core.Opt.Monad, and
+ just before doing rule matching we read
(d) from its mutable variable
- [Of course this means that we won't see new EPS rules that come in
- during a single simplifier iteration, but that probably does not
- matter.]
+ and combine it with the results from (b & c).
+
+ In a single simplifier run new rules can be added into the EPS so it matters
+ to keep an up-to-date view of which rules have been loaded. For examples of
+ where this went wrong and caused cryptic performance regressions seee
+ see T19790 and !6735.
************************************************************************
@@ -368,6 +372,9 @@ extendRuleBase :: RuleBase -> CoreRule -> RuleBase
extendRuleBase rule_base rule
= extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule
+extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv
+extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rules `unionRuleBase` rb) orphs)
+
pprRuleBase :: RuleBase -> SDoc
pprRuleBase rules = pprUFM rules $ \rss ->
vcat [ pprRules (tidyRules emptyTidyEnv rs)
diff --git a/testsuite/tests/simplCore/should_compile/T19790.stderr b/testsuite/tests/simplCore/should_compile/T19790.stderr
index 71632231f7..2108b82afe 100644
--- a/testsuite/tests/simplCore/should_compile/T19790.stderr
+++ b/testsuite/tests/simplCore/should_compile/T19790.stderr
@@ -1,7 +1,7 @@
Rule fired: Class op + (BUILTIN)
Rule fired: Class op length (BUILTIN)
+Rule fired: length (GHC.List)
Rule fired: map (GHC.Base)
Rule fired: fold/build (GHC.Base)
Rule fired: This rule should fire! (T19790)
-Rule fired: length (GHC.List)
Rule fired: lengthList (GHC.List)
View Lorry Controller Status