2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
6 module CmmCommonBlockElim
15 import Prelude hiding (iterate, succ, unzip, zip)
19 import qualified Data.List as List
27 my_trace :: String -> SDoc -> a -> a
28 my_trace = if False then pprTrace else \_ _ a -> a
30 -- Eliminate common blocks:
31 -- If two blocks are identical except for the label on the first node,
32 -- then we can eliminate one of the blocks. To ensure that the semantics
33 -- of the program are preserved, we have to rewrite each predecessor of the
34 -- eliminated block to proceed with the block we keep.
36 -- The algorithm iterates over the blocks in the graph,
37 -- checking whether it has seen another block that is equal modulo labels.
38 -- If so, then it adds an entry in a map indicating that the new block
39 -- is made redundant by the old block.
40 -- Otherwise, it is added to the useful blocks.
42 -- TODO: Use optimization fuel
43 elimCommonBlocks :: CmmGraph -> CmmGraph
45 upd_graph g . snd $ iterate common_block reset hashed_blocks
47 where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
48 reset (_, subst) = (emptyUFM, subst)
50 -- Iterate over the blocks until convergence
51 iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
52 iterate upd reset blocks state =
53 case foldl upd' (False, state) blocks of
54 (True, state') -> iterate upd reset blocks (reset state')
55 (False, state') -> state'
56 where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
58 -- Try to find a block that is equal (or ``common'') to b.
59 type BidMap = BlockEnv BlockId
60 type State = (UniqFM [CmmBlock], BidMap)
61 common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
62 common_block (bmap, subst) (hash, b) =
63 case lookupUFM bmap hash of
64 Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
65 mapLookup bid subst) of
66 (Just b', Nothing) -> addSubst b'
67 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
68 _ -> (False, (addToUFM bmap hash (b : bs), subst))
69 Nothing -> (False, (addToUFM bmap hash [b], subst))
70 where bid = entryLabel b
71 addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
72 (True, (bmap, mapInsert bid (entryLabel b') subst))
74 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
75 upd_graph :: CmmGraph -> BidMap -> CmmGraph
76 upd_graph g subst = mapGraphNodes (id, middle, last) g
77 where middle = mapExpDeep exp
78 last l = last' (mapExpDeep exp l)
79 last' :: CmmNode O C -> CmmNode O C
80 last' (CmmBranch bid) = CmmBranch $ sub bid
81 last' (CmmCondBranch p t f) = cond p (sub t) (sub f)
82 last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
83 last' l@(CmmCall _ Nothing _ _ _) = l
84 last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
85 last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs
86 cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
87 exp (CmmStackSlot (CallArea (Young id)) off) =
88 CmmStackSlot (CallArea (Young (sub id))) off
89 exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
93 -- To speed up comparisons, we hash each basic block modulo labels.
94 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
95 -- but it should be fast and good enough.
96 hash_block :: CmmBlock -> Int
98 fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
99 -- UniqFM doesn't like negative Ints
100 where hash_fst _ h = h
101 hash_mid m h = hash_node m + h `shiftL` 1
102 hash_lst m h = hash_node m + h `shiftL` 1
104 hash_node :: CmmNode O x -> Word32
105 hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
106 hash_node (CmmAssign r e) = hash_reg r + hash_e e
107 hash_node (CmmStore e e') = hash_e e + hash_e e'
108 hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
109 hash_node (CmmBranch _) = 23 -- would be great to hash these properly
110 hash_node (CmmCondBranch p _ _) = hash_e p
111 hash_node (CmmCall e _ _ _ _) = hash_e e
112 hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
113 hash_node (CmmSwitch e _) = hash_e e
115 hash_reg :: CmmReg -> Word32
116 hash_reg (CmmLocal _) = 117
117 hash_reg (CmmGlobal _) = 19
119 hash_e :: CmmExpr -> Word32
120 hash_e (CmmLit l) = hash_lit l
121 hash_e (CmmLoad e _) = 67 + hash_e e
122 hash_e (CmmReg r) = hash_reg r
123 hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
124 hash_e (CmmRegOff r i) = hash_reg r + cvt i
125 hash_e (CmmStackSlot _ _) = 13
127 hash_lit :: CmmLit -> Word32
128 hash_lit (CmmInt i _) = fromInteger i
129 hash_lit (CmmFloat r _) = truncate r
130 hash_lit (CmmLabel _) = 119 -- ugh
131 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
132 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
133 hash_lit (CmmBlock _) = 191 -- ugh
134 hash_lit (CmmHighStackMark) = cvt 313
136 hash_tgt (ForeignTarget e _) = hash_e e
137 hash_tgt (PrimTarget _) = 31 -- lots of these
139 hash_list f = foldl (\z x -> f x + z) (0::Word32)
141 cvt = fromInteger . toInteger
142 -- Utilities: equality and substitution on the graph.
144 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
145 eqBid :: BidMap -> BlockId -> BlockId -> Bool
146 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
147 lookupBid :: BidMap -> BlockId -> BlockId
148 lookupBid subst bid = case mapLookup bid subst of
149 Just bid -> lookupBid subst bid
152 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
153 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
154 eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
155 where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
156 (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
158 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
159 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
160 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
161 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
162 eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
163 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
164 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
165 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
166 eqLastWith _ _ _ = False
168 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
169 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
171 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
172 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
173 eqMaybeWith _ Nothing Nothing = True
174 eqMaybeWith _ _ _ = False