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