[commit: ghc] master: Fix combineIdenticalAlts (514bac2)

git at git.haskell.org git at git.haskell.org
Wed Jan 20 08:10:27 UTC 2016


Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/514bac264cb60db26ff9da10c6b79c3f5bd6e96d/ghc

>---------------------------------------------------------------

commit 514bac264cb60db26ff9da10c6b79c3f5bd6e96d
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.


>---------------------------------------------------------------

514bac264cb60db26ff9da10c6b79c3f5bd6e96d
 compiler/coreSyn/CoreUtils.hs                      | 65 ++++++++++++++++------
 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, 91 insertions(+), 17 deletions(-)

diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 59f1d4f..b3931c8 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,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)
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