[commit: ghc] master: Do not inline or apply rules on LHS of rules (bc4b64c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/bc4b64ca5b99bff6b3d5051b57cb2bc52bd4c841/ghc

>---------------------------------------------------------------

commit bc4b64ca5b99bff6b3d5051b57cb2bc52bd4c841
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jul 27 13:56:31 2015 +0100

    Do not inline or apply rules on LHS of rules
    
    This is the right thing to do anyway, and fixes Trac #10528


>---------------------------------------------------------------

bc4b64ca5b99bff6b3d5051b57cb2bc52bd4c841
 compiler/simplCore/SimplCore.hs  |  4 ++--
 compiler/simplCore/SimplUtils.hs | 18 ++++++++++++++++--
 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 a667250..73cdd70 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -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) } ;
 
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index b1e8c1e..d297be3 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(..),
@@ -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
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index bd17361..07bc004 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"
 
@@ -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' }) }