[commit: ghc] ghc-8.0: Fix combineIdenticalAlts (fc5f857)
git at git.haskell.org
git at git.haskell.org
Thu Jan 21 12:27:27 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/fc5f85768c297c51a2366aa8af8afa33a85dd19c/ghc
>---------------------------------------------------------------
commit fc5f85768c297c51a2366aa8af8afa33a85dd19c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Jan 20 08:07:43 2016 +0000
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.
(cherry picked from commit 514bac264cb60db26ff9da10c6b79c3f5bd6e96d)
>---------------------------------------------------------------
fc5f85768c297c51a2366aa8af8afa33a85dd19c
compiler/coreSyn/CoreUtils.hs | 67 ++++++++++++++++------
testsuite/tests/simplCore/should_run/T11172.hs | 41 +++++++++++++
testsuite/tests/simplCore/should_run/T11172.stdout | 1 +
testsuite/tests/simplCore/should_run/all.T | 1 +
4 files changed, 93 insertions(+), 17 deletions(-)
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 9c2f16c..e2a4bb9 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -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,72 @@ 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
+
+Then when combining the A and C alternatives we get
-combineIdenticalAlts :: [AltCon] -> [CoreAlt] -> (Bool, [AltCon], [CoreAlt])
+ 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)
diff --git a/testsuite/tests/simplCore/should_run/T11172.hs b/testsuite/tests/simplCore/should_run/T11172.hs
new file mode 100644
index 0000000..6cf5216
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11172.hs
@@ -0,0 +1,41 @@
+{-# 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 ())
diff --git a/testsuite/tests/simplCore/should_run/T11172.stdout b/testsuite/tests/simplCore/should_run/T11172.stdout
new file mode 100644
index 0000000..9173c65
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11172.stdout
@@ -0,0 +1 @@
+Right (Left (),JSONState [] () ())
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index ba775b7..9c15b0f 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -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, [''])
More information about the ghc-commits
mailing list