Merge branch 'master' into type-nats
[ghc.git] / compiler / cmm / CmmCommonBlockElim.hs
1 {-# LANGUAGE GADTs #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
3 -- ToDo: remove
4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
5
6 module CmmCommonBlockElim
7 ( elimCommonBlocks
8 )
9 where
10
11
12 import BlockId
13 import Cmm
14 import CmmExpr
15 import Prelude hiding (iterate, succ, unzip, zip)
16
17 import Compiler.Hoopl
18 import Data.Bits
19 import qualified Data.List as List
20 import Data.Word
21 import FastString
22 import Control.Monad
23 import Outputable
24 import UniqFM
25 import Unique
26
27 my_trace :: String -> SDoc -> a -> a
28 my_trace = if False then pprTrace else \_ _ a -> a
29
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.
35
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.
41
42 -- TODO: Use optimization fuel
43 elimCommonBlocks :: CmmGraph -> CmmGraph
44 elimCommonBlocks g =
45 upd_graph g . snd $ iterate common_block reset hashed_blocks
46 (emptyUFM, mapEmpty)
47 where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
48 reset (_, subst) = (emptyUFM, subst)
49
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
57
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))
73
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))
90 exp e = e
91 sub = lookupBid subst
92
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
97 hash_block block =
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
103
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
114
115 hash_reg :: CmmReg -> Word32
116 hash_reg (CmmLocal _) = 117
117 hash_reg (CmmGlobal _) = 19
118
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
126
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
135
136 hash_tgt (ForeignTarget e _) = hash_e e
137 hash_tgt (PrimTarget _) = 31 -- lots of these
138
139 hash_list f = foldl (\z x -> f x + z) (0::Word32)
140
141 cvt = fromInteger . toInteger
142 -- Utilities: equality and substitution on the graph.
143
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
150 Nothing -> bid
151
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'
157
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
167
168 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
169 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
170
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