Fix a bug in stack layout with safe foreign calls (#8083)
[ghc.git] / compiler / cmm / CmmCommonBlockElim.hs
1 {-# LANGUAGE GADTs #-}
2 module CmmCommonBlockElim
3 ( elimCommonBlocks
4 )
5 where
6
7
8 import BlockId
9 import Cmm
10 import CmmUtils
11 import CmmContFlowOpt
12 import Prelude hiding (iterate, succ, unzip, zip)
13
14 import Hoopl hiding (ChangeFlag)
15 import Data.Bits
16 import qualified Data.List as List
17 import Data.Word
18 import Outputable
19 import UniqFM
20
21 my_trace :: String -> SDoc -> a -> a
22 my_trace = if False then pprTrace else \_ _ a -> a
23
24 -- -----------------------------------------------------------------------------
25 -- Eliminate common blocks
26
27 -- If two blocks are identical except for the label on the first node,
28 -- then we can eliminate one of the blocks. To ensure that the semantics
29 -- of the program are preserved, we have to rewrite each predecessor of the
30 -- eliminated block to proceed with the block we keep.
31
32 -- The algorithm iterates over the blocks in the graph,
33 -- checking whether it has seen another block that is equal modulo labels.
34 -- If so, then it adds an entry in a map indicating that the new block
35 -- is made redundant by the old block.
36 -- Otherwise, it is added to the useful blocks.
37
38 -- TODO: Use optimization fuel
39 elimCommonBlocks :: CmmGraph -> CmmGraph
40 elimCommonBlocks g = replaceLabels env g
41 where
42 env = iterate hashed_blocks mapEmpty
43 hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
44
45 -- Iterate over the blocks until convergence
46 iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
47 iterate blocks subst =
48 case foldl common_block (False, emptyUFM, subst) blocks of
49 (changed, _, subst)
50 | changed -> iterate blocks subst
51 | otherwise -> subst
52
53 type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
54
55 type ChangeFlag = Bool
56 type HashCode = Int
57
58 -- Try to find a block that is equal (or ``common'') to b.
59 common_block :: State -> (HashCode, CmmBlock) -> State
60 common_block (old_change, bmap, subst) (hash, b) =
61 case lookupUFM bmap hash of
62 Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
63 mapLookup bid subst) of
64 (Just b', Nothing) -> addSubst b'
65 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
66 | otherwise -> (old_change, bmap, subst)
67 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
68 Nothing -> (old_change, addToUFM bmap hash [b], subst)
69 where bid = entryLabel b
70 addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $
71 (True, bmap, mapInsert bid (entryLabel b') subst)
72
73
74 -- -----------------------------------------------------------------------------
75 -- Hashing and equality on blocks
76
77 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
78 -- and comparing blocks modulo a label mapping.
79
80 -- To speed up comparisons, we hash each basic block modulo labels.
81 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
82 -- but it should be fast and good enough.
83 hash_block :: CmmBlock -> HashCode
84 hash_block block =
85 fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
86 -- UniqFM doesn't like negative Ints
87 where hash_fst _ h = h
88 hash_mid m h = hash_node m + h `shiftL` 1
89 hash_lst m h = hash_node m + h `shiftL` 1
90
91 hash_node :: CmmNode O x -> Word32
92 hash_node (CmmComment _) = 0 -- don't care
93 hash_node (CmmAssign r e) = hash_reg r + hash_e e
94 hash_node (CmmStore e e') = hash_e e + hash_e e'
95 hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
96 hash_node (CmmBranch _) = 23 -- NB. ignore the label
97 hash_node (CmmCondBranch p _ _) = hash_e p
98 hash_node (CmmCall e _ _ _ _ _) = hash_e e
99 hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
100 hash_node (CmmSwitch e _) = hash_e e
101
102 hash_reg :: CmmReg -> Word32
103 hash_reg (CmmLocal _) = 117
104 hash_reg (CmmGlobal _) = 19
105
106 hash_e :: CmmExpr -> Word32
107 hash_e (CmmLit l) = hash_lit l
108 hash_e (CmmLoad e _) = 67 + hash_e e
109 hash_e (CmmReg r) = hash_reg r
110 hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
111 hash_e (CmmRegOff r i) = hash_reg r + cvt i
112 hash_e (CmmStackSlot _ _) = 13
113
114 hash_lit :: CmmLit -> Word32
115 hash_lit (CmmInt i _) = fromInteger i
116 hash_lit (CmmFloat r _) = truncate r
117 hash_lit (CmmVec ls) = hash_list hash_lit ls
118 hash_lit (CmmLabel _) = 119 -- ugh
119 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
120 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
121 hash_lit (CmmBlock _) = 191 -- ugh
122 hash_lit (CmmHighStackMark) = cvt 313
123
124 hash_tgt (ForeignTarget e _) = hash_e e
125 hash_tgt (PrimTarget _) = 31 -- lots of these
126
127 hash_list f = foldl (\z x -> f x + z) (0::Word32)
128
129 cvt = fromInteger . toInteger
130 -- Utilities: equality and substitution on the graph.
131
132 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
133 eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
134 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
135 lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
136 lookupBid subst bid = case mapLookup bid subst of
137 Just bid -> lookupBid subst bid
138 Nothing -> bid
139
140 -- Middle nodes and expressions can contain BlockIds, in particular in
141 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
142 -- these.
143 --
144 eqMiddleWith :: (BlockId -> BlockId -> Bool)
145 -> CmmNode O O -> CmmNode O O -> Bool
146 eqMiddleWith _ (CmmComment _) (CmmComment _) = True
147 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
148 = r1 == r2 && eqExprWith eqBid e1 e2
149 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
150 = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
151 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
152 (CmmUnsafeForeignCall t2 r2 a2)
153 = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
154 eqMiddleWith _ _ _ = False
155
156 eqExprWith :: (BlockId -> BlockId -> Bool)
157 -> CmmExpr -> CmmExpr -> Bool
158 eqExprWith eqBid = eq
159 where
160 CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2
161 CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2
162 CmmReg r1 `eq` CmmReg r2 = r1==r2
163 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2
164 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
165 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
166 _e1 `eq` _e2 = False
167
168 xs `eqs` ys = and (zipWith eq xs ys)
169
170 eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
171 eqLit l1 l2 = l1 == l2
172
173 eqArea Old Old = True
174 eqArea (Young id1) (Young id2) = eqBid id1 id2
175 eqArea _ _ = False
176
177 -- Equality on the body of a block, modulo a function mapping block
178 -- IDs to block IDs.
179 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
180 eqBlockBodyWith eqBid block block'
181 = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
182 eqLastWith eqBid l l'
183 where (_,m,l) = blockSplit block
184 (_,m',l') = blockSplit block'
185
186
187
188 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
189 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
190 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
191 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
192 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
193 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
194 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
195 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
196 eqLastWith _ _ _ = False
197
198 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
199 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
200
201 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
202 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
203 eqMaybeWith _ Nothing Nothing = True
204 eqMaybeWith _ _ _ = False