[commit: ghc] wip/T11731: CSE: Do not add a "trivial_scrut -> case binder" mapping (89b4b03)

[git at git.haskell.org]

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

On branch  : wip/T11731
Link       : http://ghc.haskell.org/trac/ghc/changeset/89b4b0363d865c7adbb98793e51e4f7b4e91ec31/ghc

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

commit 89b4b0363d865c7adbb98793e51e4f7b4e91ec31
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Mar 30 18:00:15 2016 +0200

    CSE: Do not add a "trivial_scrut -> case binder" mapping
    
    according to the existing strategy to replace, in the body of the
    expression "case x of y in e", occurrences of y with x (and not the
    other way around with non-trivial case expressions).
    
    Previously, the mapping was added to the environment, but never used,
    due to the exprIsTrivial guard in tryForCSE. But this is fragile if
    exprIsTrivial is modified, as proposed in #11731, hence the removal of
    this code smell.


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

89b4b0363d865c7adbb98793e51e4f7b4e91ec31
 compiler/simplCore/CSE.hs | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index b4e6e14..0a053d3 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -174,8 +174,13 @@ cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, (OutBndr, OutExpr))
 cseRhs env (id',rhs)
   = case lookupCSEnv env rhs'' of
         Nothing
-          | always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs'))
-          | otherwise     -> (env,                      (id', rhs'))
+          | always_active -> (env', (zapped_id, rhs'))
+          | otherwise     -> (env,  (id', rhs'))
+          where
+            -- Do not add an unwanted trivial_scrut -> case binder mapping, according
+            -- to Note [Case binders 2].
+            env' | Var {} <- rhs' = env
+                 | otherwise      = extendCSEnv env rhs' id'
         Just id
           | always_active -> (extendCSSubst env id' id_expr, (id', mkTicks ticks id_expr))
           | otherwise     -> (env,                           (id', mkTicks ticks id_expr))