[commit: ghc] master: Optimizations for CmmBlockElim. (bd43378)
git at git.haskell.org
git at git.haskell.org
Sat Jun 2 20:13:25 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/bd43378dfba1d6c5f19246b972b761640eedb35c/ghc
>---------------------------------------------------------------
commit bd43378dfba1d6c5f19246b972b761640eedb35c
Author: klebinger.andreas at gmx.at <klebinger.andreas at gmx.at>
Date: Wed May 30 20:49:18 2018 -0400
Optimizations for CmmBlockElim.
* Use toBlockList instead of revPostorder.
Block elimination works on a given Cmm graph by:
* Getting a list of blocks.
* Looking for duplicates in these blocks.
* Removing all but one instance of duplicates.
There are two (reasonable) ways to get the list of blocks.
* The fast way: `toBlockList`
This just flattens the underlying map into a list.
* The convenient way: `revPostorder`
Start at the entry label, scan for reachable blocks and return
only these. This has the advantage of removing all dead code.
If there is dead code the later is better. Work done on unreachable
blocks is clearly wasted work. However by the point we run the
common block elimination pass the input graph already had all dead code
removed. This is done during control flow optimization in
CmmContFlowOpt which is our first Cmm pass.
This means common block elimination is free to use toBlockList
because revPostorder would return the same blocks. (Although in
a different order).
* Change the triemap used for grouping by a label list
from `(TM.ListMap UniqDFM)` to `ListMap (GenMap LabelMap)`.
* Using GenMap offers leaf compression. Which is a trie
optimization described by the Note [Compressed TrieMap] in
CoreSyn/TrieMap.hs
* Using LabelMap removes the overhead associated with UniqDFM.
This is deterministic since if we have the same input keys the same
LabelMap will be constructed.
Test Plan: ci, profiling output
Reviewers: bgamari, simonmar
Reviewed By: bgamari
Subscribers: dfeuer, thomie, carter
GHC Trac Issues: #15103
Differential Revision: https://phabricator.haskell.org/D4597
>---------------------------------------------------------------
bd43378dfba1d6c5f19246b972b761640eedb35c
compiler/cmm/CmmCommonBlockElim.hs | 42 +++++++++++++++++++++++---------------
compiler/cmm/Hoopl/Label.hs | 10 +++++++++
compiler/coreSyn/CoreMap.hs | 2 ++
3 files changed, 37 insertions(+), 17 deletions(-)
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index fc4fcab..1af9a84 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE GADTs, BangPatterns #-}
+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+
module CmmCommonBlockElim
( elimCommonBlocks
)
@@ -24,9 +25,8 @@ import qualified Data.List as List
import Data.Word
import qualified Data.Map as M
import Outputable
-import UniqFM
-import UniqDFM
import qualified TrieMap as TM
+import UniqFM
import Unique
import Control.Arrow (first, second)
import Data.List (foldl')
@@ -64,9 +64,11 @@ elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = replaceLabels env $ copyTicks env g
where
env = iterate mapEmpty blocks_with_key
- -- The order of blocks doesn't matter here, but revPostorder also drops any
- -- unreachable blocks, which is useful.
- groups = groupByInt hash_block (revPostorder g)
+ -- The order of blocks doesn't matter here. While we could use
+ -- revPostorder which drops unreachable blocks this is done in
+ -- ContFlowOpt already which runs before this pass. So we use
+ -- toBlockList since it is faster.
+ groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
-- Invariant: The blocks in the list are pairwise distinct
@@ -94,6 +96,8 @@ iterate subst blocks
subst' = subst `mapUnion` new_substs
updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
+-- Combine two lists of blocks.
+-- While they are internally distinct they can still share common blocks.
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks subst existing new = go new
where
@@ -298,17 +302,21 @@ copyTicks env g
foldr blockCons code (map CmmTick ticks)
-- Group by [Label]
-groupByLabel :: [(Key, a)] -> [(Key, [a])]
-groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)
- where
- go !m [] = TM.foldTM (:) m []
- go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries
- where k' = map getUnique k
- adjust Nothing = Just (k,[v])
- adjust (Just (_,vs)) = Just (k,v:vs)
-
+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
+groupByLabel =
+ go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
+ where
+ go !m [] = TM.foldTM (:) m []
+ go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
+ where --k' = map (getKey . getUnique) k
+ adjust Nothing = Just (k,[v])
+ adjust (Just (_,vs)) = Just (k,v:vs)
groupByInt :: (a -> Int) -> [a] -> [[a]]
groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
- -- See Note [Unique Determinism and code generation]
- where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)
+ -- See Note [Unique Determinism and code generation]
+ where
+ go m x = alterUFM addEntry m (f x)
+ where
+ addEntry xs = Just $! maybe [x] (x:) xs
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
index caed683..7fddbf4 100644
--- a/compiler/cmm/Hoopl/Label.hs
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -21,6 +21,8 @@ import Outputable
import Hoopl.Collections
import Unique (Uniquable(..))
+import TrieMap
+
-----------------------------------------------------------------------------
-- Label
@@ -120,6 +122,14 @@ instance Outputable LabelSet where
instance Outputable a => Outputable (LabelMap a) where
ppr = ppr . mapToList
+instance TrieMap LabelMap where
+ type Key LabelMap = Label
+ emptyTM = mapEmpty
+ lookupTM k m = mapLookup k m
+ alterTM k f m = mapAlter f k m
+ foldTM k m z = mapFoldr k z m
+ mapTM f m = mapMap f m
+
-----------------------------------------------------------------------------
-- FactBase
diff --git a/compiler/coreSyn/CoreMap.hs b/compiler/coreSyn/CoreMap.hs
index dc30bed..73c6995 100644
--- a/compiler/coreSyn/CoreMap.hs
+++ b/compiler/coreSyn/CoreMap.hs
@@ -24,6 +24,8 @@ module CoreMap(
ListMap,
-- * Maps over 'Literal's
LiteralMap,
+ -- * Map for compressing leaves. See Note [Compressed TrieMap]
+ GenMap,
-- * 'TrieMap' class
TrieMap(..), insertTM, deleteTM,
lkDFreeVar, xtDFreeVar,
More information about the ghc-commits
mailing list