[commit: ghc] wip/T14152: simplNonRecJoinPoint: Handle Shadowing correctly (97ca0d2)

[git at git.haskell.org]

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

On branch  : wip/T14152
Link       : http://ghc.haskell.org/trac/ghc/changeset/97ca0d249c380a961a4cb90afb44bfcee1f632f2/ghc

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

commit 97ca0d249c380a961a4cb90afb44bfcee1f632f2
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Oct 26 19:36:24 2017 -0400

    simplNonRecJoinPoint: Handle Shadowing correctly
    
    Previously, (since 33452df), simplNonRecJoinPoint would do the wrong
    thing in the presence of shadowing: It analyzed the RHS of a join
    binding with the environment for the body. In particular, with
    
        foo x =
          join x = x * x
          in x
    
    where there is shadowing, it renames the inner x to x1, and should
    produce
    
        foo x =
          join x1 = x * x
          in x1
    
    but because the substitution (x ↦ x1) is also used on the RHS we get the
    bogus
    
        foo x =
          join x1 = x1 * x1
          in x1
    
    Fixed this by adding a `rhs_se` parameter, analogous to `simplNonRecE`
    and `simplLazyBind`.
    
    Differential Revision: https://phabricator.haskell.org/D4130


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

97ca0d249c380a961a4cb90afb44bfcee1f632f2
 compiler/simplCore/Simplify.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index d6b859a..adcd017 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -204,7 +204,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
   | Just cont <- mb_cont
   = ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )
     trace_bind "join" $
-    simplJoinBind env cont old_bndr new_bndr rhs
+    simplJoinBind env cont old_bndr new_bndr rhs env
 
   | otherwise
   = trace_bind "normal" $
@@ -300,10 +300,11 @@ simplJoinBind :: SimplEnv
               -> InId -> OutId          -- Binder, both pre-and post simpl
                                         -- The OutId has IdInfo, except arity,
                                         --   unfolding
-              -> InExpr
+              -> InExpr -> SimplEnv     -- The right hand side and its env
               -> SimplM (SimplFloats, SimplEnv)
-simplJoinBind env cont old_bndr new_bndr rhs
-  = do  { rhs' <- simplJoinRhs env old_bndr rhs cont
+simplJoinBind env cont old_bndr new_bndr rhs rhs_se
+  = do  { let rhs_env = rhs_se `setInScopeFromE` env
+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont
         ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }
 
 --------------------------
@@ -1471,7 +1472,7 @@ simplNonRecJoinPoint env bndr rhs body cont
         ; let res_ty = contResultType cont
         ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr
         ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1
-        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs
+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env
         ; (floats2, body') <- simplExprF env3 body cont
         ; return (floats1 `addFloats` floats2, body') }