[commit: ghc] wip/T10613, wip/T11731: CSE: Do not add a "trivial_scrut -> case binder" mapping (5b8bf15)

[git at git.haskell.org]

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

On branches: wip/T10613,wip/T11731
Link       : http://ghc.haskell.org/trac/ghc/changeset/5b8bf154fefc8febb6b2c5f3360478b2d622a9eb/ghc

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

commit 5b8bf154fefc8febb6b2c5f3360478b2d622a9eb
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.


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

5b8bf154fefc8febb6b2c5f3360478b2d622a9eb
 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))