1 -- This module is pure representation and should be imported only by
2 -- clients that need to manipulate representation and know what
3 -- they're doing. Clients that need to create flow graphs should
4 -- instead import MkZipCfgCmm.
7 ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
8 , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
9 , Convention(..), ForeignConvention(..), ForeignSafety(..)
10 , ValueDirection(..), ForeignHint(..)
11 , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
12 , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
13 , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
19 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
20 , CallishMachOp(..), ForeignHint(..)
21 , CmmActuals, CmmFormals, CmmHinted(..)
22 , CmmStmt(..) -- imported in order to call ppr on Switch and to
23 -- implement pprCmmGraphLikeCmm
32 import qualified ZipDataflow as DF
41 import Prelude hiding (zip, unzip, last)
42 import SMRep (ByteOff)
45 ----------------------------------------------------------------------
46 ----- Type synonyms and definitions
48 type CmmGraph = LGraph Middle Last
49 type CmmAGraph = AGraph Middle Last
50 type CmmBlock = Block Middle Last
51 type CmmStackInfo = (ByteOff, Maybe ByteOff)
52 -- probably want a record; (SP offset on entry, update frame space)
53 type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
54 type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
55 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
56 type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
58 type UpdFrameOffset = ByteOff
61 = MidComment FastString
63 | MidAssign CmmReg CmmExpr -- Assign to register
65 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
66 -- given by cmmExprType of the rhs.
68 | MidForeignCall -- A foreign call; see Note [Foreign calls]
69 ForeignSafety -- Is it a safe or unsafe call?
70 MidCallTarget -- call target and convention
71 CmmFormals -- zero or more results
72 CmmActuals -- zero or more arguments
76 = LastBranch BlockId -- Goto another block in the same procedure
78 | LastCondBranch { -- conditional branch
80 cml_true, cml_false :: BlockId
82 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
83 -- The scrutinee is zero-based;
84 -- zero -> first block
85 -- one -> second block etc
86 -- Undefined outside range, and when there's a Nothing
87 | LastCall { -- A call (native or safe foreign)
88 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
90 cml_cont :: Maybe BlockId,
91 -- BlockId of continuation (Nothing for return or tail call)
94 -- Byte offset, from the *old* end of the Area associated with
95 -- the BlockId (if cml_cont = Nothing, then Old area), of
96 -- youngest outgoing arg. Set the stack pointer to this before
97 -- transferring control.
98 -- (NB: an update frame might also have been stored in the Old
99 -- area, but it'll be in an older part than the args.)
101 cml_ret_args :: ByteOff,
102 -- For calls *only*, the byte offset for youngest returned value
103 -- This is really needed at the *return* point rather than here
104 -- at the call, but in practice it's convenient to record it here.
106 cml_ret_off :: Maybe UpdFrameOffset
107 -- Stack offset for return (update frames);
108 -- The return offset should be Nothing only if we have to create
109 -- a new call, e.g. for a procpoint, in which case it's an invariant
110 -- that the call does not stand for a return or a tail call,
111 -- and the successor does not need an info table.
114 data MidCallTarget -- The target of a MidUnsafeCall
115 = ForeignTarget -- A foreign procedure
116 CmmExpr -- Its address
117 ForeignConvention -- Its calling convention
119 | PrimTarget -- A possibly-side-effecting machine operation
120 CallishMachOp -- Which one
124 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
126 | NativeNodeCall -- Native C-- call including the node argument
128 | NativeReturn -- Native C-- return
130 | Slow -- Slow entry points: all args pushed on the stack
132 | GC -- Entry to the garbage collector: uses the node reg!
134 | PrimOpCall -- Calling prim ops
136 | PrimOpReturn -- Returning from prim ops
138 | Foreign -- Foreign call/return
142 -- Used for control transfers within a (pre-CPS) procedure All
143 -- jump sites known, never pushed on the stack (hence no SRT)
144 -- You can choose whatever calling convention you please
145 -- (provided you make sure all the call sites agree)!
146 -- This data type eventually to be extended to record the convention.
149 data ForeignConvention
151 CCallConv -- Which foreign-call convention
152 [ForeignHint] -- Extra info about the args
153 [ForeignHint] -- Extra info about the result
157 = Unsafe -- unsafe call
158 | Safe BlockId -- making infotable requires: 1. label
159 UpdFrameOffset -- 2. where the upd frame is
162 data ValueDirection = Arguments | Results
163 -- Arguments go with procedure definitions, jumps, and arguments to calls
164 -- Results go with returns and with results of calls.
167 {- Note [Foreign calls]
168 ~~~~~~~~~~~~~~~~~~~~~~~
169 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
170 Unsafe ones are easy: think of them as a "fat machine instruction".
172 Safe ones are trickier. A safe foreign call
174 ultimately expands to
175 push "return address" -- Never used to return to;
176 -- just points an info table
177 save registers into TSO
179 r = f(x) -- Make the call
183 We cannot "lower" a safe foreign call to this sequence of Cmms, because
184 after we've saved Sp all the Cmm optimiser's assumptions are broken.
185 Furthermore, currently the smart Cmm constructors know the calling
186 conventions for Haskell, the garbage collector, etc, and "lower" them
187 so that a LastCall passes no parameters or results. But the smart
188 constructors do *not* (currently) know the foreign call conventions.
190 For these reasons use MidForeignCall for all calls. The only annoying thing
191 is that a safe foreign call needs an info table.
194 ----------------------------------------------------------------------
195 ----- Splicing between blocks
196 -- Given a middle node, a block, and a successor BlockId,
197 -- we can insert the middle node between the block and the successor.
198 -- We return the updated block and a list of new blocks that must be added
200 -- The semantics is a bit tricky. We consider cases on the last node:
201 -- o For a branch, we can just insert before the branch,
202 -- but sometimes the optimizer does better if we actually insert
203 -- a fresh basic block, enabling some common blockification.
204 -- o For a conditional branch, switch statement, or call, we must insert
205 -- a new basic block.
206 -- o For a jump or return, this operation is impossible.
208 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
209 insertBetween b ms succId = insert $ goto_end $ unzip b
210 where insert (h, LastOther (LastBranch bid)) =
211 if bid == succId then
212 do (bid', bs) <- newBlocks
213 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
214 else panic "tried invalid block insertBetween"
215 insert (h, LastOther (LastCondBranch c t f)) =
216 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
217 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
218 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
219 insert (h, LastOther (LastSwitch e ks)) =
220 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
221 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
222 insert (_, LastOther (LastCall {})) =
223 panic "unimp: insertBetween after a call -- probably not a good idea"
224 insert (_, LastExit) = panic "cannot insert after exit"
225 newBlocks = do id <- liftM BlockId $ getUniqueM
226 return $ (id, [Block id $
227 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
228 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
229 else return (Just k, [])
230 mbNewBlocks Nothing = return (Nothing, [])
231 lift (id, bs) = (Just id, bs)
233 ----------------------------------------------------------------------
234 ----- Instance declarations for control flow
236 instance HavingSuccessors Last where
238 fold_succs = fold_cmm_succs
240 instance LastNode Last where
241 mkBranchNode id = LastBranch id
242 isBranchNode (LastBranch _) = True
243 isBranchNode _ = False
244 branchNodeTarget (LastBranch id) = id
245 branchNodeTarget _ = panic "asked for target of non-branch"
247 cmmSuccs :: Last -> [BlockId]
248 cmmSuccs (LastBranch id) = [id]
249 cmmSuccs (LastCall _ Nothing _ _ _) = []
250 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
251 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
252 cmmSuccs (LastSwitch _ edges) = catMaybes edges
254 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
255 fold_cmm_succs f (LastBranch id) z = f id z
256 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
257 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
258 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
259 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
261 ----------------------------------------------------------------------
262 ----- Instance declarations for register use
264 instance UserOfLocalRegs Middle where
265 foldRegsUsed f z m = middle m
266 where middle (MidComment {}) = z
267 middle (MidAssign _lhs expr) = fold f z expr
268 middle (MidStore addr rval) = fold f (fold f z addr) rval
269 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
270 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
272 instance UserOfLocalRegs MidCallTarget where
273 foldRegsUsed _f z (PrimTarget _) = z
274 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
276 instance UserOfSlots MidCallTarget where
277 foldSlotsUsed _f z (PrimTarget _) = z
278 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
280 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
281 foldRegsUsed f z (Just x) = foldRegsUsed f z x
282 foldRegsUsed _ z Nothing = z
284 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
285 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
286 foldSlotsUsed _ z Nothing = z
288 instance UserOfLocalRegs Last where
289 foldRegsUsed f z l = last l
290 where last (LastBranch _id) = z
291 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
292 last (LastCondBranch e _ _) = foldRegsUsed f z e
293 last (LastSwitch e _tbl) = foldRegsUsed f z e
295 instance DefinerOfLocalRegs Middle where
296 foldRegsDefd f z m = middle m
297 where middle (MidComment {}) = z
298 middle (MidAssign lhs _) = fold f z lhs
299 middle (MidStore _ _) = z
300 middle (MidForeignCall _ _ fs _) = fold f z fs
301 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
303 instance DefinerOfLocalRegs Last where
304 foldRegsDefd _ z _ = z
307 ----------------------------------------------------------------------
308 ----- Instance declarations for stack slot use
310 instance UserOfSlots Middle where
311 foldSlotsUsed f z m = middle m
312 where middle (MidComment {}) = z
313 middle (MidAssign _lhs expr) = fold f z expr
314 middle (MidStore addr rval) = fold f (fold f z addr) rval
315 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
316 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
318 instance UserOfSlots Last where
319 foldSlotsUsed f z l = last l
320 where last (LastBranch _id) = z
321 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
322 last (LastCondBranch e _ _) = foldSlotsUsed f z e
323 last (LastSwitch e _tbl) = foldSlotsUsed f z e
325 instance UserOfSlots l => UserOfSlots (ZLast l) where
326 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
327 foldSlotsUsed _ z LastExit = z
329 instance DefinerOfSlots Middle where
330 foldSlotsDefd f z m = middle m
331 where middle (MidComment {}) = z
332 middle (MidAssign _ _) = z
333 middle (MidForeignCall {}) = z
334 middle (MidStore (CmmStackSlot a i) e) =
335 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
336 middle (MidStore _ _) = z
338 instance DefinerOfSlots Last where
339 foldSlotsDefd _ z _ = z
341 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
342 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
343 foldSlotsDefd _ z LastExit = z
345 ----------------------------------------------------------------------
346 ----- Code for manipulating Middle and Last nodes
348 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
349 mapExpMiddle _ m@(MidComment _) = m
350 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
351 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
352 mapExpMiddle exp (MidForeignCall s tgt fs as) =
353 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
355 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
356 foldExpMiddle _ (MidComment _) z = z
357 foldExpMiddle exp (MidAssign _ e) z = exp e z
358 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
359 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
361 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
362 mapExpLast _ l@(LastBranch _) = l
363 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
364 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
365 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
367 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
368 foldExpLast _ (LastBranch _) z = z
369 foldExpLast exp (LastCondBranch e _ _) z = exp e z
370 foldExpLast exp (LastSwitch e _) z = exp e z
371 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
373 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
374 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
375 mapExpMidcall _ m@(PrimTarget _) = m
377 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
378 foldExpMidcall exp (ForeignTarget e _) z = exp e z
379 foldExpMidcall _ (PrimTarget _) z = z
381 -- Take a transformer on expressions and apply it recursively.
382 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
383 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
384 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
387 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
388 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
389 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
390 mapExpDeepLast f = mapExpLast $ wrapRecExp f
392 -- Take a folder on expressions and apply it recursively.
393 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
394 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
395 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
396 wrapRecExpf f e z = f e z
398 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
399 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
400 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
401 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
403 ----------------------------------------------------------------------
404 -- Compute the join of facts live out of a Last node. Useful for most backward
406 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
407 joinOuts lattice env l =
408 let bot = fact_bot lattice
409 join x y = txVal $ fact_add_to lattice x y
411 (LastBranch id) -> env id
412 (LastCall _ Nothing _ _ _) -> bot
413 (LastCall _ (Just k) _ _ _) -> env k
414 (LastCondBranch _ t f) -> join (env t) (env f)
415 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
417 ----------------------------------------------------------------------
418 ----- Instance declarations for prettyprinting (avoids recursive imports)
420 instance Outputable Middle where
423 instance Outputable Last where
426 instance Outputable Convention where
429 instance Outputable ForeignConvention where
430 ppr = pprForeignConvention
432 instance Outputable ValueDirection where
433 ppr Arguments = ptext $ sLit "args"
434 ppr Results = ptext $ sLit "results"
436 instance DF.DebugNodes Middle Last
441 pprMiddle :: Middle -> SDoc
442 pprMiddle stmt = pp_stmt <+> pp_debug
444 pp_stmt = case stmt of
446 MidComment s -> text "//" <+> ftext s
449 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
452 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
454 rep = ppr ( cmmExprType expr )
456 -- call "ccall" foo(x, y)[r1, r2];
458 MidForeignCall safety target results args ->
459 hsep [ if null results
461 else parens (commafy $ map ppr results) <+> equals,
464 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
467 if not debugPpr then empty
470 MidComment {} -> text "MidComment"
471 MidAssign {} -> text "MidAssign"
472 MidStore {} -> text "MidStore"
473 MidForeignCall {} -> text "MidForeignCall"
475 ppr_fc :: ForeignConvention -> SDoc
476 ppr_fc (ForeignConvention c args res) =
477 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
479 ppr_safety :: ForeignSafety -> SDoc
480 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
481 ppr_safety Unsafe = text "unsafe"
483 ppr_call_target :: MidCallTarget -> SDoc
484 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
485 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
487 ppr_target :: CmmExpr -> SDoc
488 ppr_target t@(CmmLit _) = ppr t
489 ppr_target fn' = parens (ppr fn')
491 pprHinted :: Outputable a => CmmHinted a -> SDoc
492 pprHinted (CmmHinted a NoHint) = ppr a
493 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
494 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
496 pprLast :: Last -> SDoc
497 pprLast stmt = pp_stmt <+> pp_debug
499 pp_stmt = case stmt of
500 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
501 LastCondBranch expr t f -> genFullCondBranch expr t f
502 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
503 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
505 pp_debug = text " //" <+> case stmt of
506 LastBranch {} -> text "LastBranch"
507 LastCondBranch {} -> text "LastCondBranch"
508 LastSwitch {} -> text "LastSwitch"
509 LastCall {} -> text "LastCall"
511 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
512 Maybe UpdFrameOffset -> SDoc
513 genBareCall fn k out res updfr_off =
514 hcat [ ptext (sLit "call"), space
515 , pprFun fn, ptext (sLit "(...)"), space
516 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
518 , ptext (sLit " with update frame") <+> ppr updfr_off
521 pprFun :: CmmExpr -> SDoc
522 pprFun f@(CmmLit _) = ppr f
523 pprFun f = parens (ppr f)
525 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
526 genFullCondBranch expr t f =
527 hsep [ ptext (sLit "if")
529 , ptext (sLit "goto")
531 , ptext (sLit "else goto")
535 pprConvention :: Convention -> SDoc
536 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
537 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
538 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
539 pprConvention Slow = text "<slow-convention>"
540 pprConvention GC = text "<gc-convention>"
541 pprConvention PrimOpCall = text "<primop-call-convention>"
542 pprConvention PrimOpReturn = text "<primop-ret-convention>"
543 pprConvention (Foreign c) = ppr c
544 pprConvention (Private {}) = text "<private-convention>"
546 pprForeignConvention :: ForeignConvention -> SDoc
547 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
549 commafy :: [SDoc] -> SDoc
550 commafy xs = hsep $ punctuate comma xs