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