Commit c2563572 authored by Joachim Breitner's avatar Joachim Breitner

Speed up elimCommonBlocks by grouping blocks also by outgoing labels

This is an attempt to improve the situation described in #10397, where
the linear scan of possible candidates for commoning up is far too
expensive. There is (ever) more room for improvement, but this is a
start.

Differential Revision: https://phabricator.haskell.org/D892
parent ab45de12
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs, BangPatterns #-}
module CmmCommonBlockElim module CmmCommonBlockElim
( elimCommonBlocks ( elimCommonBlocks
) )
...@@ -20,9 +20,8 @@ import Data.Word ...@@ -20,9 +20,8 @@ import Data.Word
import qualified Data.Map as M import qualified Data.Map as M
import Outputable import Outputable
import UniqFM import UniqFM
import Unique
my_trace :: String -> SDoc -> a -> a import Control.Arrow (first, second)
my_trace = if False then pprTrace else \_ _ a -> a
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Eliminate common blocks -- Eliminate common blocks
...@@ -38,40 +37,72 @@ my_trace = if False then pprTrace else \_ _ a -> a ...@@ -38,40 +37,72 @@ my_trace = if False then pprTrace else \_ _ a -> a
-- is made redundant by the old block. -- is made redundant by the old block.
-- Otherwise, it is added to the useful blocks. -- Otherwise, it is added to the useful blocks.
-- To avoid comparing every block with every other block repeatedly, we group
-- them by
-- * a hash of the block, ignoring labels (explained below)
-- * the list of outgoing labels
-- The hash is invariant under relabeling, so we only ever compare within
-- the same group of blocks.
--
-- The list of outgoing labels is updated as we merge blocks, and only blocks
-- that had different labels before are compared.
--
-- All in all, two blocks should never be compared if they have different
-- hashes, and at most once otherwise. Previously, we were slower, and people
-- rightfully complained: #10397
-- TODO: Use optimization fuel -- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = replaceLabels env $ copyTicks env g elimCommonBlocks g = replaceLabels env $ copyTicks env g
where where
env = iterate hashed_blocks mapEmpty env = iterate mapEmpty blocks_with_key
hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g groups = groupBy hash_block (postorderDfs g)
blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
-- Iterate over the blocks until convergence
iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId -- Invariant: The blocks in the list are pairwise distinct
iterate blocks subst = -- (so avoid comparing them again)
case foldl common_block (False, emptyUFM, subst) blocks of type DistinctBlocks = [CmmBlock]
(changed, _, subst) type Key = [Label]
| changed -> iterate blocks subst type Subst = BlockEnv BlockId
| otherwise -> subst
-- The outer list groups by hash. We retain this grouping throughout.
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
iterate subst blocks
| mapNull new_substs = subst
| otherwise = iterate subst' updated_blocks
where
grouped_blocks :: [[(Key, [DistinctBlocks])]]
grouped_blocks = map groupByLabel blocks
type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId) merged_blocks :: [[(Key, DistinctBlocks)]]
(new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
where
go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
where
(new_subst2, db) = mergeBlockList subst dbs
type ChangeFlag = Bool subst' = subst `mapUnion` new_substs
type HashCode = Int updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
-- Try to find a block that is equal (or ``common'') to b. mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
common_block :: State -> (HashCode, CmmBlock) -> State mergeBlocks subst existing new = go new
common_block (old_change, bmap, subst) (hash, b) = where
case lookupUFM bmap hash of go [] = (mapEmpty, existing)
Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs, go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
mapLookup bid subst) of -- This block is a duplicate. Drop it, and add it to the substitution
(Just b', Nothing) -> addSubst b' Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
(Just b', Just b'') | entryLabel b' /= b'' -> addSubst b' -- This block is not a duplicate, keep it.
| otherwise -> (old_change, bmap, subst) Nothing -> second (b:) $ go bs
_ -> (old_change, addToUFM bmap hash (b : bs), subst)
Nothing -> (old_change, addToUFM bmap hash [b], subst) mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
where bid = entryLabel b mergeBlockList _ [] = pprPanic "mergeBlockList" empty
addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $ mergeBlockList subst (b:bs) = go mapEmpty b bs
(True, bmap, mapInsert bid (entryLabel b') subst) where
go !new_subst1 b [] = (new_subst1, b)
go !new_subst1 b1 (b2:bs) = go new_subst b bs
where
(new_subst2, b) = mergeBlocks subst b1 b2
new_subst = new_subst1 `mapUnion` new_subst2
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -83,6 +114,9 @@ common_block (old_change, bmap, subst) (hash, b) = ...@@ -83,6 +114,9 @@ common_block (old_change, bmap, subst) (hash, b) =
-- To speed up comparisons, we hash each basic block modulo labels. -- To speed up comparisons, we hash each basic block modulo labels.
-- The hashing is a bit arbitrary (the numbers are completely arbitrary), -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough. -- but it should be fast and good enough.
type HashCode = Int
hash_block :: CmmBlock -> HashCode hash_block :: CmmBlock -> HashCode
hash_block block = hash_block block =
fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
...@@ -235,3 +269,50 @@ copyTicks env g ...@@ -235,3 +269,50 @@ copyTicks env g
(CmmEntry lbl scp1, code) = blockSplitHead to (CmmEntry lbl scp1, code) = blockSplitHead to
in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
foldr blockCons code (map CmmTick ticks) foldr blockCons code (map CmmTick ticks)
-- Group by [Label]
groupByLabel :: [(Key, a)] -> [(Key, [a])]
groupByLabel = go emptyILM
where
go !m [] = elemsILM m
go !m ((k,v) : entries) = go (alterILM adjust m k') entries
where k' = map getUnique k
adjust Nothing = Just (k,[v])
adjust (Just (_,vs)) = Just (k,v:vs)
groupBy :: (a -> Int) -> [a] -> [[a]]
groupBy f xs = eltsUFM $ List.foldl' go emptyUFM xs
where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)
-- Efficient lookup into [([Unique], a)]
data IntListMap a = ILM (Maybe a) (UniqFM (IntListMap a))
emptyILM :: IntListMap a
emptyILM = ILM Nothing emptyUFM
unitILM :: [Unique] -> a -> IntListMap a
unitILM [] a = ILM (Just a) emptyUFM
unitILM (l:ls) a = ILM Nothing (unitUFM l (unitILM ls a))
alterILM :: (Maybe a -> Maybe a) -> IntListMap a -> [Unique] -> IntListMap a
alterILM f (ILM ma m) [] = ILM (f ma) m
alterILM f (ILM ma m) (l:ls) = ILM ma (alterUFM go m l)
where go Nothing = fmap (unitILM ls) (f Nothing)
go (Just ilm) = Just $ alterILM f ilm ls
{- currently unused
addToILM :: IntListMap a -> [Unique] -> a -> IntListMap a
addToILM (ILM _ m) [] a = ILM (Just a) m
addToILM (ILM ma m) (l:ls) a = ILM ma $ alterUFM go m l
where go Nothing = Just $ unitILM ls a
go (Just ilm) = Just $ addToILM ilm ls a
lookupILM :: IntListMap a -> [Unique] -> Maybe a
lookupILM (ILM ma _) [] = ma
lookupILM (ILM _ m) (l:ls) = lookupUFM m l >>= (\m -> lookupILM m ls)
-}
elemsILM :: IntListMap a -> [a]
elemsILM (ILM ma m) = maybe id (:) ma $ concatMap elemsILM $ eltsUFM m
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment