diff options
| -rw-r--r-- | compiler/cmm/CmmCommonBlockElim.hs | 42 | ||||
| -rw-r--r-- | compiler/cmm/Hoopl/Label.hs | 10 | ||||
| -rw-r--r-- | 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 fc4fcabcc3..1af9a84028 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 caed683151..7fddbf4c3f 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 dc30bed701..73c69952fa 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, |