Hoopl: remove dependency on Hoopl package
[ghc.git] / compiler / cmm / CmmCommonBlockElim.hs
index ad3c28d..3c23e70 100644 (file)
@@ -10,9 +10,13 @@ import Cmm
 import CmmUtils
 import CmmSwitch (eqSwitchTargetWith)
 import CmmContFlowOpt
 import CmmUtils
 import CmmSwitch (eqSwitchTargetWith)
 import CmmContFlowOpt
+-- import PprCmm ()
 import Prelude hiding (iterate, succ, unzip, zip)
 
 import Prelude hiding (iterate, succ, unzip, zip)
 
-import Hoopl hiding (ChangeFlag)
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
 import Data.Bits
 import Data.Maybe (mapMaybe)
 import qualified Data.List as List
 import Data.Bits
 import Data.Maybe (mapMaybe)
 import qualified Data.List as List
@@ -20,6 +24,8 @@ import Data.Word
 import qualified Data.Map as M
 import Outputable
 import UniqFM
 import qualified Data.Map as M
 import Outputable
 import UniqFM
+import UniqDFM
+import qualified TrieMap as TM
 import Unique
 import Control.Arrow (first, second)
 
 import Unique
 import Control.Arrow (first, second)
 
@@ -44,8 +50,8 @@ import Control.Arrow (first, second)
 -- The hash is invariant under relabeling, so we only ever compare within
 -- the same group of blocks.
 --
 -- 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.
+-- The list of outgoing labels is updated as we merge blocks (that is why they
+-- are not included in the hash, which we want to calculate only once).
 --
 -- 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
 --
 -- 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
@@ -56,14 +62,14 @@ elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
      env = iterate mapEmpty blocks_with_key
 elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
      env = iterate mapEmpty blocks_with_key
-     groups = groupBy hash_block (postorderDfs g)
+     groups = groupByInt hash_block (postorderDfs g)
      blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
 
 -- Invariant: The blocks in the list are pairwise distinct
 -- (so avoid comparing them again)
 type DistinctBlocks = [CmmBlock]
 type Key = [Label]
      blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
 
 -- Invariant: The blocks in the list are pairwise distinct
 -- (so avoid comparing them again)
 type DistinctBlocks = [CmmBlock]
 type Key = [Label]
-type Subst = BlockEnv BlockId
+type Subst = LabelMap BlockId
 
 -- The outer list groups by hash. We retain this grouping throughout.
 iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
 
 -- The outer list groups by hash. We retain this grouping throughout.
 iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
@@ -111,10 +117,14 @@ mergeBlockList subst (b:bs) = go mapEmpty b bs
 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
 -- and comparing blocks modulo a label mapping.
 
 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
 -- and comparing blocks modulo a label mapping.
 
--- To speed up comparisons, we hash each basic block modulo labels.
+-- To speed up comparisons, we hash each basic block modulo jump labels.
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
 
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
 
+-- We want to get as many small buckets as possible, as comparing blocks is
+-- expensive. So include as much as possible in the hash. Ideally everything
+-- that is compared with (==) in eqBlockBodyWith.
+
 type HashCode = Int
 
 hash_block :: CmmBlock -> HashCode
 type HashCode = Int
 
 hash_block :: CmmBlock -> HashCode
@@ -127,19 +137,18 @@ hash_block block =
 
         hash_node :: CmmNode O x -> Word32
         hash_node n | dont_care n = 0 -- don't care
 
         hash_node :: CmmNode O x -> Word32
         hash_node n | dont_care n = 0 -- don't care
-        hash_node (CmmUnwind _ e) = hash_e e
         hash_node (CmmAssign r e) = hash_reg r + hash_e e
         hash_node (CmmStore e e') = hash_e e + hash_e e'
         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
         hash_node (CmmBranch _) = 23 -- NB. ignore the label
         hash_node (CmmAssign r e) = hash_reg r + hash_e e
         hash_node (CmmStore e e') = hash_e e + hash_e e'
         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
         hash_node (CmmBranch _) = 23 -- NB. ignore the label
-        hash_node (CmmCondBranch p _ _) = hash_e p
+        hash_node (CmmCondBranch p _ _ _) = hash_e p
         hash_node (CmmCall e _ _ _ _ _) = hash_e e
         hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
         hash_node (CmmSwitch e _) = hash_e e
         hash_node _ = error "hash_node: unknown Cmm node!"
 
         hash_reg :: CmmReg -> Word32
         hash_node (CmmCall e _ _ _ _ _) = hash_e e
         hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
         hash_node (CmmSwitch e _) = hash_e e
         hash_node _ = error "hash_node: unknown Cmm node!"
 
         hash_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal _) = 117
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
         hash_reg   (CmmGlobal _)    = 19
 
         hash_e :: CmmExpr -> Word32
         hash_reg   (CmmGlobal _)    = 19
 
         hash_e :: CmmExpr -> Word32
@@ -167,18 +176,22 @@ hash_block block =
 
         cvt = fromInteger . toInteger
 
 
         cvt = fromInteger . toInteger
 
+        hash_unique :: Uniquable a => a -> Word32
+        hash_unique = cvt . getKey . getUnique
+
 -- | Ignore these node types for equality
 dont_care :: CmmNode O x -> Bool
 dont_care CmmComment {}  = True
 dont_care CmmTick {}     = True
 -- | Ignore these node types for equality
 dont_care :: CmmNode O x -> Bool
 dont_care CmmComment {}  = True
 dont_care CmmTick {}     = True
+dont_care CmmUnwind {}   = True
 dont_care _other         = False
 
 -- Utilities: equality and substitution on the graph.
 
 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
 dont_care _other         = False
 
 -- Utilities: equality and substitution on the graph.
 
 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
-eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
-lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
+lookupBid :: LabelMap BlockId -> BlockId -> BlockId
 lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
@@ -223,19 +236,24 @@ eqExprWith eqBid = eq
 -- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 eqBlockBodyWith eqBid block block'
 -- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 eqBlockBodyWith eqBid block block'
-  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
-    eqLastWith eqBid l l'
+  {-
+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
+  -}
+  = equal
   where (_,m,l)   = blockSplit block
         nodes     = filter (not . dont_care) (blockToList m)
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
   where (_,m,l)   = blockSplit block
         nodes     = filter (not . dont_care) (blockToList m)
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
+        equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
+                eqLastWith eqBid l l'
 
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
 
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
-eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
-  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
   t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
   t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
@@ -251,7 +269,7 @@ eqMaybeWith _ _ _ = False
 -- the same ticks as the respective "source" blocks. This not only
 -- means copying ticks, but also adjusting tick scopes where
 -- necessary.
 -- the same ticks as the respective "source" blocks. This not only
 -- means copying ticks, but also adjusting tick scopes where
 -- necessary.
-copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
 copyTicks env g
   | mapNull env = g
   | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
 copyTicks env g
   | mapNull env = g
   | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
@@ -272,47 +290,16 @@ copyTicks env g
 
 -- Group by [Label]
 groupByLabel :: [(Key, a)] -> [(Key, [a])]
 
 -- Group by [Label]
 groupByLabel :: [(Key, a)] -> [(Key, [a])]
-groupByLabel = go emptyILM
+groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)
   where
   where
-    go !m [] = elemsILM m
-    go !m ((k,v) : entries) = go (alterILM adjust m k') entries
+    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)
 
       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
 
 
+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)