diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2022-01-20 14:32:00 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-26 19:46:34 -0500 |
| commit | a5924b38b0cbe75021e6042b946fe921f2c4afe4 (patch) | |
| tree | 56197ee8a5813c14e4e0f47e4cc5bc4bbcf1c5ce | |
| parent | 83d3ad3148917028529b4c5614e2a03877e21863 (diff) | |
| download | haskell-a5924b38b0cbe75021e6042b946fe921f2c4afe4.tar.gz | |
Simplifier: Do the right thing if doFloatFromRhs = False
If `doFloatFromRhs` is `False` then the result from `prepareBinding`
should not be used. Previously it was in ways that are silly (but not
completly wrong, as the simplifier would clean that up again, so no
test case).
This was spotted by Simon during a phone call.
Fixes #20976
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 14 |
1 files changed, 7 insertions, 7 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 20161722be..f08f96b6bc 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -370,8 +370,8 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; (rhs_floats, body3) <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) - then -- No floating, revert to body1 - return (emptyFloats env, wrapFloats body_floats2 body1) + then -- Do not float; abandon prepareBinding entirely and revert to body1 + return (emptyFloats env, wrapFloats body_floats1 body1) else if null tvs then -- Simple floating {-#SCC "simplLazyBind-simple-floating" #-} @@ -450,15 +450,15 @@ completeNonRecX :: TopLevelFlag -> SimplEnv completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $ - do { (prepd_floats, new_rhs) <- prepareBinding env top_lvl new_bndr new_rhs + do { (prepd_floats, prepd_rhs) <- prepareBinding env top_lvl new_bndr new_rhs ; let floats = emptyFloats env `addLetFloats` prepd_floats ; (rhs_floats, rhs2) <- - if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs + if doFloatFromRhs NotTopLevel NonRecursive is_strict floats prepd_rhs then -- Add the floats to the main env do { tick LetFloatFromLet - ; return (floats, new_rhs) } - else -- Do not float; wrap the floats around the RHS - return (emptyFloats env, wrapFloats floats new_rhs) + ; return (floats, prepd_rhs) } + else -- Do not float; abandon prepareBinding entirely and revert to new_rhs + return (emptyFloats env, new_rhs) ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) NotTopLevel Nothing |