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