diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 89187259ba0eb20a7f2b9c65775f21d8aae3f393..da1e31ea6f21810ae0e242592196fcd12e1c9c46 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -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') }
diff --git a/testsuite/tests/simplCore/should_compile/T16978.hs b/testsuite/tests/simplCore/should_compile/T16978a.hs
similarity index 100%
rename from testsuite/tests/simplCore/should_compile/T16978.hs
rename to testsuite/tests/simplCore/should_compile/T16978a.hs
diff --git a/testsuite/tests/simplCore/should_compile/T16978b.hs b/testsuite/tests/simplCore/should_compile/T16978b.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6d1f4e8ed8ddd9b754dc238af868f3eb33b1c0c7
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T16978b.hs
@@ -0,0 +1,18 @@
+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 #-}
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 838ae93cad561826a832fe95b776d5ab2b4f5e93..771988eccf7211305e001577e2e5fcc6581fa7b0 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -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'])
test('T17140',