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