X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCommonBlockElim.hs;fp=compiler%2Fcmm%2FCmmCommonBlockElimZ.hs;h=c0761fce6acd8fbe7d92d30bb363ba0aa1a5490a;hp=90e70080f2f54d5293d2b8e70b9fd420925256ae;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425

diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElim.hs
similarity index 57%
rename from compiler/cmm/CmmCommonBlockElimZ.hs
rename to compiler/cmm/CmmCommonBlockElim.hs
index 90e7008..c0761fc 100644
--- a/compiler/cmm/CmmCommonBlockElimZ.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -1,15 +1,20 @@
-module CmmCommonBlockElimZ
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+module CmmCommonBlockElim
   ( elimCommonBlocks
   )
 where
 
 
 import BlockId
+import Cmm
 import CmmExpr
-import Prelude hiding (iterate, zip, unzip)
-import ZipCfg
-import ZipCfgCmmRep
+import Prelude hiding (iterate, succ, unzip, zip)
 
+import Compiler.Hoopl
 import Data.Bits
 import qualified Data.List as List
 import Data.Word
@@ -38,8 +43,8 @@ my_trace = if False then pprTrace else \_ _ a -> a
 elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g =
     upd_graph g . snd $ iterate common_block reset hashed_blocks
-                                (emptyUFM, emptyBlockEnv)
-      where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
+                                (emptyUFM, mapEmpty)
+      where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
             reset (_, subst) = (emptyUFM, subst)
 
 -- Iterate over the blocks until convergence
@@ -57,26 +62,28 @@ common_block :: (Outputable h, Uniquable h) =>  State -> (h, CmmBlock) -> (Bool,
 common_block (bmap, subst) (hash, b) =
   case lookupUFM bmap hash of
     Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
-                     lookupBlockEnv subst bid) of
-                 (Just b', Nothing)                      -> addSubst b'
-                 (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
+                     mapLookup bid subst) of
+                 (Just b', Nothing)                         -> addSubst b'
+                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
                  _ -> (False, (addToUFM bmap hash (b : bs), subst))
     Nothing -> (False, (addToUFM bmap hash [b], subst))
-  where bid = blockId b
-        addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
-                      (True, (bmap, extendBlockEnv subst bid (blockId b')))
+  where bid = entryLabel b
+        addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
+                      (True, (bmap, mapInsert bid (entryLabel b') subst))
 
 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
 upd_graph :: CmmGraph -> BidMap -> CmmGraph
-upd_graph g subst = map_nodes id middle last g
-  where middle = mapExpDeepMiddle exp
-        last l = last' (mapExpDeepLast exp l)
-        last' (LastBranch bid)            = LastBranch $ sub bid
-        last' (LastCondBranch p t f)      = cond p (sub t) (sub f)
-        last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u
-        last' l@(LastCall _ Nothing _ _ _)  = l
-        last' (LastSwitch e bs)           = LastSwitch e $ map (liftM sub) bs
-        cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+upd_graph g subst = mapGraphNodes (id, middle, last) g
+  where middle = mapExpDeep exp
+        last l = last' (mapExpDeep exp l)
+        last' :: CmmNode O C -> CmmNode O C
+        last' (CmmBranch bid)              = CmmBranch $ sub bid
+        last' (CmmCondBranch p t f)        = cond p (sub t) (sub f)
+        last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
+        last' l@(CmmCall _ Nothing _ _ _)  = l
+        last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
+        last' (CmmSwitch e bs)             = CmmSwitch e $ map (liftM sub) bs
+        cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
         exp (CmmStackSlot (CallArea (Young id))       off) =
              CmmStackSlot (CallArea (Young (sub id))) off
         exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
@@ -87,24 +94,36 @@ upd_graph g subst = map_nodes id middle last g
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
 hash_block :: CmmBlock -> Int
-hash_block (Block _ t) =
-  fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
   -- UniqFM doesn't like negative Ints
-  where hash_mid   (MidComment (FastString u _ _ _ _)) = cvt u
-        hash_mid   (MidAssign r e) = hash_reg r + hash_e e
-        hash_mid   (MidStore e e') = hash_e e + hash_e e'
-        hash_mid   (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
+  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 (CmmComment (FastString u _ _ _ _)) = cvt u
+        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 -- would be great to hash these properly
+        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_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal l) = hash_local l
+        hash_reg   (CmmLocal _) = 117
         hash_reg   (CmmGlobal _)    = 19
-        hash_local (LocalReg _ _) = 117
+
         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_lst hash_e es -- pessimal - no operator check
+        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
         hash_lit (CmmFloat r _) = truncate r
@@ -113,16 +132,12 @@ hash_block (Block _ t) =
         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_lst f = foldl (\z x -> f x + z) (0::Word32)
-        hash_last (LastBranch _) = 23 -- would be great to hash these properly
-        hash_last (LastCondBranch p _ _) = hash_e p 
-        hash_last (LastCall e _ _ _ _) = hash_e e
-        hash_last (LastSwitch e _) = hash_e e
-        hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
-        hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
-        hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
+
+        hash_list f = foldl (\z x -> f x + z) (0::Word32)
+
         cvt = fromInteger . toInteger
 -- Utilities: equality and substitution on the graph.
 
@@ -130,33 +145,28 @@ hash_block (Block _ t) =
 eqBid :: BidMap -> BlockId -> BlockId -> Bool
 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
 lookupBid :: BidMap -> BlockId -> BlockId
-lookupBid subst bid = case lookupBlockEnv subst bid of
+lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
-
-type CmmTail = ZTail Middle Last
-eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
-eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
-eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
-eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
-eqTailWith _ _ _ = False
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
-eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
-eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
+eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
+  where (_, middles , JustC last  :: MaybeC C (CmmNode O C)) = blockToNodeList block
+        (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
+
+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 (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
+eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
   t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
-eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
-  e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
+eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
+  e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
 eqLastWith _ _ _ = False
 
-eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
 
 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'