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