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