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