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

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,