Commit 5c87ebd7 authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Marge Bot

SetLevels: Don't set context level when floating cases

When floating a single-alternative case we previously would set the
context level to the level where we were floating the case. However,
this is wrong as we are only moving the case and its binders. This
resulted in #16978, where the disrepancy caused us to
unnecessarily abstract over some free variables of the case body,
resulting in shadowing and consequently Core Lint failures.

(cherry picked from commit a2a0e6f3)
parent 3db2ab30
Pipeline #12431 failed with stages
in 292 minutes and 17 seconds
......@@ -504,7 +504,7 @@ Consider this:
Here we can float the (case y ...) out, because y is sure
to be evaluated, to give
f x vs = case x of { MkT y ->
caes y of I# w ->
case y of I# w ->
let f vs = ...(e)...f..
in f vs
......@@ -536,6 +536,32 @@ Things to note:
* We only do this with a single-alternative case
Note [Setting levels when floating single-alternative cases]
Handling level-setting when floating a single-alternative case binding
is a bit subtle, as evidenced by #16978. In particular, we must keep
in mind that we are merely moving the case and its binders, not the
body. For example, suppose 'a' is known to be evaluated and we have
\z -> case a of
(x,_) -> <body involving x and z>
After floating we may have:
case a of
(x,_) -> \z -> <body involving x and z>
{- some expression involving x and z -}
When analysing <body involving...> we want to use the /ambient/ level,
and /not/ the desitnation level of the 'case a of (x,-) ->' binding.
#16978 was caused by us setting the context level to the destination
level of `x` when analysing <body>. This led us to conclude that we
needed to quantify over some of its free variables (e.g. z), resulting
in shadowing and very confusing Core Lint failures.
Note [Check the output scrutinee for exprIsHNF]
Consider this:
......@@ -1669,14 +1695,17 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
| otherwise
= mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
-- | Clone the binders bound by a single-alternative case.
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
new_lvl vs
= do { us <- getUniqueSupplyM
; let (subst', vs') = cloneBndrs subst us vs
env' = env { le_ctxt_lvl = new_lvl
, le_join_ceil = new_lvl
, le_lvl_env = addLvls new_lvl lvl_env vs'
-- N.B. We are not moving the body of the case, merely its case
-- binders. Consequently we should *not* set le_ctxt_lvl and
-- le_join_ceil. See Note [Setting levels when floating
-- single-alternative cases].
env' = env { le_lvl_env = addLvls new_lvl lvl_env vs'
, le_subst = subst'
, le_env = foldl' add_id id_env (vs `zip` vs') }
module T16978b (renderNode) where
import Data.Text (Text)
import qualified Data.Text.Lazy.Builder as B
data Value = String !Text | Null
renderNode :: Value -> B.Builder -> ((), B.Builder)
renderNode v b =
case renderValue v b of
(t, s') -> ((), s' <> B.fromText t)
renderValue :: Value -> B.Builder -> (Text, B.Builder)
renderValue v b = case v of
String str -> (str, b)
Null -> let x = x in x
{-# INLINE renderValue #-}
......@@ -305,7 +305,8 @@ test('T16288', normal, multimod_compile, ['T16288B', '-O -dcore-lint -v0'])
test('T16348', normal, compile, ['-O'])
test('T16918', normal, compile, ['-O'])
test('T16918a', normal, compile, ['-O'])
test('T16978', normal, compile, ['-O'])
test('T16978a', normal, compile, ['-O'])
test('T16978b', normal, compile, ['-O'])
test('T16979a', normal, compile, ['-O'])
test('T16979b', normal, compile, ['-O'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment