Combine the CoreAlts with the most common RHSwip/T14684

Unless there already is a DEFAULT alternative, look for the most common
RHS and create a new DEFAULT alt.

Previously, only the very first RHS was considered.

Test Plan: make test TEST="T7360 T14684"

Reviewers: bgamari

Subscribers: AndreasK, mpickering, rwbarton, thomie, carter

GHC Trac Issues: #14684

Differential Revision: https://phabricator.haskell.org/D4419

5 files changed, 88 insertions, 30 deletions

diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 3d5f4bcb5a..157d6d2154 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -61,6 +61,7 @@ module CoreUtils (
 import GhcPrelude
 
 import CoreSyn
+import TrieMap
 import PrelNames ( makeStaticName )
 import PprCore
 import CoreFVs( exprFreeVars )
@@ -692,16 +693,26 @@ DEFAULT alternative.  I've occasionally seen this making a big
 difference:
 
      case e of               =====>     case e of
+       DEFAULT -> f x                     DEFAULT -> f x
        C _ -> f x                         D v -> ....v....
-       D v -> ....v....                   DEFAULT -> f x
-       DEFAULT -> f x
+       D v -> ....v....
 
-The point is that we merge common RHSs, at least for the DEFAULT case.
-[One could do something more elaborate but I've never seen it needed.]
-To avoid an expensive test, we just merge branches equal to the *first*
-alternative; this picks up the common cases
-     a) all branches equal
-     b) some branches equal to the DEFAULT (which occurs first)
+Our method of finding identical branches depends on whether or not
+there already is a DEFAULT case:
+
+ * If there is a DEFAULT case (which always comes first) we just look
+   for more branches with the same RHS and merge them into the existing
+   DEFAULT case.
+
+ * Otherwise we look for the most common RHS and form a new DEFAULT
+   case from those alternatives:
+
+     case a of               =====>     case a of
+       A -> f x                           DEFAULT -> g x
+       B -> g x                           A -> f x
+       C -> f x                           C -> f x
+       D -> g x
+       E -> g x
 
 The case where Combine Identical Alternatives transformation showed up
 was like this (base/Foreign/C/Err/Error.hs):
@@ -717,9 +728,9 @@ where @is@ was something like
 This gave rise to a horrible sequence of cases
 
         case p of
-          (-1) -> $j p
-          1    -> e1
           DEFAULT -> $j p
+          (-1) -> $j p
+          1 -> e1
 
 and similarly in cascade for all the join points!
 
@@ -773,33 +784,49 @@ missed the first one.)
 
 combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT
                      -> [CoreAlt]
-                     -> (Bool,      -- True <=> something happened
+                     -> (Bool,      -- True <=> we combined some alts
                          [AltCon],  -- New constructors that cannot match DEFAULT
                          [CoreAlt]) -- New alternatives
 -- See Note [Combine identical alternatives]
--- True <=> we did some combining, result is a single DEFAULT alternative
-combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)
-  | all isDeadBinder bndrs1    -- Remember the default
-  , not (null elim_rest) -- alternative comes first
-  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)
+combineIdenticalAlts imposs_deflt_cons alts
+  = case identical_alts of
+      (_con, _bndrs, rhs1) : elim_rest@(_ : _)
+        -> (True, imposs_deflt_cons', alts')
+        where
+          -- See Note
+          -- [Care with impossible-constructors when combining alternatives]
+          imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons
+          elim_cons = map fstOf3 identical_alts
+
+          alts' = deflt_alt : filter (not . cheapEqTicked rhs1 . thdOf3) alts
+          deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
+          tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
+      _ -> (False, imposs_deflt_cons, alts)
   where
-    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts
-    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
+    identical_alts
+      = case alts of
+          (DEFAULT, [], rhs1) : _
+            -> filter (cheapEqTicked rhs1 . thdOf3) dead_bindr_alts
+          _ -> most_common_alts -- See #14684
+    dead_bindr_alts = filter (all isDeadBinder . sndOf3) alts
+    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
+    most_common_alts = foldCoreMap longest [] core_map
+      where
+        core_map = foldr updateCM emptyCoreMap dead_bindr_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]
+        updateCM :: CoreAlt -> CoreMap [CoreAlt] -> CoreMap [CoreAlt]
+        updateCM ca@(_, _, rhs) cm
+          = alterTM (stripTicksE tickishFloatable rhs) (prepend ca) cm
 
-    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
-    identical_to_alt1 (_con,bndrs,rhs)
-      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
-    tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
+        prepend x (Just xs) = Just (x : xs)
+        prepend x Nothing   = Just [x]
 
-combineIdenticalAlts imposs_cons alts
-  = (False, imposs_cons, alts)
+        longest :: [a] -> [a] -> [a]
+        longest xs ys = go xs ys
+          where
+            go _       []      = xs
+            go []      _       = ys
+            go (_:xs') (_:ys') = go xs' ys'
 
 {- *********************************************************************
 *                                                                      *
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 33322f38a1..fa1c796f90 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -237,3 +237,6 @@ T14140:
 	$(RM) -f T14140.o T14140.hi
 	-'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T14140.hs | grep '[2-9]# *->'
 # Expecting no output from the grep, hence "-"
+
+T14684:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-simpl -dsuppress-uniques T14684.hs | grep -B1 -A4 "__DEFAULT -> 2#"
diff --git a/testsuite/tests/simplCore/should_compile/T14684.hs b/testsuite/tests/simplCore/should_compile/T14684.hs
new file mode 100644
index 0000000000..30671eb301
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14684.hs
@@ -0,0 +1,18 @@
+-- This is a test for the combine-identical-alternatives optimisation.
+-- The alternatives with the most common RHS are combined into
+-- a single DEFAULT alternative.
+
+
+module T14684 where
+
+data Foo = Foo1 | Foo2 | Foo3 !Int | Foo4 | Foo5 | Foo6
+
+fun1 :: Foo -> Int
+{-# NOINLINE fun1 #-}
+fun1 x = case x of
+               Foo1 -> 0
+               Foo2 -> 1
+               Foo3 {} -> 2
+               Foo4 -> 1
+               Foo5 -> 2
+               Foo6 -> 2
diff --git a/testsuite/tests/simplCore/should_compile/T14684.stdout b/testsuite/tests/simplCore/should_compile/T14684.stdout
new file mode 100644
index 0000000000..71388061e8
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14684.stdout
@@ -0,0 +1,6 @@
+      case w of {
+        __DEFAULT -> 2#;
+        Foo1 -> 0#;
+        Foo2 -> 1#;
+        Foo4 -> 1#
+      }
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index e681ca7363..e6c0957199 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -290,3 +290,7 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'),
                 compile, ['-fno-exitification -ddump-simpl'])
 test('T13990', normal, compile, ['-dcore-lint -O'])
 test('T14650', normal, compile, ['-O2'])
+test('T14684',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory T14684'])