Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / cmm / CmmContFlowOpt.hs
1 {-# LANGUAGE GADTs #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
3
4 module CmmContFlowOpt
5 ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
6 , branchChainElim, removeUnreachableBlocks, predMap
7 , replaceLabels, replaceBranches, runCmmContFlowOpts
8 )
9 where
10
11 import BlockId
12 import Cmm
13 import CmmUtils
14 import qualified OldCmm as Old
15
16 import Maybes
17 import Compiler.Hoopl
18 import Control.Monad
19 import Outputable
20 import Prelude hiding (succ, unzip, zip)
21 import Util
22
23 ------------------------------------
24 runCmmContFlowOpts :: CmmPgm -> CmmPgm
25 runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
26
27 oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
28 cmmCfgOpts :: CmmGraph -> CmmGraph
29
30 oldCmmCfgOpts = oldBranchChainElim -- boring, but will get more exciting later
31 cmmCfgOpts =
32 removeUnreachableBlocks . blockConcat . branchChainElim
33 -- Here branchChainElim can ultimately be replaced
34 -- with a more exciting combination of optimisations
35
36 runCmmOpts :: (g -> g) -> GenCmmPgm d h g -> GenCmmPgm d h g
37 -- Lifts a transformer on a single graph to one on the whole program
38 runCmmOpts opt = map (optProc opt)
39
40 optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
41 optProc _ top@(CmmData {}) = top
42 optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
43
44 ----------------------------------------------------------------
45 oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
46 -- If L is not captured in an instruction, we can remove any
47 -- basic block of the form L: goto L', and replace L with L' everywhere else.
48 -- How does L get captured? In a CallArea.
49 oldBranchChainElim (Old.ListGraph blocks)
50 | null lone_branch_blocks -- No blocks to remove
51 = Old.ListGraph blocks
52 | otherwise
53 = Old.ListGraph new_blocks
54 where
55 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
56 new_blocks = map (replaceLabels env) others
57 env = mkClosureBlockEnv lone_branch_blocks
58
59 isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
60 isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target)
61 isLoneBranch other_block = Right other_block
62 -- An infinite loop is not a link in a branch chain!
63
64 replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock
65 replaceLabels env (Old.BasicBlock id stmts)
66 = Old.BasicBlock id (map replace stmts)
67 where
68 replace (Old.CmmBranch id) = Old.CmmBranch (lookup id)
69 replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
70 replace (Old.CmmSwitch e tbl) = Old.CmmSwitch e (map (fmap lookup) tbl)
71 replace other_stmt = other_stmt
72
73 lookup id = mapLookup id env `orElse` id
74
75 ----------------------------------------------------------------
76 branchChainElim :: CmmGraph -> CmmGraph
77 -- Remove any basic block of the form L: goto L',
78 -- and replace L with L' everywhere else,
79 -- unless L is the successor of a call instruction and L'
80 -- is the entry block. You don't want to set the successor
81 -- of a function call to the entry block because there is no good way
82 -- to store both the infotables for the call and from the callee,
83 -- while putting the stack pointer in a consistent place.
84 --
85 -- JD isn't quite sure when it's safe to share continuations for different
86 -- function calls -- have to think about where the SP will be,
87 -- so we'll table that problem for now by leaving all call successors alone.
88 branchChainElim g
89 | null lone_branch_blocks -- No blocks to remove
90 = g
91 | otherwise
92 = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
93 where
94 blocks = toBlockList g
95 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
96 env = mkClosureBlockEnv lone_branch_blocks
97 self_branches =
98 let loop_to (id, _) =
99 if lookup id == id then
100 Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
101 else
102 Nothing
103 in mapMaybe loop_to lone_branch_blocks
104 lookup id = mapLookup id env `orElse` id
105
106 call_succs = foldl add emptyBlockSet blocks
107 where add :: BlockSet -> CmmBlock -> BlockSet
108 add succs b =
109 case lastNode b of
110 (CmmCall _ (Just k) _ _ _) -> setInsert k succs
111 (CmmForeignCall {succ=k}) -> setInsert k succs
112 _ -> succs
113 isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
114 isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
115 id /= target && not (setMember id call_succs)
116 = Left (id,target)
117 isLoneBranch other = Right other
118 -- An infinite loop is not a link in a branch chain!
119
120 maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
121 maybeReplaceLabels lpred env =
122 replace_eid . mapGraphNodes (id, middle, last)
123 where
124 replace_eid g = g {g_entry = lookup (g_entry g)}
125 lookup id = fmap lookup (mapLookup id env) `orElse` id
126
127 middle = mapExpDeep exp
128 last l = if lpred l then mapExpDeep exp (last' l) else l
129 last' :: CmmNode O C -> CmmNode O C
130 last' (CmmBranch bid) = CmmBranch (lookup bid)
131 last' (CmmCondBranch p t f) = CmmCondBranch p (lookup t) (lookup f)
132 last' (CmmSwitch e arms) = CmmSwitch e (map (liftM lookup) arms)
133 last' (CmmCall t k a res r) = CmmCall t (liftM lookup k) a res r
134 last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
135
136 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
137 exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
138 exp e = e
139
140
141 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
142 replaceLabels = maybeReplaceLabels (const True)
143
144 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
145 replaceBranches env g = mapGraphNodes (id, id, last) g
146 where
147 last :: CmmNode O C -> CmmNode O C
148 last (CmmBranch id) = CmmBranch (lookup id)
149 last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
150 last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
151 last l@(CmmCall {}) = l
152 last l@(CmmForeignCall {}) = l
153 lookup id = fmap lookup (mapLookup id env) `orElse` id
154
155 ----------------------------------------------------------------
156 -- Build a map from a block to its set of predecessors. Very useful.
157 predMap :: [CmmBlock] -> BlockEnv BlockSet
158 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
159 where add_preds block env = foldl (add (entryLabel block)) env (successors block)
160 add bid env b' =
161 mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
162 ----------------------------------------------------------------
163 -- If a block B branches to a label L, L is not the entry block,
164 -- and L has no other predecessors,
165 -- then we can splice the block starting with L onto the end of B.
166 -- Order matters, so we work bottom up (reverse postorder DFS).
167 -- This optimization can be inhibited by unreachable blocks, but
168 -- the reverse postorder DFS returns only reachable blocks.
169 --
170 -- To ensure correctness, we have to make sure that the BlockId of the block
171 -- we are about to eliminate is not named in another instruction.
172 --
173 -- Note: This optimization does _not_ subsume branch chain elimination.
174 blockConcat :: CmmGraph -> CmmGraph
175 blockConcat g@(CmmGraph {g_entry=eid}) =
176 replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
177 where blocks = postorderDfs g
178 (blocks', concatMap) =
179 foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
180 maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
181 maybe_concat b unchanged@(blocks', concatMap) =
182 let bid = entryLabel b
183 in case blockToNodeList b of
184 (JustC h, m, JustC (CmmBranch b')) ->
185 if canConcatWith b' then
186 (mapInsert bid (splice blocks' h m b') blocks',
187 mapInsert b' bid concatMap)
188 else unchanged
189 _ -> unchanged
190 num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
191 canConcatWith b' = b' /= eid && num_preds b' == 1
192 backEdges = predMap blocks
193 splice :: forall map n e x.
194 IsMap map =>
195 map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
196 splice blocks' h m bid' =
197 case mapLookup bid' blocks' of
198 Nothing -> panic "unknown successor block"
199 Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')
200 ----------------------------------------------------------------
201 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
202 mkClosureBlockEnv blocks = mapFromList $ map follow blocks
203 where singleEnv = mapFromList blocks :: BlockEnv BlockId
204 follow (id, next) = (id, endChain id next)
205 endChain orig id = case mapLookup id singleEnv of
206 Just id' | id /= orig -> endChain orig id'
207 _ -> id
208 ----------------------------------------------------------------
209 removeUnreachableBlocks :: CmmGraph -> CmmGraph
210 removeUnreachableBlocks g =
211 if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
212 else g
213 where blocks = postorderDfs g