Commit 514bac26 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix combineIdenticalAlts

This long-standing bug in CoreUtils.combineIdenticalAlts
was shown up by Trac #11172. The effect was that it returned
a correct set of alternatives, but a bogus set of "impossible
default constructors".  That meant that we subsequently
removed all the alternatives from a case, and hence ended
up with a bogusly empty case that should not have been empty.

See Note [Care with impossible-constructors when
combining alternatives] in CoreUtils.
parent 975bdacb
......@@ -585,7 +585,10 @@ filterAlts _tycon inst_tys imposs_cons alts
impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
impossible_alt _ _ = False
refineDefaultAlt :: [Unique] -> TyCon -> [Type] -> [AltCon] -> [CoreAlt] -> (Bool, [CoreAlt])
refineDefaultAlt :: [Unique] -> TyCon -> [Type]
-> [AltCon] -- Constructors tha cannot match the DEFAULT (if any)
-> [CoreAlt]
-> (Bool, [CoreAlt])
-- Refine the default alterantive to a DataAlt,
-- if there is a unique way to do so
refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
......@@ -667,42 +670,70 @@ defeats combineIdenticalAlts (see Trac #7360).
Note [Care with impossible-constructors when combining alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have (Trac #10538)
data T = A | B | C
data T = A | B | C | D
... case x::T of
case x::T of (Imposs-default-cons {A,B})
DEFAULT -> e1
A -> e2
B -> e1
When calling combineIdentialAlts, we'll have computed that the "impossible
constructors" for the DEFAULT alt is {A,B}, since if x is A or B we'll
take the other alternatives. But suppose we combine B into the DEFAULT,
to get
... case x::T of
When calling combineIdentialAlts, we'll have computed that the
"impossible constructors" for the DEFAULT alt is {A,B}, since if x is
A or B we'll take the other alternatives. But suppose we combine B
into the DEFAULT, to get
case x::T of (Imposs-default-cons {A})
DEFAULT -> e1
A -> e2
Then we must be careful to trim the impossible constructors to just {A},
else we risk compiling 'e1' wrong!
-}
Not only that, but we take care when there is no DEFAULT beforehand,
because we are introducing one. Consider
case x of (Imposs-default-cons {A,B,C})
A -> e1
B -> e2
C -> e1
combineIdenticalAlts :: [AltCon] -> [CoreAlt] -> (Bool, [AltCon], [CoreAlt])
Then when combining the A and C alternatives we get
case x of (Imposs-default-cons {B})
DEFAULT -> e1
B -> e2
Note that we have a new DEFAULT branch that we didn't have before. So
we need delete from the "impossible-default-constructors" all the
known-con alternatives that we have eliminated. (In Trac #11172 we
missed the first one.)
combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT
-> [CoreAlt]
-> (Bool, -- True <=> something happened
[AltCon], -- New contructors that cannot match DEFAULT
[CoreAlt]) -- New alternatives
-- See Note [Combine identical alternatives]
-- See Note [Care with impossible-constructors when combining alternatives]
-- True <=> we did some combining, result is a single DEFAULT alternative
combineIdenticalAlts imposs_cons ((_con1,bndrs1,rhs1) : con_alts)
combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)
| all isDeadBinder bndrs1 -- Remember the default
, not (null eliminated_alts) -- alternative comes first
= (True, imposs_cons', deflt_alt : filtered_alts)
, not (null elim_rest) -- alternative comes first
= (True, imposs_deflt_cons', deflt_alt : filtered_rest)
where
(eliminated_alts, filtered_alts) = partition identical_to_alt1 con_alts
(elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts
deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
imposs_cons' = imposs_cons `minusList` map fstOf3 eliminated_alts
-- See Note [Care with impossible-constructors when combining alternatives]
imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons
elim_cons = elim_con1 ++ map fstOf3 elim_rest
elim_con1 = case con1 of -- Don't forget con1!
DEFAULT -> [] -- See Note [
_ -> [con1]
cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
identical_to_alt1 (_con,bndrs,rhs)
= all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
tickss = map (stripTicksT tickishFloatable . thdOf3) eliminated_alts
tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
combineIdenticalAlts imposs_cons alts
= (False, imposs_cons, alts)
......
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Main where
data JSONState = JSONState [()] () () deriving Show
weta_s6yD :: Either a (b, c) -> (# (Either a b, JSONState) #)
weta_s6yD ww_s6ys = case ww_s6ys of
Left l -> (# (Left l, JSONState [] () ()) #)
Right (x, _) -> (# (Right x, JSONState [] () ()) #)
eta_B1 :: (Either a (b, c), t) -> Either a1 (Either a b, JSONState)
eta_B1 (ww_s6ys, _) = case weta_s6yD ww_s6ys of
(# ww_s6zb #) -> Right ww_s6zb
wks_s6yS :: Either a b -> (# (Either a b, JSONState) #)
wks_s6yS ww_s6yH =
case case ww_s6yH of
Left l_a4ay -> eta_B1 (Left l_a4ay, ())
Right r_a4aB -> eta_B1 (Right (r_a4aB, ()), ())
of
Right ww_s6ze -> (# ww_s6ze #)
ks_a49u :: (Either a b, t) -> Either a1 (Either a b, JSONState)
ks_a49u (ww_s6yH, _) = case wks_s6yS ww_s6yH of
(# ww_s6ze #) -> Right ww_s6ze
wks_s6z7 :: Either a b -> (# (Either a b, JSONState) #)
wks_s6z7 ww_s6yW = case (
case ww_s6yW of
Left _ -> ks_a49u (ww_s6yW, JSONState [()] () ())
Right _ -> ks_a49u (ww_s6yW, JSONState [] () ())
) of
Right ww_s6zh -> (# ww_s6zh #)
ks_X3Sb :: Either () Int -> Either String (Either () Int, JSONState)
ks_X3Sb ww_s6yW = case wks_s6z7 ww_s6yW of
(# ww_s6zh #) -> Right ww_s6zh
main :: IO ()
main = print $ ks_X3Sb (Left ())
......@@ -70,3 +70,4 @@ test('T457', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run,
test('T9128', normal, compile_and_run, [''])
test('T9390', normal, compile_and_run, [''])
test('T10830', extra_run_opts('+RTS -K100k -RTS'), compile_and_run, [''])
test('T11172', normal, compile_and_run, [''])
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