X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCommonBlockElimZ.hs;h=df15845f1e0e0d2cf25c6ad46d023410897e0ac4;hp=97ec31d4bb0a90cb1a87be894b56768a62a90098;hb=e6243a818496aad82b6f47511d3bd9bc800f747d;hpb=0d80489c9b9f2421f65d8dd86c1e50c6bb429715 diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs index 97ec31d..df15845 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -5,14 +5,14 @@ where import BlockId -import Cmm hiding (blockId) import CmmExpr import Prelude hiding (iterate, zip, unzip) import ZipCfg import ZipCfgCmmRep +import Data.Bits +import Data.Word import FastString -import FiniteMap import List hiding (iterate) import Monad import Outputable @@ -20,7 +20,7 @@ import UniqFM import Unique my_trace :: String -> SDoc -> a -> a -my_trace = if True then pprTrace else \_ _ a -> a +my_trace = if False then pprTrace else \_ _ a -> a -- Eliminate common blocks: -- If two blocks are identical except for the label on the first node, @@ -37,7 +37,8 @@ my_trace = if True then pprTrace else \_ _ a -> a -- TODO: Use optimization fuel elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks g = - upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM) + 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)) reset (_, subst) = (emptyUFM, subst) @@ -50,87 +51,93 @@ iterate upd reset blocks state = where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes -- Try to find a block that is equal (or ``common'') to b. -type BidMap = FiniteMap BlockId BlockId +type BidMap = BlockEnv BlockId type State = (UniqFM [CmmBlock], BidMap) common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State) common_block (bmap, subst) (hash, b) = - case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of - Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of + case lookupUFM bmap hash of + Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, + lookupBlockEnv subst bid) of (Just b', Nothing) -> addSubst b' (Just b', Just b'') | blockId 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, addToFM subst bid (blockId b'))) + (True, (bmap, extendBlockEnv subst bid (blockId b'))) -- 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 m = m - last (LastBranch bid) = LastBranch $ sub bid - last (LastCondBranch p t f) = cond p (sub t) (sub f) - last (LastCall t bid) = LastCall t $ liftM sub bid - last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs - last l = l + 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) s u) = LastCall t (Just $ sub bid) s 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 + exp (CmmStackSlot (CallArea (Young id)) off) = + CmmStackSlot (CallArea (Young (sub id))) off + exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id)) + exp e = e sub = lookupBid subst -- To speed up comparisons, we hash each basic block modulo labels. -- 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) = hash_tail t 0 - where hash_mid (MidComment (FastString u _ _ _ _)) = u +hash_block (Block _ _ t) = + fromIntegral (hash_tail t (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 (MidUnsafeCall t _ as) = hash_tgt t + hash_as as - hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es - hash_mid (CopyIn _ fs _) = hash_fs fs - hash_mid (CopyOut _ as) = hash_as as + hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as + hash_reg :: CmmReg -> Word32 hash_reg (CmmLocal l) = hash_local l hash_reg (CmmGlobal _) = 19 - hash_local (LocalReg _ _ _) = 117 + 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 (CmmRegOff r i) = hash_reg r + i + 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 hash_lit (CmmLabel _) = 119 -- ugh - hash_lit (CmmLabelOff _ i) = 199 + i - hash_lit (CmmLabelDiffOff _ _ i) = 299 + i - hash_tgt (CmmCallee e _) = hash_e e - hash_tgt (CmmPrim _) = 31 -- lots of these - hash_as = hash_lst $ hash_kinded hash_e - hash_fs = hash_lst $ hash_kinded hash_local - hash_kinded f (CmmKinded x _) = f x - hash_lst f = foldl (\z x -> f x + z) 0 + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i + hash_lit (CmmBlock id) = 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 LastReturn = 17 -- better ideas? - hash_last (LastJump e) = hash_e e - hash_last (LastCall e _) = hash_e e + hash_last (LastCall e _ _ _) = hash_e e hash_last (LastSwitch e _) = hash_e e - hash_tail (ZLast LastExit) v = 29 + v * 2 - hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2) - hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2)) - + 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)) + cvt = fromInteger . toInteger -- Utilities: equality and substitution on the graph. -- Given a map ``subst'' from BlockID -> BlockID, we define equality. eqBid :: BidMap -> BlockId -> BlockId -> Bool eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' lookupBid :: BidMap -> BlockId -> BlockId -lookupBid subst bid = case lookupFM subst bid of +lookupBid subst bid = case lookupBlockEnv subst bid 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' +eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') = + sinfo == sinfo' && eqTailWith eqBid t t' type CmmTail = ZTail Middle Last eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool @@ -140,15 +147,13 @@ eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid eqTailWith _ _ _ = False eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool -eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid' -eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) = - eqBid (cml_true c) (cml_true c') && eqBid (cml_false c) (cml_false c') -eqLastWith _ LastReturn LastReturn = True -eqLastWith _ (LastJump e) (LastJump e') = e == e' -eqLastWith eqBid c@(LastCall _ _) c'@(LastCall _ _) = - cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') -eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') = - e == e' && eqLstWith (eqMaybeWith eqBid) bs bs' +eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) = + c1 == c2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2 +eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) = + e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2 eqLastWith _ _ _ = False eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool