cmm: Revert more aggressive CBE due to #14226

Trac #14226 noted that the C-- CBE pass frequently fails to
common up semantically identical blocks due to the differences in local
register naming. These patches fixed this by making the pass consider
equality up to alpha-renaming.

However, the new logic failed to consider the possibility that local
register naming *may* matter across multiple blocks. This lead to the
regression #14754. I'll need to do a bit of thinking on a proper
solution to this but in the meantime I'm reverting all four patches.

This reverts commit a27056f9823f8bbe2302f1924b3ab38fd6752e37.
This reverts commit 6f990c54f922beae80362fe62426beededc21290.
This reverts commit 9aa73892e10e90a1799b9277da593e816a827364.
This reverts commit 7920a7d9c53083b234e060a3e72f00b601a46808.

3 files changed, 86 insertions, 237 deletions

diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 26004fb9e7..2c889b382a 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -24,7 +24,6 @@ import qualified Data.List as List
 import Data.Word
 import qualified Data.Map as M
 import Outputable
-import DynFlags (DynFlags)
 import UniqFM
 import UniqDFM
 import qualified TrieMap as TM
@@ -60,11 +59,11 @@ import Control.Arrow (first, second)
 -- rightfully complained: #10397
 
 -- TODO: Use optimization fuel
-elimCommonBlocks :: DynFlags -> CmmGraph -> CmmGraph
-elimCommonBlocks dflags g = replaceLabels env $ copyTicks env g
+elimCommonBlocks :: CmmGraph -> CmmGraph
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
-     env = iterate dflags mapEmpty blocks_with_key
-     groups = groupByInt (hash_block dflags) (postorderDfs g)
+     env = iterate mapEmpty blocks_with_key
+     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
@@ -74,47 +73,42 @@ type Key = [Label]
 type Subst = LabelMap BlockId
 
 -- The outer list groups by hash. We retain this grouping throughout.
-iterate :: DynFlags -> Subst -> [[(Key, DistinctBlocks)]] -> Subst
-iterate dflags subst blocks
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
     | mapNull new_substs = subst
-    | otherwise = iterate dflags subst' updated_blocks
+    | otherwise = iterate subst' updated_blocks
   where
     grouped_blocks :: [[(Key, [DistinctBlocks])]]
     grouped_blocks = map groupByLabel blocks
 
     merged_blocks :: [[(Key, DistinctBlocks)]]
