Be more selective in which conditionals we invert
[ghc.git] / compiler / cmm / MkGraph.hs
1 {-# LANGUAGE BangPatterns, CPP, GADTs #-}
2
3 module MkGraph
4 ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
5 , (<*>), catAGraphs
6 , mkLabel, mkMiddle, mkLast, outOfLine
7 , lgraphOfAGraph, labelAGraph
8
9 , stackStubExpr
10 , mkNop, mkAssign, mkStore
11 , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
12 , mkJumpReturnsTo
13 , mkJump, mkJumpExtra
14 , mkRawJump
15 , mkCbranch, mkSwitch
16 , mkReturn, mkComment, mkCallEntry, mkBranch
17 , mkUnwind
18 , copyInOflow, copyOutOflow
19 , noExtraStack
20 , toCall, Transfer(..)
21 )
22 where
23
24 import GhcPrelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
25
26 import BlockId
27 import Cmm
28 import CmmCallConv
29 import CmmSwitch (SwitchTargets)
30
31 import Hoopl.Block
32 import Hoopl.Graph
33 import Hoopl.Label
34 import DynFlags
35 import FastString
36 import ForeignCall
37 import OrdList
38 import SMRep (ByteOff)
39 import UniqSupply
40
41 import Control.Monad
42 import Data.List
43 import Data.Maybe
44
45
46 -----------------------------------------------------------------------------
47 -- Building Graphs
48
49
50 -- | CmmAGraph is a chunk of code consisting of:
51 --
52 -- * ordinary statements (assignments, stores etc.)
53 -- * jumps
54 -- * labels
55 -- * out-of-line labelled blocks
56 --
57 -- The semantics is that control falls through labels and out-of-line
58 -- blocks. Everything after a jump up to the next label is by
59 -- definition unreachable code, and will be discarded.
60 --
61 -- Two CmmAGraphs can be stuck together with <*>, with the meaning that
62 -- control flows from the first to the second.
63 --
64 -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
65 -- by providing a label for the entry point and a tick scope; see
66 -- 'labelAGraph'.
67 type CmmAGraph = OrdList CgStmt
68 -- | Unlabeled graph with tick scope
69 type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
70
71 data CgStmt
72 = CgLabel BlockId CmmTickScope
73 | CgStmt (CmmNode O O)
74 | CgLast (CmmNode O C)
75 | CgFork BlockId CmmAGraph CmmTickScope
76
77 flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
78 flattenCmmAGraph id (stmts_t, tscope) =
79 CmmGraph { g_entry = id,
80 g_graph = GMany NothingO body NothingO }
81 where
82 body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
83
84 --
85 -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
86 --
87 -- NB. avoid the quadratic-append trap by passing in the tail of the
88 -- list. This is important for Very Long Functions (e.g. in T783).
89 --
90 flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
91 -> [Block CmmNode C C]
92 flatten id g tscope blocks
93 = flatten1 (fromOL g) block' blocks
94 where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
95 --
96 -- flatten0: we are outside a block at this point: any code before
97 -- the first label is unreachable, so just drop it.
98 --
99 flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
100 flatten0 [] blocks = blocks
101
102 flatten0 (CgLabel id tscope : stmts) blocks
103 = flatten1 stmts block blocks
104 where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
105
106 flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
107 = flatten fork_id stmts_t tscope $ flatten0 rest blocks
108
109 flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
110 flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
111
112 --
113 -- flatten1: we have a partial block, collect statements until the
114 -- next last node to make a block, then call flatten0 to get the rest
115 -- of the blocks
116 --
117 flatten1 :: [CgStmt] -> Block CmmNode C O
118 -> [Block CmmNode C C] -> [Block CmmNode C C]
119
120 -- The current block falls through to the end of a function or fork:
121 -- this code should not be reachable, but it may be referenced by
122 -- other code that is not reachable. We'll remove it later with
123 -- dead-code analysis, but for now we have to keep the graph
124 -- well-formed, so we terminate the block with a branch to the
125 -- beginning of the current block.
126 flatten1 [] block blocks
127 = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
128
129 flatten1 (CgLast stmt : stmts) block blocks
130 = block' : flatten0 stmts blocks
131 where !block' = blockJoinTail block stmt
132
133 flatten1 (CgStmt stmt : stmts) block blocks
134 = flatten1 stmts block' blocks
135 where !block' = blockSnoc block stmt
136
137 flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
138 = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
139
140 -- a label here means that we should start a new block, and the
141 -- current block should fall through to the new block.
142 flatten1 (CgLabel id tscp : stmts) block blocks
143 = blockJoinTail block (CmmBranch id) :
144 flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
145
146
147
148 ---------- AGraph manipulation
149
150 (<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
151 (<*>) = appOL
152
153 catAGraphs :: [CmmAGraph] -> CmmAGraph
154 catAGraphs = concatOL
155
156 -- | created a sequence "goto id; id:" as an AGraph
157 mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
158 mkLabel bid scp = unitOL (CgLabel bid scp)
159
160 -- | creates an open AGraph from a given node
161 mkMiddle :: CmmNode O O -> CmmAGraph
162 mkMiddle middle = unitOL (CgStmt middle)
163
164 -- | created a closed AGraph from a given node
165 mkLast :: CmmNode O C -> CmmAGraph
166 mkLast last = unitOL (CgLast last)
167
168 -- | A labelled code block; should end in a last node
169 outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
170 outOfLine l (c,s) = unitOL (CgFork l c s)
171
172 -- | allocate a fresh label for the entry point
173 lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
174 lgraphOfAGraph g = do
175 u <- getUniqueM
176 return (labelAGraph (mkBlockId u) g)
177
178 -- | use the given BlockId as the label of the entry point
179 labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
180 labelAGraph lbl ag = flattenCmmAGraph lbl ag
181
182 ---------- No-ops
183 mkNop :: CmmAGraph
184 mkNop = nilOL
185
186 mkComment :: FastString -> CmmAGraph
187 #if defined(DEBUG)
188 -- SDM: generating all those comments takes time, this saved about 4% for me
189 mkComment fs = mkMiddle $ CmmComment fs
190 #else
191 mkComment _ = nilOL
192 #endif
193
194 ---------- Assignment and store
195 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
196 mkAssign l (CmmReg r) | l == r = mkNop
197 mkAssign l r = mkMiddle $ CmmAssign l r
198
199 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
200 mkStore l r = mkMiddle $ CmmStore l r
201
202 ---------- Control transfer
203 mkJump :: DynFlags -> Convention -> CmmExpr
204 -> [CmmExpr]
205 -> UpdFrameOffset
206 -> CmmAGraph
207 mkJump dflags conv e actuals updfr_off =
208 lastWithArgs dflags Jump Old conv actuals updfr_off $
209 toCall e Nothing updfr_off 0
210
211 -- | A jump where the caller says what the live GlobalRegs are. Used
212 -- for low-level hand-written Cmm.
213 mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
214 -> CmmAGraph
215 mkRawJump dflags e updfr_off vols =
216 lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
217 \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
218
219
220 mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
221 -> UpdFrameOffset -> [CmmExpr]
222 -> CmmAGraph
223 mkJumpExtra dflags conv e actuals updfr_off extra_stack =
224 lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
225 toCall e Nothing updfr_off 0
226
227 mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
228 mkCbranch pred ifso ifnot likely =
229 mkLast (CmmCondBranch pred ifso ifnot likely)
230
231 mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
232 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
233
234 mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
235 -> CmmAGraph
236 mkReturn dflags e actuals updfr_off =
237 lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
238 toCall e Nothing updfr_off 0
239
240 mkBranch :: BlockId -> CmmAGraph
241 mkBranch bid = mkLast (CmmBranch bid)
242
243 mkFinalCall :: DynFlags
244 -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
245 -> CmmAGraph
246 mkFinalCall dflags f _ actuals updfr_off =
247 lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
248 toCall f Nothing updfr_off 0
249
250 mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
251 -> BlockId
252 -> ByteOff
253 -> UpdFrameOffset
254 -> [CmmExpr]
255 -> CmmAGraph
256 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
257 lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
258 updfr_off extra_stack $
259 toCall f (Just ret_lbl) updfr_off ret_off
260
261 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
262 -- already on the stack).
263 mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
264 -> BlockId
265 -> ByteOff
266 -> UpdFrameOffset
267 -> CmmAGraph
268 mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
269 lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
270 toCall f (Just ret_lbl) updfr_off ret_off
271
272 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
273 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
274
275 -- | Construct a 'CmmUnwind' node for the given register and unwinding
276 -- expression.
277 mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph
278 mkUnwind r e = mkMiddle $ CmmUnwind [(r, Just e)]
279
280 --------------------------------------------------------------------------
281
282
283
284
285 -- Why are we inserting extra blocks that simply branch to the successors?
286 -- Because in addition to the branch instruction, @mkBranch@ will insert
287 -- a necessary adjustment to the stack pointer.
288
289
290 -- For debugging purposes, we can stub out dead stack slots:
291 stackStubExpr :: Width -> CmmExpr
292 stackStubExpr w = CmmLit (CmmInt 0 w)
293
294 -- When we copy in parameters, we usually want to put overflow
295 -- parameters on the stack, but sometimes we want to pass the
296 -- variables in their spill slots. Therefore, for copying arguments
297 -- and results, we provide different functions to pass the arguments
298 -- in an overflow area and to pass them in spill slots.
299 copyInOflow :: DynFlags -> Convention -> Area
300 -> [CmmFormal]
301 -> [CmmFormal]
302 -> (Int, [GlobalReg], CmmAGraph)
303
304 copyInOflow dflags conv area formals extra_stk
305 = (offset, gregs, catAGraphs $ map mkMiddle nodes)
306 where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
307
308 -- Return the number of bytes used for copying arguments, as well as the
309 -- instructions to copy the arguments.
310 copyIn :: DynFlags -> Convention -> Area
311 -> [CmmFormal]
312 -> [CmmFormal]
313 -> (ByteOff, [GlobalReg], [CmmNode O O])
314 copyIn dflags conv area formals extra_stk
315 = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
316 where
317 ci (reg, RegisterParam r) =
318 CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
319 ci (reg, StackParam off) =
320 CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
321 where ty = localRegType reg
322
323 init_offset = widthInBytes (wordWidth dflags) -- infotable
324
325 (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
326
327 (stk_size, args) = assignArgumentsPos dflags stk_off conv
328 localRegType formals
329
330 -- Factoring out the common parts of the copyout functions yielded something
331 -- more complicated:
332
333 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
334
335 copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
336 -> UpdFrameOffset
337 -> [CmmExpr] -- extra stack args
338 -> (Int, [GlobalReg], CmmAGraph)
339
340 -- Generate code to move the actual parameters into the locations
341 -- required by the calling convention. This includes a store for the
342 -- return address.
343 --
344 -- The argument layout function ignores the pointer to the info table,
345 -- so we slot that in here. When copying-out to a young area, we set
346 -- the info table for return and adjust the offsets of the other
347 -- parameters. If this is a call instruction, we adjust the offsets
348 -- of the other parameters.
349 copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
350 = (stk_size, regs, graph)
351 where
352 (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
353
354 co (v, RegisterParam r) (rs, ms)
355 = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
356 co (v, StackParam off) (rs, ms)
357 = (rs, mkStore (CmmStackSlot area off) v <*> ms)
358
359 (setRA, init_offset) =
360 case area of
361 Young id -> -- Generate a store instruction for
362 -- the return address if making a call
363 case transfer of
364 Call ->
365 ([(CmmLit (CmmBlock id), StackParam init_offset)],
366 widthInBytes (wordWidth dflags))
367 JumpRet ->
368 ([],
369 widthInBytes (wordWidth dflags))
370 _other ->
371 ([], 0)
372 Old -> ([], updfr_off)
373
374 (extra_stack_off, stack_params) =
375 assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
376
377 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
378 (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
379 (cmmExprType dflags) actuals
380
381
382
383 mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
384 -> (Int, [GlobalReg], CmmAGraph)
385 mkCallEntry dflags conv formals extra_stk
386 = copyInOflow dflags conv Old formals extra_stk
387
388 lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
389 -> UpdFrameOffset
390 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
391 -> CmmAGraph
392 lastWithArgs dflags transfer area conv actuals updfr_off last =
393 lastWithArgsAndExtraStack dflags transfer area conv actuals
394 updfr_off noExtraStack last
395
396 lastWithArgsAndExtraStack :: DynFlags
397 -> Transfer -> Area -> Convention -> [CmmExpr]
398 -> UpdFrameOffset -> [CmmExpr]
399 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
400 -> CmmAGraph
401 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
402 extra_stack last =
403 copies <*> last outArgs regs
404 where
405 (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
406 updfr_off extra_stack
407
408
409 noExtraStack :: [CmmExpr]
410 noExtraStack = []
411
412 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
413 -> ByteOff -> [GlobalReg]
414 -> CmmAGraph
415 toCall e cont updfr_off res_space arg_space regs =
416 mkLast $ CmmCall e cont regs arg_space res_space updfr_off