4ba82cd8f83e5d5561b46ada46a6f1073292bfd1
[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, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
13 , mkCbranch, mkSwitch
14 , mkReturn, mkComment, mkCallEntry, mkBranch
15 , copyInOflow, copyOutOflow
16 , noExtraStack
17 , toCall, Transfer(..)
18 )
19 where
20
21 import BlockId
22 import Cmm
23 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
24
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 (flattenCmmAGraph (mkBlockId u) g)
165
166 -- | use the given BlockId as the label of the entry point
167 labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
168 labelAGraph lbl ag = return (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 mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
198 -> CmmAGraph
199 mkDirectJump dflags e actuals updfr_off =
200 lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
201 toCall e Nothing updfr_off 0
202
203 mkJumpGC :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
204 -> CmmAGraph
205 mkJumpGC dflags e actuals updfr_off =
206 lastWithArgs dflags Jump Old GC actuals updfr_off $
207 toCall e Nothing updfr_off 0
208
209 mkForeignJump :: DynFlags
210 -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
211 -> CmmAGraph
212 mkForeignJump dflags conv e actuals updfr_off =
213 mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
214
215 mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
216 -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
217 -> CmmAGraph
218 mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
219 lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
220 toCall e Nothing updfr_off 0
221
222 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
223 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
224
225 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
226 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
227
228 mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
229 -> CmmAGraph
230 mkReturn dflags e actuals updfr_off =
231 lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
232 toCall e Nothing updfr_off 0
233
234 mkBranch :: BlockId -> CmmAGraph
235 mkBranch bid = mkLast (CmmBranch bid)
236
237 mkFinalCall :: DynFlags
238 -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
239 -> CmmAGraph
240 mkFinalCall dflags f _ actuals updfr_off =
241 lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
242 toCall f Nothing updfr_off 0
243
244 mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
245 -> BlockId
246 -> ByteOff
247 -> UpdFrameOffset
248 -> (ByteOff, [(CmmExpr,ByteOff)])
249 -> CmmAGraph
250 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
251 lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
252 updfr_off extra_stack $
253 toCall f (Just ret_lbl) updfr_off ret_off
254
255 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
256 -- already on the stack).
257 mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
258 -> BlockId
259 -> ByteOff
260 -> UpdFrameOffset
261 -> CmmAGraph
262 mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
263 lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
264 toCall f (Just ret_lbl) updfr_off ret_off
265
266 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
267 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
268
269
270 --------------------------------------------------------------------------
271
272
273
274
275 -- Why are we inserting extra blocks that simply branch to the successors?
276 -- Because in addition to the branch instruction, @mkBranch@ will insert
277 -- a necessary adjustment to the stack pointer.
278
279
280 -- For debugging purposes, we can stub out dead stack slots:
281 stackStubExpr :: Width -> CmmExpr
282 stackStubExpr w = CmmLit (CmmInt 0 w)
283
284 -- When we copy in parameters, we usually want to put overflow
285 -- parameters on the stack, but sometimes we want to pass
286 -- the variables in their spill slots.
287 -- Therefore, for copying arguments and results, we provide different
288 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
289 copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal]
290 -> (Int, CmmAGraph)
291
292 copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
293 where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
294
295 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
296 (ByteOff, [CmmNode O O])
297 type CopyIn = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
298
299 -- Return the number of bytes used for copying arguments, as well as the
300 -- instructions to copy the arguments.
301 copyIn :: CopyIn
302 copyIn dflags oflow conv area formals =
303 foldr ci (init_offset, []) args'
304 where ci (reg, RegisterParam r) (n, ms) =
305 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
306 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
307 init_offset = widthInBytes (wordWidth dflags) -- infotable
308 args = assignArgumentsPos dflags conv localRegType formals
309 args' = foldl adjust [] args
310 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
311 adjust rst x@(_, RegisterParam _) = x : rst
312
313 -- Copy-in one arg, using overflow space if needed.
314 oneCopyOflowI :: SlotCopier
315 oneCopyOflowI area (reg, off) (n, ms) =
316 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
317 where ty = localRegType reg
318
319 -- Factoring out the common parts of the copyout functions yielded something
320 -- more complicated:
321
322 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
323
324 copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
325 -> UpdFrameOffset
326 -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
327 -> (Int, [GlobalReg], CmmAGraph)
328
329 -- Generate code to move the actual parameters into the locations
330 -- required by the calling convention. This includes a store for the
331 -- return address.
332 --
333 -- The argument layout function ignores the pointer to the info table,
334 -- so we slot that in here. When copying-out to a young area, we set
335 -- the info table for return and adjust the offsets of the other
336 -- parameters. If this is a call instruction, we adjust the offsets
337 -- of the other parameters.
338 copyOutOflow dflags conv transfer area actuals updfr_off
339 (extra_stack_off, extra_stack_stuff)
340 = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
341 where
342 co (v, RegisterParam r) (n, rs, ms)
343 = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
344 co (v, StackParam off) (n, rs, ms)
345 = (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
346
347 stack_params = [ (e, StackParam (off + init_offset))
348 | (e,off) <- extra_stack_stuff ]
349
350 (setRA, init_offset) =
351 case area of
352 Young id -> id `seq` -- Generate a store instruction for
353 -- the return address if making a call
354 case transfer of
355 Call ->
356 ([(CmmLit (CmmBlock id), StackParam init_offset)],
357 widthInBytes (wordWidth dflags))
358 JumpRet ->
359 ([],
360 widthInBytes (wordWidth dflags))
361 _other ->
362 ([], 0)
363 Old -> ([], updfr_off)
364
365 arg_offset = init_offset + extra_stack_off
366
367 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
368 args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals
369
370 args' = foldl adjust setRA args
371 where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
372 adjust rst x@(_, RegisterParam _) = x : rst
373
374
375
376 mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
377 mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
378
379 lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
380 -> UpdFrameOffset
381 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
382 -> CmmAGraph
383 lastWithArgs dflags transfer area conv actuals updfr_off last =
384 lastWithArgsAndExtraStack dflags transfer area conv actuals
385 updfr_off noExtraStack last
386
387 lastWithArgsAndExtraStack :: DynFlags
388 -> Transfer -> Area -> Convention -> [CmmActual]
389 -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
390 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
391 -> CmmAGraph
392 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
393 extra_stack last =
394 copies <*> last outArgs regs
395 where
396 (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
397 updfr_off extra_stack
398
399
400 noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
401 noExtraStack = (0,[])
402
403 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
404 -> ByteOff -> [GlobalReg]
405 -> CmmAGraph
406 toCall e cont updfr_off res_space arg_space regs =
407 mkLast $ CmmCall e cont regs arg_space res_space updfr_off