[commit: ghc] wip/T14684: Combine the CoreAlts with the most common RHS (fe98cd7)
git at git.haskell.org
git at git.haskell.org
Tue Feb 20 04:45:29 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T14684
Link : http://ghc.haskell.org/trac/ghc/changeset/fe98cd7538ce18dec260b50ca756d06929ae0b3b/ghc
>---------------------------------------------------------------
commit fe98cd7538ce18dec260b50ca756d06929ae0b3b
Author: Simon Jakobi <simon.jakobi at gmail.com>
Date: Mon Feb 19 23:44:52 2018 -0500
Combine the CoreAlts with the most common RHS
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
>---------------------------------------------------------------
fe98cd7538ce18dec260b50ca756d06929ae0b3b
compiler/coreSyn/CoreUtils.hs | 87 ++++++++++++++--------
testsuite/tests/simplCore/should_compile/Makefile | 3 +
testsuite/tests/simplCore/should_compile/T14684.hs | 18 +++++
.../tests/simplCore/should_compile/T14684.stdout | 6 ++
testsuite/tests/simplCore/should_compile/all.T | 4 +
5 files changed, 88 insertions(+), 30 deletions(-)
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 3d5f4bc..157d6d2 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 33322f3..fa1c796 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 0000000..30671eb
--- /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 0000000..7138806
--- /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 e681ca7..e6c0957 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'])
More information about the ghc-commits
mailing list