d1ac5712ab01de2cca68e03c8944aae59fa1989e
[ghc.git] / compiler / cmm / MkGraph.hs
1 {-# LANGUAGE GADTs #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
3 -- ToDo: remove
4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
5
6 -- Module for building CmmAGraphs.
7
8 -- As the CmmAGraph is a wrapper over Graph CmmNode O x, it is different
9 -- from Hoopl's AGraph. The current clients expect functions with the
10 -- same names Hoopl uses, so this module cannot be in the same namespace
11 -- as Compiler.Hoopl.
12
13 module MkGraph
14 ( CmmAGraph
15 , emptyAGraph, (<*>), catAGraphs, outOfLine
16 , mkLabel, mkMiddle, mkLast
17 , withFreshLabel, withUnique, lgraphOfAGraph, labelAGraph
18
19 , stackStubExpr
20 , mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
21 , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
22 , mkReturn, mkReturnSimple, mkComment, mkCallEntry
23 , mkBranch, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
24 , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
25 -- Reexport of needed Cmm stuff
26 , Convention(..), ForeignConvention(..), ForeignTarget(..)
27 , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
28 , Cmm, CmmTop
29 )
30 where
31
32 import BlockId
33 import Cmm
34 import CmmDecl
35 import CmmExpr
36 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
37
38 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
39 import qualified Compiler.Hoopl as H
40 import Compiler.Hoopl.GHC (uniqueToLbl)
41 import FastString
42 import ForeignCall
43 import Outputable
44 import Prelude hiding (succ)
45 import SMRep (ByteOff)
46 import StaticFlags
47 import Unique
48 import UniqSupply
49
50 #include "HsVersions.h"
51
52 {-
53 A 'CmmAGraph' is an abstract version of a 'Graph CmmNode O x' from module
54 'Cmm'. The difference is that the 'CmmAGraph' can be eigher open of closed at
55 exit and it can supply fresh Labels and Uniques.
56
57 It also supports a splicing operation <*>, which is different from the Hoopl's
58 <*>, because it splices two CmmAGraphs. Specifically, it can splice Graph
59 O C and Graph O x. In this case, the open beginning of the second graph is
60 thrown away. In the debug mode this sequence is checked to be empty or
61 containing a branch (see note [Branch follows branch]).
62
63 When an CmmAGraph open at exit is being converted to a CmmGraph, the output
64 exit sequence is considered unreachable. If the graph consist of one block
65 only, if it not the case and we crash. Otherwise we just throw the exit
66 sequence away (and in debug mode we test that it really was unreachable).
67 -}
68
69 {-
70 Node [Branch follows branch]
71 ============================
72 Why do we say it's ok for a Branch to follow a Branch?
73 Because the standard constructor mkLabel has fall-through
74 semantics. So if you do a mkLabel, you finish the current block,
75 giving it a label, and start a new one that branches to that label.
76 Emitting a Branch at this point is fine:
77 goto L1; L2: ...stuff...
78 -}
79
80 data CmmGraphOC = Opened (Graph CmmNode O O)
81 | Closed (Graph CmmNode O C)
82 type CmmAGraph = UniqSM CmmGraphOC -- Graph open at entry
83
84 {-
85 MS: I began with
86 newtype CmmAGraph = forall x. AG (UniqSM (Graph CmmNode O x))
87 but that does not work well, because we cannot take the graph
88 out of the monad -- we do not know the type of what we would take
89 out and pattern matching does not help, as we cannot pattern match
90 on a graph inside the monad.
91 -}
92
93 data Transfer = Call | Jump | Ret deriving Eq
94
95 ---------- AGraph manipulation
96
97 emptyAGraph :: CmmAGraph
98 (<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
99 catAGraphs :: [CmmAGraph] -> CmmAGraph
100
101 mkLabel :: BlockId -> CmmAGraph -- created a sequence "goto id; id:" as an AGraph
102 mkMiddle :: CmmNode O O -> CmmAGraph -- creates an open AGraph from a given node
103 mkLast :: CmmNode O C -> CmmAGraph -- created a closed AGraph from a given node
104
105 withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
106 withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
107
108 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
109 -- ^ allocate a fresh label for the entry point
110 labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
111 -- ^ use the given BlockId as the label of the entry point
112
113 ---------- No-ops
114 mkNop :: CmmAGraph
115 mkComment :: FastString -> CmmAGraph
116
117 ---------- Assignment and store
118 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
119 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
120
121 ---------- Calls
122 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] ->
123 UpdFrameOffset -> CmmAGraph
124 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] ->
125 UpdFrameOffset -> CmmAGraph
126 -- Native C-- calling convention
127 mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> Bool -> CmmAGraph
128 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
129 mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
130 -- Never returns; like exit() or barf()
131
132 ---------- Control transfer
133 mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
134 mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
135 mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
136 mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
137 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
138 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
139 mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
140 mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
141
142 mkBranch :: BlockId -> CmmAGraph
143 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
144 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
145 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
146
147 outOfLine :: CmmAGraph -> CmmAGraph
148 -- ^ The argument is an CmmAGraph that must have an
149 -- empty entry sequence and be closed at the end.
150 -- The result is a new CmmAGraph that is open at the
151 -- end and goes directly from entry to exit, with the
152 -- original graph sitting to the side out-of-line.
153 --
154 -- Example: mkMiddle (x = 3)
155 -- <*> outOfLine (mkLabel L <*> ...stuff...)
156 -- <*> mkMiddle (y = x)
157 -- Control will flow directly from x=3 to y=x;
158 -- the block starting with L is "on the side".
159 --
160 -- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
161
162 --------------------------------------------------------------------------
163
164 -- ================ IMPLEMENTATION ================--
165
166 --------------------------------------------------
167 -- Raw CmmAGraph handling
168
169 emptyAGraph = return $ Opened emptyGraph
170 ag <*> ah = do g <- ag
171 h <- ah
172 return (case (g, h) of
173 (Opened g, Opened h) -> Opened $ g H.<*> h
174 (Opened g, Closed h) -> Closed $ g H.<*> h
175 (Closed g, Opened GNil) -> Closed g
176 (Closed g, Opened (GUnit e)) -> note_unreachable e $ Closed g
177 (Closed g, Opened (GMany (JustO e) b x)) -> note_unreachable e $ Opened $ g H.|*><*| GMany NothingO b x
178 (Closed g, Closed (GMany (JustO e) b x)) -> note_unreachable e $ Closed $ g H.|*><*| GMany NothingO b x
179 :: CmmGraphOC)
180 catAGraphs = foldl (<*>) emptyAGraph
181
182 outOfLine ag = withFreshLabel "outOfLine" $ \l ->
183 do g <- ag
184 return (case g of
185 Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
186 GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
187 _ -> panic "outOfLine"
188 :: CmmGraphOC)
189
190 note_unreachable :: Block CmmNode O x -> a -> a
191 note_unreachable block graph =
192 ASSERT (block_is_empty_or_label) -- Note [Branch follows branch]
193 graph
194 where block_is_empty_or_label :: Bool
195 block_is_empty_or_label = case blockToNodeList block of
196 (NothingC, [], NothingC) -> True
197 (NothingC, [], JustC (CmmBranch _)) -> True
198 _ -> False
199
200 mkLabel bid = return $ Opened $ H.mkLast (CmmBranch bid) |*><*| H.mkFirst (CmmEntry bid)
201 mkMiddle middle = return $ Opened $ H.mkMiddle middle
202 mkLast last = return $ Closed $ H.mkLast last
203
204 withUnique f = getUniqueM >>= f
205 withFreshLabel _name f = getUniqueM >>= f . uniqueToLbl . intToUnique . getKey
206
207 lgraphOfAGraph g = do u <- getUniqueM
208 labelAGraph (mkBlockId u) g
209
210 labelAGraph lbl ag = do g <- ag
211 return $ CmmGraph {g_entry=lbl, g_graph=H.mkFirst (CmmEntry lbl) H.<*> closed g}
212 where closed :: CmmGraphOC -> Graph CmmNode O C
213 closed (Closed g) = g
214 closed (Opened g@(GMany entry body (JustO exit))) =
215 ASSERT (entryLabel exit `notElem` map entryLabel (postorder_dfs g))
216 GMany entry body NothingO
217 closed (Opened _) = panic "labelAGraph"
218
219 --------------------------------------------------
220 -- CmmAGraph constructions
221
222 mkNop = emptyAGraph
223 mkComment fs = mkMiddle $ CmmComment fs
224 mkStore l r = mkMiddle $ CmmStore l r
225
226 -- NEED A COMPILER-DEBUGGING FLAG HERE
227 -- Sanity check: any value assigned to a pointer must be non-zero.
228 -- If it's 0, cause a crash immediately.
229 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
230 where assign l r = mkMiddle (CmmAssign l r)
231 check (CmmGlobal _) = mkNop
232 check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
233 if isGcPtrType ty then
234 mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
235 (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
236 else mkNop
237 where ty = localRegType reg
238 w = typeWidth ty
239 r = CmmReg l
240
241
242 -- Why are we inserting extra blocks that simply branch to the successors?
243 -- Because in addition to the branch instruction, @mkBranch@ will insert
244 -- a necessary adjustment to the stack pointer.
245 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
246 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
247
248 mkSafeCall t fs as upd i = withFreshLabel "safe call" $ body
249 where
250 body k =
251 ( mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth))
252 (CmmLit (CmmBlock k))
253 <*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i})
254 <*> mkLabel k)
255 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
256
257 mkBranch bid = mkLast (CmmBranch bid)
258
259 mkCmmIfThenElse e tbranch fbranch =
260 withFreshLabel "end of if" $ \endif ->
261 withFreshLabel "start of then" $ \tid ->
262 withFreshLabel "start of else" $ \fid ->
263 mkCbranch e tid fid <*>
264 mkLabel tid <*> tbranch <*> mkBranch endif <*>
265 mkLabel fid <*> fbranch <*> mkLabel endif
266
267 mkCmmIfThen e tbranch
268 = withFreshLabel "end of if" $ \endif ->
269 withFreshLabel "start of then" $ \tid ->
270 mkCbranch e tid endif <*>
271 mkLabel tid <*> tbranch <*> mkLabel endif
272
273 mkCmmWhileDo e body =
274 withFreshLabel "loop test" $ \test ->
275 withFreshLabel "loop head" $ \head ->
276 withFreshLabel "end while" $ \endwhile ->
277 -- Forrest Baskett's while-loop layout
278 mkBranch test <*> mkLabel head <*> body
279 <*> mkLabel test <*> mkCbranch e head endwhile
280 <*> mkLabel endwhile
281
282 -- For debugging purposes, we can stub out dead stack slots:
283 stackStubExpr :: Width -> CmmExpr
284 stackStubExpr w = CmmLit (CmmInt 0 w)
285
286 -- When we copy in parameters, we usually want to put overflow
287 -- parameters on the stack, but sometimes we want to pass
288 -- the variables in their spill slots.
289 -- Therefore, for copying arguments and results, we provide different
290 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
291 copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
292 copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O]
293 copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
294
295 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
296 where (offset, nodes) = copyIn oneCopyOflowI conv area formals
297 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
298
299 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
300 (ByteOff, [CmmNode O O])
301 type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
302
303 -- Return the number of bytes used for copying arguments, as well as the
304 -- instructions to copy the arguments.
305 copyIn :: CopyIn
306 copyIn oflow conv area formals =
307 foldr ci (init_offset, []) args'
308 where ci (reg, RegisterParam r) (n, ms) =
309 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
310 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
311 init_offset = widthInBytes wordWidth -- infotable
312 args = assignArgumentsPos conv localRegType formals
313 args' = foldl adjust [] args
314 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
315 adjust rst x@(_, RegisterParam _) = x : rst
316
317 -- Copy-in one arg, using overflow space if needed.
318 oneCopyOflowI, oneCopySlotI :: SlotCopier
319 oneCopyOflowI area (reg, off) (n, ms) =
320 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
321 where ty = localRegType reg
322
323 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
324 -- a procpoint that is not a return point. The offset is irrelevant here...
325 oneCopySlotI _ (reg, _) (n, ms) =
326 (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
327 where ty = localRegType reg
328 w = widthInBytes (typeWidth ty)
329
330
331 -- Factoring out the common parts of the copyout functions yielded something
332 -- more complicated:
333
334 copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset ->
335 (Int, CmmAGraph)
336 -- Generate code to move the actual parameters into the locations
337 -- required by the calling convention. This includes a store for the return address.
338 --
339 -- The argument layout function ignores the pointer to the info table, so we slot that
340 -- in here. When copying-out to a young area, we set the info table for return
341 -- and adjust the offsets of the other parameters.
342 -- If this is a call instruction, we adjust the offsets of the other parameters.
343 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
344 = foldr co (init_offset, emptyAGraph) args'
345 where
346 co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
347 co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
348
349 (setRA, init_offset) =
350 case a of Young id -> id `seq` -- Generate a store instruction for
351 -- the return address if making a call
352 if transfer == Call then
353 ([(CmmLit (CmmBlock id), StackParam init_offset)],
354 widthInBytes wordWidth)
355 else ([], 0)
356 Old -> ([], updfr_off)
357
358 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
359 args = assignArgumentsPos conv cmmExprType actuals
360
361 args' = foldl adjust setRA args
362 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
363 adjust rst x@(_, RegisterParam _) = x : rst
364
365 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
366
367 -- Args passed only in registers and stack slots; no overflow space.
368 -- No return address may apply!
369 copyOutSlot conv actuals = foldr co [] args
370 where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
371 co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
372 toExp r = CmmReg (CmmLocal r)
373 args = assignArgumentsPos conv localRegType actuals
374
375 mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
376 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
377
378 lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset ->
379 (ByteOff -> CmmAGraph) -> CmmAGraph
380 lastWithArgs transfer area conv actuals updfr_off last =
381 let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
382 copies <*> last outArgs
383
384 -- The area created for the jump and return arguments is the same area as the
385 -- procedure entry.
386 old :: Area
387 old = CallArea Old
388 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
389 toCall e cont updfr_off res_space arg_space =
390 mkLast $ CmmCall e cont arg_space res_space updfr_off
391 mkJump e actuals updfr_off =
392 lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
393 mkDirectJump e actuals updfr_off =
394 lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
395 mkJumpGC e actuals updfr_off =
396 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
397 mkForeignJump conv e actuals updfr_off =
398 lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
399 mkReturn e actuals updfr_off =
400 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
401 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
402 mkReturnSimple actuals updfr_off =
403 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
404 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
405
406 mkFinalCall f _ actuals updfr_off =
407 lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
408
409 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
410
411 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
412 mkCall f (callConv, retConv) results actuals updfr_off =
413 withFreshLabel "call successor" $ \k ->
414 let area = CallArea $ Young k
415 (off, copyin) = copyInOflow retConv area results
416 copyout = lastWithArgs Call area callConv actuals updfr_off
417 (toCall f (Just k) updfr_off off)
418 in (copyout <*> mkLabel k <*> copyin)