diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-07-27 13:56:31 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-10-22 14:26:46 +0200 |
commit | 50f951138023c8b8b30b99df9cffd909f182ad35 (patch) | |
tree | ec331ae857110a48b209f3b66aea8fdc00415c1a | |
parent | 2980c318c2a269d79133744c22f14823c6fccf0e (diff) | |
download | haskell-50f951138023c8b8b30b99df9cffd909f182ad35.tar.gz |
Do not inline or apply rules on LHS of rules
This is the right thing to do anyway, and fixes Trac #10528
-rw-r--r-- | compiler/simplCore/SimplCore.hs | 4 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.hs | 18 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.hs | 36 |
3 files changed, 39 insertions, 19 deletions
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 0a2f8e4d30..4789160120 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -23,7 +23,7 @@ import CoreUtils ( coreBindsSize, coreBindsStats, exprSize, mkTicks, stripTicksTop ) import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult, lintAnnots ) -import Simplify ( simplTopBinds, simplExpr, simplRule ) +import Simplify ( simplTopBinds, simplExpr, simplRules ) import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv import SimplMonad @@ -649,7 +649,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- 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 <- mapM (simplRule env1 Nothing) rules + ; rules1 <- simplRules env1 Nothing rules ; return (getFloatBinds env1, rules1) } ; diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index a768be46f9..6dbe8706c3 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -14,7 +14,7 @@ module SimplUtils ( preInlineUnconditionally, postInlineUnconditionally, activeUnfolding, activeRule, getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, + simplEnvForGHCi, updModeForStableUnfoldings, updModeForRuleLHS, -- The continuation type SimplCont(..), DupFlag(..), @@ -700,7 +700,21 @@ updModeForStableUnfoldings inline_rule_act current_mode phaseFromActivation (ActiveAfter n) = Phase n phaseFromActivation _ = InitialPhase -{- +updModeForRuleLHS :: SimplifierMode -> SimplifierMode +-- See Note [Simplifying RULE LHSs] +updModeForRuleLHS current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False + , sm_rules = False + , sm_eta_expand = False } + +{- Note [Simplifying RULE LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying on the LHS of a rule, refrain from all inlining and +all RULES. Doing anything to the LHS is plain confusing, because it +means that what the rule matches is not what the user wrote. +c.f. Trac #10595, and #10528. + Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Something is inlined if diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 40a68d4e6c..d816d3f157 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} -module Simplify ( simplTopBinds, simplExpr, simplRule ) where +module Simplify ( simplTopBinds, simplExpr, simplRules ) where #include "HsVersions.h" @@ -2952,22 +2952,28 @@ addBndrRules env in_id out_id | null old_rules = return (env, out_id) | otherwise - = do { new_rules <- mapM (simplRule env (Just (idName out_id))) old_rules + = do { new_rules <- simplRules env (Just (idName out_id)) old_rules ; let final_id = out_id `setIdSpecialisation` mkSpecInfo new_rules ; return (modifyInScope env final_id, final_id) } where old_rules = specInfoRules (idSpecialisation in_id) -simplRule :: SimplEnv -> Maybe Name -> CoreRule -> SimplM CoreRule -simplRule _ _ rule@(BuiltinRule {}) = return rule -simplRule env mb_new_nm rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_act = act }) - = do { (env, bndrs') <- simplBinders env bndrs - ; let rule_env = updMode (updModeForStableUnfoldings act) env - ; args' <- mapM (simplExpr rule_env) args - ; rhs' <- simplExpr rule_env rhs - ; return (rule { ru_bndrs = bndrs' - , ru_fn = mb_new_nm `orElse` fn_name - , ru_args = args' - , ru_rhs = rhs' }) } +simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule] +simplRules env mb_new_nm rules + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_act = act }) + = do { (env, bndrs') <- simplBinders env bndrs + ; let lhs_env = updMode updModeForRuleLHS env + rhs_env = updMode (updModeForStableUnfoldings act) env + ; args' <- mapM (simplExpr lhs_env) args + ; rhs' <- simplExpr rhs_env rhs + ; return (rule { ru_bndrs = bndrs' + , ru_fn = mb_new_nm `orElse` fn_name + , ru_args = args' + , ru_rhs = rhs' }) } |