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