diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-06-24 11:17:45 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2021-07-27 17:54:29 +0100 |
| commit | ca6ebd6c6d83ad793dad8f12fecf7ede926aa397 (patch) | |
| tree | 4a250e48d2a9bdb60434c386cf546fd3c97461fb | |
| parent | e8003e6d0c51f32a41c12f4047405e2355447290 (diff) | |
| download | haskell-wip/T20153.tar.gz | |
Fix a subtle scoping error in simplLazyBindwip/T20153
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.
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 25 |
1 files changed, 15 insertions, 10 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 75619af3b1..50d611035a 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -364,16 +364,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" #-} @@ -386,11 +387,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) } -------------------------- @@ -721,7 +722,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 @@ -814,6 +815,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 |