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