60704b5b328bf144355b0ba90c43839144b5d765
[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, mkReturnSimple, 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 Outputable
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 (block, blocks) = flatten (fromOL stmts)
74 entry = blockJoinHead (CmmEntry id) block
75 body = foldr addBlock emptyBody (entry:blocks)
76
77 flatten :: [CgStmt] -> (Block CmmNode O C, [Block CmmNode C C])
78 flatten [] = panic "flatten []"
79
80 -- A label at the end of a function or fork: this label must not be reachable,
81 -- but it might be referred to from another BB that also isn't reachable.
82 -- Eliminating these has to be done with a dead-code analysis. For now,
83 -- we just make it into a well-formed block by adding a recursive jump.
84 flatten [CgLabel id]
85 = (goto_id, [blockJoinHead (CmmEntry id) goto_id] )
86 where goto_id = blockJoinTail emptyBlock (CmmBranch id)
87
88 -- A jump/branch: throw away all the code up to the next label, because
89 -- it is unreachable. Be careful to keep forks that we find on the way.
90 flatten (CgLast stmt : stmts)
91 = case dropWhile isOrdinaryStmt stmts of
92 [] ->
93 ( sing, [] )
94 [CgLabel id] ->
95 ( sing, [blockJoin (CmmEntry id) emptyBlock (CmmBranch id)] )
96 (CgLabel id : stmts) ->
97 ( sing, blockJoinHead (CmmEntry id) block : blocks )
98 where (block,blocks) = flatten stmts
99 (CgFork fork_id stmts : ss) ->
100 flatten (CgFork fork_id stmts : CgLast stmt : ss)
101 _ -> panic "MkGraph.flatten"
102 where
103 sing = blockJoinTail emptyBlock stmt
104
105 flatten (s:ss) =
106 case s of
107 CgStmt stmt -> (blockCons stmt block, blocks)
108 CgLabel id -> (blockJoinTail emptyBlock (CmmBranch id),
109 blockJoinHead (CmmEntry id) block : blocks)
110 CgFork fork_id stmts ->
111 (block, blockJoinHead (CmmEntry fork_id) fork_block : fork_blocks ++ blocks)
112 where (fork_block, fork_blocks) = flatten (fromOL stmts)
113 _ -> panic "MkGraph.flatten"
114 where (block,blocks) = flatten ss
115
116 isOrdinaryStmt :: CgStmt -> Bool
117 isOrdinaryStmt (CgStmt _) = True
118 isOrdinaryStmt (CgLast _) = True
119 isOrdinaryStmt _ = False
120
121
122
123 ---------- AGraph manipulation
124
125 (<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
126 (<*>) = appOL
127
128 catAGraphs :: [CmmAGraph] -> CmmAGraph
129 catAGraphs = concatOL
130
131 -- | created a sequence "goto id; id:" as an AGraph
132 mkLabel :: BlockId -> CmmAGraph
133 mkLabel bid = unitOL (CgLabel bid)
134
135 -- | creates an open AGraph from a given node
136 mkMiddle :: CmmNode O O -> CmmAGraph
137 mkMiddle middle = unitOL (CgStmt middle)
138
139 -- | created a closed AGraph from a given node
140 mkLast :: CmmNode O C -> CmmAGraph
141 mkLast last = unitOL (CgLast last)
142
143 -- | A labelled code block; should end in a last node
144 outOfLine :: BlockId -> CmmAGraph -> CmmAGraph
145 outOfLine l g = unitOL (CgFork l g)
146
147 -- | allocate a fresh label for the entry point
148 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
149 lgraphOfAGraph g = do u <- getUniqueM
150 return (flattenCmmAGraph (mkBlockId u) g)
151
152 -- | use the given BlockId as the label of the entry point
153 labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
154 labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
155
156 ---------- No-ops
157 mkNop :: CmmAGraph
158 mkNop = nilOL
159
160 mkComment :: FastString -> CmmAGraph
161 #ifdef DEBUG
162 -- SDM: generating all those comments takes time, this saved about 4% for me
163 mkComment fs = mkMiddle $ CmmComment fs
164 #else
165 mkComment _ = nilOL
166 #endif
167
168 ---------- Assignment and store
169 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
170 mkAssign l r = mkMiddle $ CmmAssign l r
171
172 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
173 mkStore l r = mkMiddle $ CmmStore l r
174
175 ---------- Control transfer
176 mkJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
177 -> CmmAGraph
178 mkJump dflags e actuals updfr_off =
179 lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
180 toCall e Nothing updfr_off 0
181
182 mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
183 -> CmmAGraph
184 mkDirectJump dflags e actuals updfr_off =
185 lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
186 toCall e Nothing updfr_off 0
187
188 mkJumpGC :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
189 -> CmmAGraph
190 mkJumpGC dflags e actuals updfr_off =
191 lastWithArgs dflags Jump Old GC actuals updfr_off $
192 toCall e Nothing updfr_off 0
193
194 mkForeignJump :: DynFlags
195 -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
196 -> CmmAGraph
197 mkForeignJump dflags conv e actuals updfr_off =
198 mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
199
200 mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
201 -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
202 -> CmmAGraph
203 mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
204 lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
205 toCall e Nothing updfr_off 0
206
207 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
208 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
209
210 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
211 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
212
213 mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
214 -> CmmAGraph
215 mkReturn dflags e actuals updfr_off =
216 lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
217 toCall e Nothing updfr_off 0
218
219 mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
220 mkReturnSimple dflags actuals updfr_off =
221 mkReturn dflags e actuals updfr_off
222 where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
223
224 mkBranch :: BlockId -> CmmAGraph
225 mkBranch bid = mkLast (CmmBranch bid)
226
227 mkFinalCall :: DynFlags
228 -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
229 -> CmmAGraph
230 mkFinalCall dflags f _ actuals updfr_off =
231 lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
232 toCall f Nothing updfr_off 0
233
234 mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
235 -> BlockId
236 -> ByteOff
237 -> UpdFrameOffset
238 -> (ByteOff, [(CmmExpr,ByteOff)])
239 -> CmmAGraph
240 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
241 lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
242 updfr_off extra_stack $
243 toCall f (Just ret_lbl) updfr_off ret_off
244
245 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
246 -- already on the stack).
247 mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
248 -> BlockId
249 -> ByteOff
250 -> UpdFrameOffset
251 -> CmmAGraph
252 mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
253 lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
254 toCall f (Just ret_lbl) updfr_off ret_off
255
256 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
257 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
258
259
260 --------------------------------------------------------------------------
261
262
263
264
265 -- Why are we inserting extra blocks that simply branch to the successors?
266 -- Because in addition to the branch instruction, @mkBranch@ will insert
267 -- a necessary adjustment to the stack pointer.
268
269
270 -- For debugging purposes, we can stub out dead stack slots:
271 stackStubExpr :: Width -> CmmExpr
272 stackStubExpr w = CmmLit (CmmInt 0 w)
273
274 -- When we copy in parameters, we usually want to put overflow
275 -- parameters on the stack, but sometimes we want to pass
276 -- the variables in their spill slots.
277 -- Therefore, for copying arguments and results, we provide different
278 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
279 copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal]
280 -> (Int, CmmAGraph)
281
282 copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
283 where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
284
285 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
286 (ByteOff, [CmmNode O O])
287 type CopyIn = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
288
289 -- Return the number of bytes used for copying arguments, as well as the
290 -- instructions to copy the arguments.
291 copyIn :: CopyIn
292 copyIn dflags oflow conv area formals =
293 foldr ci (init_offset, []) args'
294 where ci (reg, RegisterParam r) (n, ms) =
295 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
296 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
297 init_offset = widthInBytes wordWidth -- infotable
298 args = assignArgumentsPos dflags conv localRegType formals
299 args' = foldl adjust [] args
300 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
301 adjust rst x@(_, RegisterParam _) = x : rst
302
303 -- Copy-in one arg, using overflow space if needed.
304 oneCopyOflowI :: SlotCopier
305 oneCopyOflowI area (reg, off) (n, ms) =
306 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
307 where ty = localRegType reg
308
309 -- Factoring out the common parts of the copyout functions yielded something
310 -- more complicated:
311
312 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
313
314 copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
315 -> UpdFrameOffset
316 -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
317 -> (Int, [GlobalReg], CmmAGraph)
318
319 -- Generate code to move the actual parameters into the locations
320 -- required by the calling convention. This includes a store for the
321 -- return address.
322 --
323 -- The argument layout function ignores the pointer to the info table,
324 -- so we slot that in here. When copying-out to a young area, we set
325 -- the info table for return and adjust the offsets of the other
326 -- parameters. If this is a call instruction, we adjust the offsets
327 -- of the other parameters.
328 copyOutOflow dflags conv transfer area actuals updfr_off
329 (extra_stack_off, extra_stack_stuff)
330 = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
331 where
332 co (v, RegisterParam r) (n, rs, ms)
333 = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
334 co (v, StackParam off) (n, rs, ms)
335 = (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
336
337 stack_params = [ (e, StackParam (off + init_offset))
338 | (e,off) <- extra_stack_stuff ]
339
340 (setRA, init_offset) =
341 case area of
342 Young id -> id `seq` -- Generate a store instruction for
343 -- the return address if making a call
344 case transfer of
345 Call ->
346 ([(CmmLit (CmmBlock id), StackParam init_offset)],
347 widthInBytes wordWidth)
348 JumpRet ->
349 ([],
350 widthInBytes wordWidth)
351 _other ->
352 ([], 0)
353 Old -> ([], updfr_off)
354
355 arg_offset = init_offset + extra_stack_off
356
357 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
358 args = assignArgumentsPos dflags conv cmmExprType actuals
359
360 args' = foldl adjust setRA args
361 where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
362 adjust rst x@(_, RegisterParam _) = x : rst
363
364
365
366 mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
367 mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
368
369 lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
370 -> UpdFrameOffset
371 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
372 -> CmmAGraph
373 lastWithArgs dflags transfer area conv actuals updfr_off last =
374 lastWithArgsAndExtraStack dflags transfer area conv actuals
375 updfr_off noExtraStack last
376
377 lastWithArgsAndExtraStack :: DynFlags
378 -> Transfer -> Area -> Convention -> [CmmActual]
379 -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
380 -> (ByteOff -> [GlobalReg] -> CmmAGraph)
381 -> CmmAGraph
382 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
383 extra_stack last =
384 copies <*> last outArgs regs
385 where
386 (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
387 updfr_off extra_stack
388
389
390 noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
391 noExtraStack = (0,[])
392
393 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
394 -> ByteOff -> [GlobalReg]
395 -> CmmAGraph
396 toCall e cont updfr_off res_space arg_space regs =
397 mkLast $ CmmCall e cont regs arg_space res_space updfr_off