Different implementation of MkGraph
[ghc.git] / compiler / cmm / MkGraph.hs
1 {-# LANGUAGE GADTs #-}
2
3 module MkGraph
4 ( CmmAGraph, CgStmt(..)
5 , (<*>), catAGraphs
6 , mkLabel, mkMiddle, mkLast
7 , lgraphOfAGraph, labelAGraph
8
9 , stackStubExpr
10 , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, lastWithArgs
11 , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
12 , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
13 , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
14 , toCall, Transfer(..)
15 )
16 where
17
18 import BlockId
19 import Cmm
20 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
21
22
23 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
24 import FastString
25 import ForeignCall
26 import Outputable
27 import Prelude hiding (succ)
28 import SMRep (ByteOff)
29 import UniqSupply
30 import OrdList
31
32 #include "HsVersions.h"
33
34
35 -----------------------------------------------------------------------------
36 -- Building Graphs
37
38
39 -- | CmmAGraph is a chunk of code consisting of:
40 --
41 -- * ordinary statements (assignments, stores etc.)
42 -- * jumps
43 -- * labels
44 -- * out-of-line labelled blocks
45 --
46 -- The semantics is that control falls through labels and out-of-line
47 -- blocks. Everything after a jump up to the next label is by
48 -- definition unreachable code, and will be discarded.
49 --
50 -- Two CmmAGraphs can be stuck together with <*>, with the meaning that
51 -- control flows from the first to the second.
52 --
53 -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
54 -- by providing a label for the entry point; see 'labelAGraph'.
55 --
56 type CmmAGraph = OrdList CgStmt
57
58 data CgStmt
59 = CgLabel BlockId
60 | CgStmt (CmmNode O O)
61 | CgLast (CmmNode O C)
62 | CgFork BlockId CmmAGraph
63
64 flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph
65 flattenCmmAGraph id stmts =
66 CmmGraph { g_entry = id,
67 g_graph = GMany NothingO body NothingO }
68 where
69 (block, blocks) = flatten (fromOL stmts)
70 entry = blockJoinHead (CmmEntry id) block
71 body = foldr addBlock emptyBody (entry:blocks)
72
73 flatten :: [CgStmt] -> (Block CmmNode O C, [Block CmmNode C C])
74 flatten [] = panic "flatten []"
75
76 -- A label at the end of a function or fork: this label must not be reachable,
77 -- but it might be referred to from another BB that also isn't reachable.
78 -- Eliminating these has to be done with a dead-code analysis. For now,
79 -- we just make it into a well-formed block by adding a recursive jump.
80 flatten [CgLabel id]
81 = (goto_id, [blockJoinHead (CmmEntry id) goto_id] )
82 where goto_id = blockJoinTail emptyBlock (CmmBranch id)
83
84 -- A jump/branch: throw away all the code up to the next label, because
85 -- it is unreachable. Be careful to keep forks that we find on the way.
86 flatten (CgLast stmt : stmts)
87 = case dropWhile isOrdinaryStmt stmts of
88 [] ->
89 ( sing, [] )
90 [CgLabel id] ->
91 ( sing, [blockJoin (CmmEntry id) emptyBlock (CmmBranch id)] )
92 (CgLabel id : stmts) ->
93 ( sing, blockJoinHead (CmmEntry id) block : blocks )
94 where (block,blocks) = flatten stmts
95 (CgFork fork_id stmts : ss) ->
96 flatten (CgFork fork_id stmts : CgLast stmt : ss)
97 _ -> panic "MkGraph.flatten"
98 where
99 sing = blockJoinTail emptyBlock stmt
100
101 flatten (s:ss) =
102 case s of
103 CgStmt stmt -> (blockCons stmt block, blocks)
104 CgLabel id -> (blockJoinTail emptyBlock (CmmBranch id),
105 blockJoinHead (CmmEntry id) block : blocks)
106 CgFork fork_id stmts ->
107 (block, blockJoinHead (CmmEntry fork_id) fork_block : fork_blocks ++ blocks)
108 where (fork_block, fork_blocks) = flatten (fromOL stmts)
109 _ -> panic "MkGraph.flatten"
110 where (block,blocks) = flatten ss
111
112 isOrdinaryStmt :: CgStmt -> Bool
113 isOrdinaryStmt (CgStmt _) = True
114 isOrdinaryStmt (CgLast _) = True
115 isOrdinaryStmt _ = False
116
117
118
119 ---------- AGraph manipulation
120
121 (<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
122 (<*>) = appOL
123
124 catAGraphs :: [CmmAGraph] -> CmmAGraph
125 catAGraphs = concatOL
126
127 -- | created a sequence "goto id; id:" as an AGraph
128 mkLabel :: BlockId -> CmmAGraph
129 mkLabel bid = unitOL (CgLabel bid)
130
131 -- | creates an open AGraph from a given node
132 mkMiddle :: CmmNode O O -> CmmAGraph
133 mkMiddle middle = unitOL (CgStmt middle)
134
135 -- | created a closed AGraph from a given node
136 mkLast :: CmmNode O C -> CmmAGraph
137 mkLast last = unitOL (CgLast last)
138
139
140 -- | allocate a fresh label for the entry point
141 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
142 lgraphOfAGraph g = do u <- getUniqueM
143 return (flattenCmmAGraph (mkBlockId u) g)
144
145 -- | use the given BlockId as the label of the entry point
146 labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
147 labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
148
149 ---------- No-ops
150 mkNop :: CmmAGraph
151 mkNop = nilOL
152
153 mkComment :: FastString -> CmmAGraph
154 #ifdef DEBUG
155 -- SDM: generating all those comments takes time, this saved about 4% for me
156 mkComment fs = mkMiddle $ CmmComment fs
157 #else
158 mkComment _ = nilOL
159 #endif
160
161 ---------- Assignment and store
162 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
163 mkAssign l r = mkMiddle $ CmmAssign l r
164
165 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
166 mkStore l r = mkMiddle $ CmmStore l r
167
168 ---------- Control transfer
169 mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
170 mkJump e actuals updfr_off =
171 lastWithArgs Jump old NativeNodeCall actuals updfr_off $
172 toCall e Nothing updfr_off 0
173
174 mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
175 mkDirectJump e actuals updfr_off =
176 lastWithArgs Jump old NativeDirectCall actuals updfr_off $
177 toCall e Nothing updfr_off 0
178
179 mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
180 mkJumpGC e actuals updfr_off =
181 lastWithArgs Jump old GC actuals updfr_off $
182 toCall e Nothing updfr_off 0
183
184 mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
185 -> CmmAGraph
186 mkForeignJump conv e actuals updfr_off =
187 lastWithArgs Jump old conv actuals updfr_off $
188 toCall e Nothing updfr_off 0
189
190 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
191 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
192
193 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
194 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
195
196 mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
197 mkReturn e actuals updfr_off =
198 lastWithArgs Ret old NativeReturn actuals updfr_off $
199 toCall e Nothing updfr_off 0
200 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
201
202 mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
203 mkReturnSimple actuals updfr_off =
204 lastWithArgs Ret old NativeReturn actuals updfr_off $
205 toCall e Nothing updfr_off 0
206 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
207
208 mkBranch :: BlockId -> CmmAGraph
209 mkBranch bid = mkLast (CmmBranch bid)
210
211 mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
212 -> CmmAGraph
213 mkFinalCall f _ actuals updfr_off =
214 lastWithArgs Call old NativeDirectCall actuals updfr_off $
215 toCall f Nothing updfr_off 0
216
217 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
218 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
219
220
221 --------------------------------------------------------------------------
222
223
224
225
226 -- Why are we inserting extra blocks that simply branch to the successors?
227 -- Because in addition to the branch instruction, @mkBranch@ will insert
228 -- a necessary adjustment to the stack pointer.
229
230
231 -- For debugging purposes, we can stub out dead stack slots:
232 stackStubExpr :: Width -> CmmExpr
233 stackStubExpr w = CmmLit (CmmInt 0 w)
234
235 -- When we copy in parameters, we usually want to put overflow
236 -- parameters on the stack, but sometimes we want to pass
237 -- the variables in their spill slots.
238 -- Therefore, for copying arguments and results, we provide different
239 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
240 copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
241 copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O]
242 copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
243
244 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
245 where (offset, nodes) = copyIn oneCopyOflowI conv area formals
246 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
247
248 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
249 (ByteOff, [CmmNode O O])
250 type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
251
252 -- Return the number of bytes used for copying arguments, as well as the
253 -- instructions to copy the arguments.
254 copyIn :: CopyIn
255 copyIn oflow conv area formals =
256 foldr ci (init_offset, []) args'
257 where ci (reg, RegisterParam r) (n, ms) =
258 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
259 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
260 init_offset = widthInBytes wordWidth -- infotable
261 args = assignArgumentsPos conv localRegType formals
262 args' = foldl adjust [] args
263 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
264 adjust rst x@(_, RegisterParam _) = x : rst
265
266 -- Copy-in one arg, using overflow space if needed.
267 oneCopyOflowI, oneCopySlotI :: SlotCopier
268 oneCopyOflowI area (reg, off) (n, ms) =
269 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
270 where ty = localRegType reg
271
272 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
273 -- a procpoint that is not a return point. The offset is irrelevant here...
274 oneCopySlotI _ (reg, _) (n, ms) =
275 (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
276 where ty = localRegType reg
277 w = widthInBytes (typeWidth ty)
278
279
280 -- Factoring out the common parts of the copyout functions yielded something
281 -- more complicated:
282
283 data Transfer = Call | Jump | Ret deriving Eq
284
285 copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset ->
286 (Int, CmmAGraph)
287
288 -- Generate code to move the actual parameters into the locations
289 -- required by the calling convention. This includes a store for the
290 -- return address.
291 --
292 -- The argument layout function ignores the pointer to the info table,
293 -- so we slot that in here. When copying-out to a young area, we set
294 -- the info table for return and adjust the offsets of the other
295 -- parameters. If this is a call instruction, we adjust the offsets
296 -- of the other parameters.
297 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
298 = foldr co (init_offset, mkNop) args'
299 where
300 co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
301 co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
302
303 (setRA, init_offset) =
304 case a of Young id -> id `seq` -- Generate a store instruction for
305 -- the return address if making a call
306 if transfer == Call then
307 ([(CmmLit (CmmBlock id), StackParam init_offset)],
308 widthInBytes wordWidth)
309 else ([], 0)
310 Old -> ([], updfr_off)
311
312 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
313 args = assignArgumentsPos conv cmmExprType actuals
314
315 args' = foldl adjust setRA args
316 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
317 adjust rst x@(_, RegisterParam _) = x : rst
318
319 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
320
321 -- Args passed only in registers and stack slots; no overflow space.
322 -- No return address may apply!
323 copyOutSlot conv actuals = foldr co [] args
324 where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
325 co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
326 toExp r = CmmReg (CmmLocal r)
327 args = assignArgumentsPos conv localRegType actuals
328
329 mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
330 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
331
332 lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset ->
333 (ByteOff -> CmmAGraph) -> CmmAGraph
334 lastWithArgs transfer area conv actuals updfr_off last =
335 let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
336 copies <*> last outArgs
337
338 -- The area created for the jump and return arguments is the same area as the
339 -- procedure entry.
340 old :: Area
341 old = CallArea Old
342
343 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff
344 -> CmmAGraph
345 toCall e cont updfr_off res_space arg_space =
346 mkLast $ CmmCall e cont arg_space res_space updfr_off