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