diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2019-08-19 14:03:35 (GMT) |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-11-08 17:09:22 (GMT) |
| commit | 5c87ebd7b24db75c64443a708f6005ecad3b763e (patch) | |
| tree | c12a06497ac4a6582fbb9faf20c55fb55c12d87a | |
| parent | 3db2ab306d56582ac4d7600755393bf2e52a86cf (diff) | |
| download | ghc-5c87ebd7b24db75c64443a708f6005ecad3b763e.zip ghc-5c87ebd7b24db75c64443a708f6005ecad3b763e.tar.gz ghc-5c87ebd7b24db75c64443a708f6005ecad3b763e.tar.bz2 | |
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 a2a0e6f3bb2d02a9347dec4c7c4f6d4480bc2421)
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 37 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T16978a.hs (renamed from testsuite/tests/simplCore/should_compile/T16978.hs) | 0 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T16978b.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 3 |
4 files changed, 53 insertions, 5 deletions
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 8918725..da1e31e 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 index cf78013..cf78013 100644 --- a/testsuite/tests/simplCore/should_compile/T16978.hs +++ b/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 0000000..6d1f4e8 --- /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 838ae93..771988e 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', |