More codegen refactoring with simonpj
[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 -- -----------------------------------------------------------------------------
32 -- Eliminate common blocks
33
34 -- If two blocks are identical except for the label on the first node,
35 -- then we can eliminate one of the blocks. To ensure that the semantics
36 -- of the program are preserved, we have to rewrite each predecessor of the
37 -- eliminated block to proceed with the block we keep.
38
39 -- The algorithm iterates over the blocks in the graph,
40 -- checking whether it has seen another block that is equal modulo labels.
41 -- If so, then it adds an entry in a map indicating that the new block
42 -- is made redundant by the old block.
43 -- Otherwise, it is added to the useful blocks.
44
45 -- TODO: Use optimization fuel
46 elimCommonBlocks :: CmmGraph -> CmmGraph
47 elimCommonBlocks g = replaceLabels env g
48 where
49 env = iterate hashed_blocks mapEmpty
50 hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
51
52 -- Iterate over the blocks until convergence
53 iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
54 iterate blocks subst =
55 case foldl common_block (False, emptyUFM, subst) blocks of
56 (changed, _, subst)
57 | changed -> iterate blocks subst
58 | otherwise -> subst
59
60 type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
61
62 type ChangeFlag = Bool
63 type HashCode = Int
64
65 -- Try to find a block that is equal (or ``common'') to b.
66 common_block :: State -> (HashCode, CmmBlock) -> State
67 common_block (old_change, bmap, subst) (hash, b) =
68 case lookupUFM bmap hash of
69 Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
70 mapLookup bid subst) of
71 (Just b', Nothing) -> addSubst b'
72 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
73 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
74 Nothing -> (old_change, (addToUFM bmap hash [b], subst))
75 where bid = entryLabel b
76 addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
77 (True, bmap, mapInsert bid (entryLabel b') subst)
78
79
80 -- -----------------------------------------------------------------------------
81 -- Hashing and equality on blocks
82
83 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
84 -- and comparing blocks modulo a label mapping.
85
86 -- To speed up comparisons, we hash each basic block modulo labels.
87 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
88 -- but it should be fast and good enough.
89 hash_block :: CmmBlock -> HashCode
90 hash_block block =
91 fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
92 -- UniqFM doesn't like negative Ints
93 where hash_fst _ h = h
94 hash_mid m h = hash_node m + h `shiftL` 1
95 hash_lst m h = hash_node m + h `shiftL` 1
96
97 hash_node :: CmmNode O x -> Word32
98 hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
99 hash_node (CmmAssign r e) = hash_reg r + hash_e e
100 hash_node (CmmStore e e') = hash_e e + hash_e e'
101 hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
102 hash_node (CmmBranch _) = 23 -- NB. ignore the label
103 hash_node (CmmCondBranch p _ _) = hash_e p
104 hash_node (CmmCall e _ _ _ _) = hash_e e
105 hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
106 hash_node (CmmSwitch e _) = hash_e e
107
108 hash_reg :: CmmReg -> Word32
109 hash_reg (CmmLocal _) = 117
110 hash_reg (CmmGlobal _) = 19
111
112 hash_e :: CmmExpr -> Word32
113 hash_e (CmmLit l) = hash_lit l
114 hash_e (CmmLoad e _) = 67 + hash_e e
115 hash_e (CmmReg r) = hash_reg r
116 hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
117 hash_e (CmmRegOff r i) = hash_reg r + cvt i
118 hash_e (CmmStackSlot _ _) = 13
119
120 hash_lit :: CmmLit -> Word32
121 hash_lit (CmmInt i _) = fromInteger i
122 hash_lit (CmmFloat r _) = truncate r
123 hash_lit (CmmLabel _) = 119 -- ugh
124 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
125 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
126 hash_lit (CmmBlock _) = 191 -- ugh
127 hash_lit (CmmHighStackMark) = cvt 313
128
129 hash_tgt (ForeignTarget e _) = hash_e e
130 hash_tgt (PrimTarget _) = 31 -- lots of these
131
132 hash_list f = foldl (\z x -> f x + z) (0::Word32)
133
134 cvt = fromInteger . toInteger
135 -- Utilities: equality and substitution on the graph.
136
137 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
138 eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
139 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
140 lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
141 lookupBid subst bid = case mapLookup bid subst of
142 Just bid -> lookupBid subst bid
143 Nothing -> bid
144
145 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
146 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
147 eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
148 where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
149 (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
150
151 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
152 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
153 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
154 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
155 eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
156 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
157 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
158 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
159 eqLastWith _ _ _ = False
160
161 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
162 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
163
164 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
165 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
166 eqMaybeWith _ Nothing Nothing = True
167 eqMaybeWith _ _ _ = False