Commit bc4b64ca authored by Simon Peyton Jones's avatar Simon Peyton Jones

Do not inline or apply rules on LHS of rules

This is the right thing to do anyway, and fixes Trac #10528
parent 81fffc4b
......@@ -23,7 +23,7 @@ import CoreStats ( coreBindsSize, coreBindsStats, exprSize )
import CoreUtils ( 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
......@@ -659,7 +659,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) } ;
......
......@@ -14,7 +14,7 @@ module SimplUtils (
preInlineUnconditionally, postInlineUnconditionally,
activeUnfolding, activeRule,
getUnfoldingInRuleMatch,
simplEnvForGHCi, updModeForStableUnfoldings,
simplEnvForGHCi, updModeForStableUnfoldings, updModeForRuleLHS,
-- The continuation type
SimplCont(..), DupFlag(..),
......@@ -701,7 +701,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
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE CPP #-}
module Simplify ( simplTopBinds, simplExpr, simplRule ) where
module Simplify ( simplTopBinds, simplExpr, simplRules ) where
#include "HsVersions.h"
......@@ -2956,22 +2956,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' }) }
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment