diff options
Diffstat (limited to 'compiler/cmm/CmmCommonBlockElim.hs')
| -rw-r--r-- | compiler/cmm/CmmCommonBlockElim.hs | 63 |
1 files changed, 40 insertions, 23 deletions
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs index 3c23e70b8c..1af9a84028 100644 --- a/compiler/cmm/CmmCommonBlockElim.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE GADTs, BangPatterns #-} +{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-} + module CmmCommonBlockElim ( elimCommonBlocks ) where +import GhcPrelude hiding (iterate, succ, unzip, zip) + import BlockId import Cmm import CmmUtils import CmmSwitch (eqSwitchTargetWith) import CmmContFlowOpt -- import PprCmm () -import Prelude hiding (iterate, succ, unzip, zip) import Hoopl.Block import Hoopl.Graph @@ -23,11 +25,11 @@ 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') -- ----------------------------------------------------------------------------- -- Eliminate common blocks @@ -62,7 +64,11 @@ elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks g = replaceLabels env $ copyTicks env g where env = iterate mapEmpty blocks_with_key - groups = groupByInt hash_block (postorderDfs 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 @@ -90,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 @@ -165,14 +173,14 @@ hash_block block = hash_lit (CmmVec ls) = hash_list hash_lit ls hash_lit (CmmLabel _) = 119 -- ugh hash_lit (CmmLabelOff _ i) = cvt $ 199 + i - hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i + hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i hash_lit (CmmBlock _) = 191 -- ugh hash_lit (CmmHighStackMark) = cvt 313 hash_tgt (ForeignTarget e _) = hash_e e hash_tgt (PrimTarget _) = 31 -- lots of these - hash_list f = foldl (\z x -> f x + z) (0::Word32) + hash_list f = foldl' (\z x -> f x + z) (0::Word32) cvt = fromInteger . toInteger @@ -208,7 +216,7 @@ eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) (CmmUnsafeForeignCall t2 r2 a2) - = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2) + = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2 eqMiddleWith _ _ _ = False eqExprWith :: (BlockId -> BlockId -> Bool) @@ -223,7 +231,7 @@ eqExprWith eqBid = eq CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 _e1 `eq` _e2 = False - xs `eqs` ys = and (zipWith eq xs ys) + xs `eqs` ys = eqListWith eq xs ys eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 eqLit l1 l2 = l1 == l2 @@ -246,7 +254,7 @@ eqBlockBodyWith eqBid block block' (_,m',l') = blockSplit block' nodes' = filter (not . dont_care) (blockToList m') - equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') && + equal = eqListWith (eqMiddleWith eqBid) nodes nodes' && eqLastWith eqBid l l' @@ -265,6 +273,11 @@ eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' eqMaybeWith _ Nothing Nothing = True eqMaybeWith _ _ _ = False +eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool +eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs +eqListWith _ [] [] = True +eqListWith _ _ _ = False + -- | Given a block map, ensure that all "target" blocks are covered by -- the same ticks as the respective "source" blocks. This not only -- means copying ticks, but also adjusting tick scopes where @@ -275,8 +288,8 @@ copyTicks env g | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap where -- Reverse block merge map blockMap = toBlockMap g - revEnv = mapFoldWithKey insertRev M.empty env - insertRev k x = M.insertWith (const (k:)) x [k] + revEnv = mapFoldlWithKey insertRev M.empty env + insertRev m k x = M.insertWith (const (k:)) x [k] m -- Copy ticks and scopes into the given block copyTo block = case M.lookup (entryLabel block) revEnv of Nothing -> block @@ -289,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 |