1 module CmmCommonBlockElimZ
9 import Prelude hiding (iterate, zip, unzip)
15 import List hiding (iterate)
21 my_trace :: String -> SDoc -> a -> a
22 my_trace = if True then pprTrace else \_ _ a -> a
24 -- Eliminate common blocks:
25 -- If two blocks are identical except for the label on the first node,
26 -- then we can eliminate one of the blocks. To ensure that the semantics
27 -- of the program are preserved, we have to rewrite each predecessor of the
28 -- eliminated block to proceed with the block we keep.
30 -- The algorithm iterates over the blocks in the graph,
31 -- checking whether it has seen another block that is equal modulo labels.
32 -- If so, then it adds an entry in a map indicating that the new block
33 -- is made redundant by the old block.
34 -- Otherwise, it is added to the useful blocks.
36 -- TODO: Use optimization fuel
37 elimCommonBlocks :: CmmGraph -> CmmGraph
39 upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM)
40 where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
41 reset (_, subst) = (emptyUFM, subst)
43 -- Iterate over the blocks until convergence
44 iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
45 iterate upd reset blocks state =
46 case foldl upd' (False, state) blocks of
47 (True, state') -> iterate upd reset blocks (reset state')
48 (False, state') -> state'
49 where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
51 -- Try to find a block that is equal (or ``common'') to b.
52 type BidMap = FiniteMap BlockId BlockId
53 type State = (UniqFM [CmmBlock], BidMap)
54 common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
55 common_block (bmap, subst) (hash, b) =
56 case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of
57 Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of
58 (Just b', Nothing) -> addSubst b'
59 (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
60 _ -> (False, (addToUFM bmap hash (b : bs), subst))
61 Nothing -> (False, (addToUFM bmap hash [b], subst))
63 addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
64 (True, (bmap, addToFM subst bid (blockId b')))
66 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
67 upd_graph :: CmmGraph -> BidMap -> CmmGraph
68 upd_graph g subst = map_nodes id middle last g
70 last (LastBranch bid) = LastBranch $ sub bid
71 last (LastCondBranch p t f) = cond p (sub t) (sub f)
72 last (LastCall t bid s) = LastCall t (liftM sub bid) s
73 last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
75 cond p t f = if t == f then LastBranch t else LastCondBranch p t f
78 -- To speed up comparisons, we hash each basic block modulo labels.
79 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
80 -- but it should be fast and good enough.
81 hash_block :: CmmBlock -> Int
82 hash_block (Block _ _ t) = hash_tail t 0
83 where hash_mid (MidComment (FastString u _ _ _ _)) = u
84 hash_mid (MidAssign r e) = hash_reg r + hash_e e
85 hash_mid (MidStore e e') = hash_e e + hash_e e'
86 hash_mid (MidUnsafeCall t _ as) = hash_tgt t + hash_lst hash_e as
87 hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es
88 hash_reg (CmmLocal l) = hash_local l
89 hash_reg (CmmGlobal _) = 19
90 hash_local (LocalReg _ _) = 117
91 hash_e (CmmLit l) = hash_lit l
92 hash_e (CmmLoad e _) = 67 + hash_e e
93 hash_e (CmmReg r) = hash_reg r
94 hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
95 hash_e (CmmRegOff r i) = hash_reg r + i
96 hash_e (CmmStackSlot _ _) = 13
97 hash_lit (CmmInt i _) = fromInteger i
98 hash_lit (CmmFloat r _) = truncate r
99 hash_lit (CmmLabel _) = 119 -- ugh
100 hash_lit (CmmLabelOff _ i) = 199 + i
101 hash_lit (CmmLabelDiffOff _ _ i) = 299 + i
102 hash_tgt (ForeignTarget e _) = hash_e e
103 hash_tgt (PrimTarget _) = 31 -- lots of these
104 hash_lst f = foldl (\z x -> f x + z) (0::Int)
105 hash_last (LastBranch _) = 23 -- would be great to hash these properly
106 hash_last (LastCondBranch p _ _) = hash_e p
107 hash_last (LastReturn _) = 17 -- better ideas?
108 hash_last (LastJump e _) = hash_e e
109 hash_last (LastCall e _ _) = hash_e e
110 hash_last (LastSwitch e _) = hash_e e
111 hash_tail (ZLast LastExit) v = 29 + v * 2
112 hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2)
113 hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2))
115 -- Utilities: equality and substitution on the graph.
117 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
118 eqBid :: BidMap -> BlockId -> BlockId -> Bool
119 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
120 lookupBid :: BidMap -> BlockId -> BlockId
121 lookupBid subst bid = case lookupFM subst bid of
122 Just bid -> lookupBid subst bid
125 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
126 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
127 eqBlockBodyWith eqBid (Block _ Nothing t) (Block _ Nothing t') = eqTailWith eqBid t t'
128 eqBlockBodyWith _ _ _ = False
130 type CmmTail = ZTail Middle Last
131 eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
132 eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
133 eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
134 eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
135 eqTailWith _ _ _ = False
137 eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
138 eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid'
139 eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) =
140 eqBid (cml_true c) (cml_true c') && eqBid (cml_false c) (cml_false c')
141 eqLastWith _ (LastReturn s) (LastReturn s') = s == s'
142 eqLastWith _ (LastJump e s) (LastJump e' s') = e == e' && s == s'
143 eqLastWith eqBid c@(LastCall _ _ s) c'@(LastCall _ _ s') =
144 cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') &&
146 eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') =
147 e == e' && eqLstWith (eqMaybeWith eqBid) bs bs'
148 eqLastWith _ _ _ = False
150 eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
151 eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
153 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
154 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
155 eqMaybeWith _ Nothing Nothing = True
156 eqMaybeWith _ _ _ = False