diff options
author | Simon Jakobi <simon.jakobi@gmail.com> | 2018-02-19 23:44:52 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-02-19 23:45:01 -0500 |
commit | fe98cd7538ce18dec260b50ca756d06929ae0b3b (patch) | |
tree | e0aeb9ac71bd3ca6dfe7141da94064539ef3fedd | |
parent | eb2daa2b6a83412382aa0fcda598f8b3d40fde2c (diff) | |
download | haskell-fe98cd7538ce18dec260b50ca756d06929ae0b3b.tar.gz |
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
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 87 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/Makefile | 3 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T14684.hs | 18 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T14684.stdout | 6 | ||||
-rw-r--r-- | 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 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']) |