Fix a subtle scoping error in simplLazyBind

In the call to prepareBinding (in simplLazyBind), I had failed to
extend the in-scope set with the binders from body_floats1. As as
result, when eta-expanding deep inside prepareBinding we made up
an eta-binder that shadowed a variable free in body1.  Yikes.

It's hard to trigger this bug.  It showed up when I was working
on !5658, and I started using the in-scope set for eta-expansion,
rather than taking free variables afresh.  But even then it only
showed up when compiling a module in Haddock
   utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs

Sadly Haddock is compiled without Core Lint, so we ultimately got
a seg-fault.  Lint nailed it fast once I realised that it was off.

There is some other tiny refactoring in this patch.

1 files changed, 15 insertions, 10 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index ac55c68ded..f7853a551a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -361,16 +361,17 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 
         -- ANF-ise a constructor or PAP rhs
         -- We get at most one float per argument here
+        ; let body_env1 = body_env `setInScopeFromF` body_floats1
+              -- body_env1: add to in-scope set the binders from body_floats1
+              -- so that prepareBinding knows what is in scope in body1
         ; (let_floats, body2) <- {-#SCC "prepareBinding" #-}
-                                 prepareBinding body_env top_lvl bndr1 body1
+                                 prepareBinding body_env1 top_lvl bndr1 body1
         ; let body_floats2 = body_floats1 `addLetFloats` let_floats
 
-        ; (rhs_floats, rhs')
+        ; (rhs_floats, body3)
             <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)
                 then                    -- No floating, revert to body1
-                     {-#SCC "simplLazyBind-no-floating" #-}
-                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont
-                        ; return (emptyFloats env, rhs') }
+                     return (emptyFloats env, wrapFloats body_floats2 body1)
 
                 else if null tvs then   -- Simple floating
                      {-#SCC "simplLazyBind-simple-floating" #-}
@@ -383,11 +384,11 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                         ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl
                                                                 tvs' body_floats2 body2
                         ; let floats = foldl' extendFloats (emptyFloats env) poly_binds
-                        ; rhs' <- mkLam env tvs' body3 rhs_cont
-                        ; return (floats, rhs') }
+                        ; return (floats, body3) }
 
-        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
-                                             top_lvl Nothing bndr bndr1 rhs'
+        ; let env' = env `setInScopeFromF` rhs_floats
+        ; rhs' <- mkLam env' tvs' body3 rhs_cont
+        ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr1 rhs'
         ; return (rhs_floats `addFloats` bind_float, env2) }
 
 --------------------------
@@ -718,7 +719,7 @@ prepareRhs :: SimplEnv -> TopLevelFlag
 -- Transforms a RHS into a better RHS by ANF'ing args
 -- for expandable RHSs: constructors and PAPs
 -- e.g        x = Just e
--- becomes    a = e
+-- becomes    a = e               -- 'a' is fresh
 --            x = Just a
 -- See Note [prepareRhs]
 prepareRhs env top_lvl occ rhs0
@@ -811,6 +812,10 @@ makeTrivialBinding env top_lvl occ_fs info expr expr_ty
         -- Now something very like completeBind,
         -- but without the postInlineUnconditionally part
         ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1
+          -- Technically we should extend the in-scope set in 'env' with
+          -- the 'floats' from prepareRHS; but they are all fresh, so there is
+          -- no danger of introducing name shadowig in eta expansion
+
         ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2
 
         ; let final_id = addLetBndrInfo var arity_type unf