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