Big collection of patches for the new codegen branch.
[ghc.git] / compiler / cmm / CmmContFlowOpt.hs
1
2 module CmmContFlowOpt
3 ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
4 , branchChainElimZ, removeUnreachableBlocksZ, predMap
5 , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
6 )
7 where
8
9 import BlockId
10 import Cmm
11 import CmmTx
12 import qualified ZipCfg as G
13 import ZipCfg
14 import ZipCfgCmmRep
15
16 import Maybes
17 import Monad
18 import Outputable
19 import Panic
20 import Prelude hiding (unzip, zip)
21 import Util
22
23 ------------------------------------
24 runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
25 runCmmContFlowOptsZs prog
26 = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top
27 | cmm_top <- prog ]
28
29 cmmCfgOpts :: Tx (ListGraph CmmStmt)
30 cmmCfgOptsZ :: Tx CmmGraph
31
32 cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
33 cmmCfgOptsZ g =
34 (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
35 -- Here branchChainElim can ultimately be replaced
36 -- with a more exciting combination of optimisations
37
38 runCmmOpts :: Tx g -> Tx (GenCmm d h g)
39 runCmmOpts opt = mapProcs (optGraph opt)
40
41 optGraph :: Tx g -> Tx (GenCmmTop d h g)
42 optGraph _ top@(CmmData {}) = noTx top
43 optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
44
45 ------------------------------------
46 mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
47 mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
48
49 ----------------------------------------------------------------
50 branchChainElim :: Tx (ListGraph CmmStmt)
51 -- If L is not captured in an instruction, we can remove any
52 -- basic block of the form L: goto L', and replace L with L' everywhere else.
53 -- How does L get captured? In a CallArea.
54 branchChainElim (ListGraph blocks)
55 | null lone_branch_blocks -- No blocks to remove
56 = noTx (ListGraph blocks)
57 | otherwise
58 = aTx (ListGraph new_blocks)
59 where
60 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
61 new_blocks = map (replaceLabels env) others
62 env = mkClosureBlockEnv lone_branch_blocks
63
64 isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
65 isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
66 isLoneBranch other_block = Right other_block
67 -- An infinite loop is not a link in a branch chain!
68
69 replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
70 replaceLabels env (BasicBlock id stmts)
71 = BasicBlock id (map replace stmts)
72 where
73 replace (CmmBranch id) = CmmBranch (lookup id)
74 replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
75 replace (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
76 replace other_stmt = other_stmt
77
78 lookup id = lookupBlockEnv env id `orElse` id
79 ----------------------------------------------------------------
80 branchChainElimZ :: Tx CmmGraph
81 -- Remove any basic block of the form L: goto L',
82 -- and replace L with L' everywhere else
83 branchChainElimZ g@(G.LGraph eid args _)
84 | null lone_branch_blocks -- No blocks to remove
85 = noTx g
86 | otherwise
87 = aTx $ replaceLabelsZ env $ G.of_block_list eid args (self_branches ++ others)
88 where
89 (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
90 env = mkClosureBlockEnvZ lone_branch_blocks
91 self_branches =
92 let loop_to (id, _) =
93 if lookup id == id then
94 Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id)))
95 else
96 Nothing
97 in mapMaybe loop_to lone_branch_blocks
98 lookup id = lookupBlockEnv env id `orElse` id
99
100 -- Be careful not to mark a block as a lone branch if it carries
101 -- important information about incoming arguments or the update frame.
102 isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
103 isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing})
104 (G.ZLast (G.LastOther (LastBranch target))))
105 | id /= target = Left (id,target)
106 isLoneBranchZ other = Right other
107 -- An infinite loop is not a link in a branch chain!
108
109 replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
110 replaceLabelsZ env = replace_eid . G.map_nodes id middle last
111 where
112 replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks
113 middle = mapExpDeepMiddle exp
114 last l = mapExpDeepLast exp (last' l)
115 last' (LastBranch bid) = LastBranch (lookup bid)
116 last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
117 last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
118 last' (LastCall t k a r) = LastCall t (liftM lookup k) a r
119 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
120 exp (CmmStackSlot (CallArea (Young id)) i) =
121 CmmStackSlot (CallArea (Young (lookup id))) i
122 exp e = e
123 lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
124
125 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
126 replaceBranches env g = map_nodes id id last g
127 where
128 last (LastBranch id) = LastBranch (lookup id)
129 last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
130 last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
131 last l@(LastCall {}) = l
132 lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
133
134 ----------------------------------------------------------------
135 -- Build a map from a block to its set of predecessors. Very useful.
136 predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
137 predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
138 where add_preds b env = foldl (add b) env (G.succs b)
139 add (G.Block bid _ _) env b' =
140 extendBlockEnv env b' $
141 extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
142 ----------------------------------------------------------------
143 -- If a block B branches to a label L, and L has no other predecessors,
144 -- then we can splice the block starting with L onto the end of B.
145 -- Because this optmization can be inhibited by unreachable blocks,
146 -- we first take a pass to drops unreachable blocks.
147 -- Order matters, so we work bottom up (reverse postorder DFS).
148 --
149 -- To ensure correctness, we have to make sure that the BlockId of the block
150 -- we are about to eliminate is not named in another instruction.
151 --
152 -- Note: This optimization does _not_ subsume branch chain elimination.
153 blockConcatZ :: Tx CmmGraph
154 blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
155 blockConcatZ' :: Tx CmmGraph
156 blockConcatZ' g@(G.LGraph eid off blocks) =
157 tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
158 where (changed, blocks', concatMap) =
159 foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
160 maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
161 let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
162 in case G.goto_end $ G.unzip b of
163 (h, G.LastOther (LastBranch b')) ->
164 if canConcatWith b' then
165 (True, extendBlockEnv blocks' bid $ splice blocks' h b',
166 extendBlockEnv concatMap b' bid)
167 else unchanged
168 _ -> unchanged
169 num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
170 canConcatWith b' =
171 case lookupBlockEnv blocks b' of
172 Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1
173 _ -> False
174 backEdges = predMap g
175 splice blocks' h bid' =
176 case lookupBlockEnv blocks' bid' of
177 Just (G.Block _ (StackInfo {returnOff = Nothing}) t) ->
178 G.zip $ G.ZBlock h t
179 Just (G.Block _ _ _) ->
180 panic "trying to concatenate but successor block has incoming args"
181 Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks)
182 tx = if changed then aTx else noTx
183 ----------------------------------------------------------------
184 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
185 mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
186 where singleEnv = mkBlockEnv blocks
187 follow (id, next) = (id, endChain id next)
188 endChain orig id = case lookupBlockEnv singleEnv id of
189 Just id' | id /= orig -> endChain orig id'
190 _ -> id
191 mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId
192 mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
193 where singleEnv = mkBlockEnv blocks
194 follow (id, next) = (id, endChain id next)
195 endChain orig id = case lookupBlockEnv singleEnv id of
196 Just id' | id /= orig -> endChain orig id'
197 _ -> id
198 ----------------------------------------------------------------
199 removeUnreachableBlocksZ :: Tx CmmGraph
200 removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
201 if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks'
202 else noTx g
203 where blocks' = G.postorder_dfs g