-    (new_substs, merged_blocks) =
-        List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+    (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 dflags subst dbs
+            (new_subst2, db) = mergeBlockList subst dbs
 
     subst' = subst `mapUnion` new_substs
     updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
 
-mergeBlocks :: DynFlags -> Subst
-            -> DistinctBlocks -> DistinctBlocks
-            -> (Subst, DistinctBlocks)
-mergeBlocks dflags subst existing new = go new
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
   where
     go [] = (mapEmpty, existing)
-    go (b:bs) =
-        case List.find (eqBlockBodyWith dflags (eqBid subst) b) existing of
-          -- This block is a duplicate. Drop it, and add it to the substitution
-          Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
-          -- This block is not a duplicate, keep it.
-          Nothing -> second (b:) $ go bs
-
-mergeBlockList :: DynFlags -> Subst -> [DistinctBlocks]
-               -> (Subst, DistinctBlocks)
-mergeBlockList _      _     [] = pprPanic "mergeBlockList" empty
-mergeBlockList dflags subst (b:bs) = go mapEmpty b bs
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
   where
     go !new_subst1 b [] = (new_subst1, b)
     go !new_subst1 b1 (b2:bs) = go new_subst b bs
       where
-        (new_subst2, b) =  mergeBlocks dflags subst b1 b2
+        (new_subst2, b) =  mergeBlocks subst b1 b2
         new_subst = new_subst1 `mapUnion` new_subst2
 
 
@@ -132,110 +126,39 @@ mergeBlockList dflags subst (b:bs) = go mapEmpty b bs
 -- expensive. So include as much as possible in the hash. Ideally everything
 -- that is compared with (==) in eqBlockBodyWith.
 
-{-
-Note [Equivalence up to local registers in CBE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-CBE treats two blocks which are equivalent up to alpha-renaming of locally-bound
-local registers as equivalent. This was not always the case (see #14226) but is
-quite important for effective CBE. For instance, consider the blocks,
-
-    c2VZ: // global
-        _c2Yd::I64 = _s2Se::I64 + 1;
-        _s2Sx::I64 = _c2Yd::I64;
-        _s2Se::I64 = _s2Sx::I64;
-        goto c2TE;
-
-    c2VY: // global
-        _c2Yb::I64 = _s2Se::I64 + 1;
-        _s2Sw::I64 = _c2Yb::I64;
-        _s2Se::I64 = _s2Sw::I64;
-        goto c2TE;
-
-These clearly implement precisely the same logic, differing only register
-naming. This happens quite often in the code produced by GHC.
-
-This alpha-equivalence relation must be accounted for in two places:
-
- 1. the block hash function (hash_block), which we use for approximate "binning"
- 2. the exact block comparison function, which computes pair-wise equivalence
-
-In (1) we maintain a de Bruijn numbering of each block's locally-bound local
-registers and compute the hash relative to this numbering.
-
-For (2) we maintain a substitution which maps the local registers of one block
-onto those of the other. We then compare local registers modulo this
-substitution.
-
--}
-
 type HashCode = Int
 
-type LocalRegEnv a = UniqFM a
-type DeBruijn = Int
-
--- | Maintains a de Bruijn numbering of local registers bound within a block.
---
--- See Note [Equivalence up to local registers in CBE]
-data HashEnv = HashEnv { localRegHashEnv :: !(LocalRegEnv DeBruijn)
-                       , nextIndex       :: !DeBruijn
-                       }
-
-hash_block :: DynFlags -> CmmBlock -> HashCode
-hash_block dflags block =
-  --pprTrace "hash_block" (ppr (entryLabel block) $$ ppr hash)
-  hash
-  where hash_fst _ (env, h) = (env, h)
-        hash_mid m (env, h) = let (env', h') = hash_node env m
-                              in (env', h' + h `shiftL` 1)
-        hash_lst m (env, h) = let (env', h') = hash_node env m
-                              in (env', h' + h `shiftL` 1)
-
-        hash =
-            let (_, raw_hash) =
-                    foldBlockNodesF3 (hash_fst, hash_mid, hash_lst)
-                                     block
-                                     (emptyEnv, 0 :: Word32)
-                emptyEnv = HashEnv mempty 0
-            in fromIntegral (raw_hash .&. (0x7fffffff :: Word32))
-               -- UniqFM doesn't like negative Ints
-
-        hash_node :: HashEnv -> CmmNode O x -> (HashEnv, Word32)
-        hash_node env n =
-            (env', hash)
-          where
-            hash =
-              case n of
-                n | dont_care n -> 0  -- don't care
-                -- don't include register as it is a binding occurrence
-                CmmAssign (CmmLocal _) e -> hash_e env e
-                CmmAssign r e   -> hash_reg env r + hash_e env e
-                CmmStore e e'   -> hash_e env e + hash_e env e'
-                CmmUnsafeForeignCall t _ as
-                                -> hash_tgt env t + hash_list (hash_e env) as
-                CmmBranch _     ->  23 -- NB. ignore the label
-                CmmCondBranch p _ _ _ -> hash_e env p
-                CmmCall e _ _ _ _ _   -> hash_e env e
-                CmmForeignCall t _ _ _ _ _ _ -> hash_tgt env t
-                CmmSwitch e _   -> hash_e env e
-                _               -> error "hash_node: unknown Cmm node!"
-            env' = foldLocalRegsDefd dflags (flip bind_local_reg) env n
-
-        hash_reg :: HashEnv -> CmmReg -> Word32
-        hash_reg env (CmmLocal localReg)
-          | Just idx <- lookupUFM (localRegHashEnv env) localReg
-          = fromIntegral idx
-          | otherwise
-          = hash_unique localReg -- important for performance, see #10397
-        hash_reg _  (CmmGlobal _)    = 19
-
-        hash_e :: HashEnv -> CmmExpr -> Word32
-        hash_e _   (CmmLit l) = hash_lit l
-        hash_e env (CmmLoad e _) = 67 + hash_e env e
-        hash_e env (CmmReg r) = hash_reg env r
-        hash_e env (CmmMachOp _ es) = hash_list (hash_e env) es -- pessimal - no operator check
-        hash_e env (CmmRegOff r i) = hash_reg env r + cvt i
-        hash_e _   (CmmStackSlot _ _) = 13
+hash_block :: CmmBlock -> HashCode
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
+  -- UniqFM doesn't like negative Ints
+  where hash_fst _ h = h
+        hash_mid m h = hash_node m + h `shiftL` 1
+        hash_lst m h = hash_node m + h `shiftL` 1
+
+        hash_node :: CmmNode O x -> Word32
+        hash_node n | dont_care n = 0 -- don't care
+        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 (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 localReg) = hash_unique localReg -- important for performance, see #10397
+        hash_reg   (CmmGlobal _)    = 19
+
+        hash_e :: CmmExpr -> Word32
+        hash_e (CmmLit l) = hash_lit l
+        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmReg r) = hash_reg r
+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
+        hash_e (CmmRegOff r i) = hash_reg r + cvt i
+        hash_e (CmmStackSlot _ _) = 13
 
         hash_lit :: CmmLit -> Word32
         hash_lit (CmmInt i _) = fromInteger i
@@ -247,21 +170,13 @@ hash_block dflags block =
         hash_lit (CmmBlock _) = 191 -- ugh
         hash_lit (CmmHighStackMark) = cvt 313
 
-        hash_tgt :: HashEnv -> ForeignTarget -> Word32
-        hash_tgt env (ForeignTarget e _) = hash_e env e
-        hash_tgt _   (PrimTarget _) = 31 -- lots of these
+        hash_tgt (ForeignTarget e _) = hash_e e
+        hash_tgt (PrimTarget _) = 31 -- lots of these
 
-        hash_list f = List.foldl' (\z x -> f x + z) (0::Word32)
+        hash_list f = foldl (\z x -> f x + z) (0::Word32)
 
         cvt = fromInteger . toInteger
 
-        bind_local_reg :: LocalReg -> HashEnv -> HashEnv
-        bind_local_reg reg env =
-            env { localRegHashEnv =
-                    addToUFM (localRegHashEnv env) reg (nextIndex env)
-                , nextIndex = nextIndex env + 1
-                }
-
         hash_unique :: Uniquable a => a -> Word32
         hash_unique = cvt . getKey . getUnique
 
@@ -282,76 +197,34 @@ lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
--- | Maps the local registers of one block to those of another
---
--- See Note [Equivalence up to local registers in CBE]
-type LocalRegMapping = LocalRegEnv LocalReg
-
 -- Middle nodes and expressions can contain BlockIds, in particular in
 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
 -- these.
 --
-eqMiddleWith :: DynFlags
-             -> (BlockId -> BlockId -> Bool)
-             -> LocalRegMapping
-             -> CmmNode O O -> CmmNode O O
-             -> (LocalRegMapping, Bool)
-eqMiddleWith dflags eqBid env a b =
-  case (a, b) of
-     -- registers aren't compared since they are binding occurrences
-    (CmmAssign (CmmLocal _) e1,  CmmAssign (CmmLocal _) e2) ->
-        let eq = eqExprWith eqBid env e1 e2
-        in (env', eq)
-
-    (CmmAssign r1 e1,  CmmAssign r2 e2) ->
-        let eq = r1 == r2
-              && eqExprWith eqBid env e1 e2
-        in (env', eq)
-
-    (CmmStore l1 r1,  CmmStore l2 r2) ->
-        let eq = eqExprWith eqBid env l1 l2
-              && eqExprWith eqBid env r1 r2
-        in (env', eq)
-
-     -- result registers aren't compared since they are binding occurrences
-    (CmmUnsafeForeignCall t1 _ a1,  CmmUnsafeForeignCall t2 _ a2) ->
-        let eq = t1 == t2
-              && eqLists (eqExprWith eqBid env) a1 a2
-        in (env', eq)
-
-    _ -> (env, False)
-  where
-    env' = List.foldl' (\acc (ra,rb) -> addToUFM acc ra rb) emptyUFM
-           $ List.zip defd_a defd_b
-    defd_a = foldLocalRegsDefd dflags (flip (:)) [] a
-    defd_b = foldLocalRegsDefd dflags (flip (:)) [] b
-
-eqLists :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-eqLists f (a:as) (b:bs) = f a b && eqLists f as bs
-eqLists _ []     []     = True
-eqLists _ _      _      = False
+eqMiddleWith :: (BlockId -> BlockId -> Bool)
+             -> CmmNode O O -> CmmNode O O -> Bool
+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
+  = r1 == r2 && eqExprWith eqBid e1 e2
+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)
+eqMiddleWith _ _ _ = False
 
 eqExprWith :: (BlockId -> BlockId -> Bool)
-           -> LocalRegMapping
-           -> CmmExpr -> CmmExpr
-           -> Bool
-eqExprWith eqBid env = eq
+           -> CmmExpr -> CmmExpr -> Bool
+eqExprWith eqBid = eq
  where
   CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
   CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
-  CmmReg r1          `eq` CmmReg r2          = r1 `eqReg` r2
-  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1 `eqReg` r2 && i1==i2
+  CmmReg r1          `eq` CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
   CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
   CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
   _e1                `eq` _e2                = False
 
-  xs `eqs` ys = eqLists eq xs ys
-
-  -- See Note [Equivalence up to local registers in CBE]
-  CmmLocal a `eqReg` CmmLocal b
-    | Just a' <- lookupUFM env a
-    = a' == b
-  a `eqReg` b = a == b
+  xs `eqs` ys = and (zipWith eq xs ys)
 
   eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
   eqLit l1 l2 = l1 == l2
@@ -362,10 +235,8 @@ eqExprWith eqBid env = eq
 
 -- Equality on the body of a block, modulo a function mapping block
 -- IDs to block IDs.
-eqBlockBodyWith :: DynFlags
-                -> (BlockId -> BlockId -> Bool)
-                -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith dflags eqBid block block'
+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
+eqBlockBodyWith eqBid block block'
   {-
   | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
   | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
@@ -376,40 +247,19 @@ eqBlockBodyWith dflags eqBid block block'
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
-        eqMids :: LocalRegMapping -> [CmmNode O O] -> [CmmNode O O] -> Bool
-        eqMids env (a:as) (b:bs)
-          | eq = eqMids env' as bs
-          where
-            (env', eq) = eqMiddleWith dflags eqBid env a b
-        eqMids env [] [] = eqLastWith eqBid env l l'
-        eqMids _ _ _ = False
-
-        equal = eqMids emptyUFM nodes nodes'
-
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> LocalRegMapping
-           -> CmmNode O C -> CmmNode O C -> Bool
-eqLastWith eqBid env a b =
-    case (a, b) of
-      (CmmBranch bid1, CmmBranch bid2) -> eqBid bid1 bid2
-      (CmmCondBranch c1 t1 f1 l1, CmmCondBranch c2 t2 f2 l2) ->
-          eqExprWith eqBid env c1 c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
-      (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
-      (CmmSwitch e1 ids1, CmmSwitch e2 ids2) ->
-          eqExprWith eqBid env e1 e2 && eqSwitchTargetWith eqBid ids1 ids2
-      -- result registers aren't compared since they are binding occurrences
-      (CmmForeignCall t1 _ a1 s1 ret_args1 ret_off1 intrbl1,
-       CmmForeignCall t2 _ a2 s2 ret_args2 ret_off2 intrbl2) ->
-             t1 == t2
-          && eqLists (eqExprWith eqBid env) a1 a2
-          && s1 == s2
-          && ret_args1 == ret_args2
-          && ret_off1 == ret_off2
-          && intrbl1 == intrbl2
-      _ -> False
+        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 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) =
+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
+eqLastWith _ _ _ = False
 
 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index b90b92a92f..4d109a4086 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -68,7 +68,7 @@ cpsTop hsc_env proc =
 
        ----------- Eliminate common blocks -------------------------------------
        g <- {-# SCC "elimCommonBlocks" #-}
-            condPass Opt_CmmElimCommonBlocks (elimCommonBlocks dflags) g
+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
                           Opt_D_dump_cmm_cbe "Post common block elimination"
 
        -- Any work storing block Labels must be performed _after_
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
index 4561fef199..c4ff1794e8 100644
--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -24,7 +24,6 @@ module Hoopl.Block
     , foldBlockNodesB
     , foldBlockNodesB3
     , foldBlockNodesF
-    , foldBlockNodesF3
     , isEmptyBlock
     , lastNode
     , mapBlock