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 ByteOff
107 -- For calls *only*, the byte offset of the base of the frame that
108 -- must be described by the info table for the return point.
109 -- The older words are an update frames, which have their own
110 -- info-table and layout information
112 -- From a liveness point of view, the stack words older than
113 -- cml_ret_off are treated as live, even if the sequel of
114 -- the call goes into a loop.
117 data MidCallTarget -- The target of a MidUnsafeCall
118 = ForeignTarget -- A foreign procedure
119 CmmExpr -- Its address
120 ForeignConvention -- Its calling convention
122 | PrimTarget -- A possibly-side-effecting machine operation
123 CallishMachOp -- Which one
127 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
129 | NativeNodeCall -- Native C-- call including the node argument
131 | NativeReturn -- Native C-- return
133 | Slow -- Slow entry points: all args pushed on the stack
135 | GC -- Entry to the garbage collector: uses the node reg!
137 | PrimOpCall -- Calling prim ops
139 | PrimOpReturn -- Returning from prim ops
141 | Foreign -- Foreign call/return
145 -- Used for control transfers within a (pre-CPS) procedure All
146 -- jump sites known, never pushed on the stack (hence no SRT)
147 -- You can choose whatever calling convention you please
148 -- (provided you make sure all the call sites agree)!
149 -- This data type eventually to be extended to record the convention.
152 data ForeignConvention
154 CCallConv -- Which foreign-call convention
155 [ForeignHint] -- Extra info about the args
156 [ForeignHint] -- Extra info about the result
160 = Unsafe -- unsafe call
161 | Safe BlockId -- making infotable requires: 1. label
162 UpdFrameOffset -- 2. where the upd frame is
165 data ValueDirection = Arguments | Results
166 -- Arguments go with procedure definitions, jumps, and arguments to calls
167 -- Results go with returns and with results of calls.
170 {- Note [Foreign calls]
171 ~~~~~~~~~~~~~~~~~~~~~~~
172 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
173 Unsafe ones are easy: think of them as a "fat machine instruction".
175 Safe ones are trickier. A safe foreign call
177 ultimately expands to
178 push "return address" -- Never used to return to;
179 -- just points an info table
180 save registers into TSO
182 r = f(x) -- Make the call
186 We cannot "lower" a safe foreign call to this sequence of Cmms, because
187 after we've saved Sp all the Cmm optimiser's assumptions are broken.
188 Furthermore, currently the smart Cmm constructors know the calling
189 conventions for Haskell, the garbage collector, etc, and "lower" them
190 so that a LastCall passes no parameters or results. But the smart
191 constructors do *not* (currently) know the foreign call conventions.
193 For these reasons use MidForeignCall for all calls. The only annoying thing
194 is that a safe foreign call needs an info table.
197 ----------------------------------------------------------------------
198 ----- Splicing between blocks
199 -- Given a middle node, a block, and a successor BlockId,
200 -- we can insert the middle node between the block and the successor.
201 -- We return the updated block and a list of new blocks that must be added
203 -- The semantics is a bit tricky. We consider cases on the last node:
204 -- o For a branch, we can just insert before the branch,
205 -- but sometimes the optimizer does better if we actually insert
206 -- a fresh basic block, enabling some common blockification.
207 -- o For a conditional branch, switch statement, or call, we must insert
208 -- a new basic block.
209 -- o For a jump or return, this operation is impossible.
211 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
212 insertBetween b ms succId = insert $ goto_end $ unzip b
213 where insert (h, LastOther (LastBranch bid)) =
214 if bid == succId then
215 do (bid', bs) <- newBlocks
216 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
217 else panic "tried invalid block insertBetween"
218 insert (h, LastOther (LastCondBranch c t f)) =
219 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
220 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
221 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
222 insert (h, LastOther (LastSwitch e ks)) =
223 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
224 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
225 insert (_, LastOther (LastCall {})) =
226 panic "unimp: insertBetween after a call -- probably not a good idea"
227 insert (_, LastExit) = panic "cannot insert after exit"
228 newBlocks = do id <- liftM BlockId $ getUniqueM
229 return $ (id, [Block id $
230 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
231 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
232 else return (Just k, [])
233 mbNewBlocks Nothing = return (Nothing, [])
234 lift (id, bs) = (Just id, bs)
236 ----------------------------------------------------------------------
237 ----- Instance declarations for control flow
239 instance HavingSuccessors Last where
241 fold_succs = fold_cmm_succs
243 instance LastNode Last where
244 mkBranchNode id = LastBranch id
245 isBranchNode (LastBranch _) = True
246 isBranchNode _ = False
247 branchNodeTarget (LastBranch id) = id
248 branchNodeTarget _ = panic "asked for target of non-branch"
250 cmmSuccs :: Last -> [BlockId]
251 cmmSuccs (LastBranch id) = [id]
252 cmmSuccs (LastCall _ Nothing _ _ _) = []
253 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
254 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
255 cmmSuccs (LastSwitch _ edges) = catMaybes edges
257 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
258 fold_cmm_succs f (LastBranch id) z = f id z
259 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
260 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
261 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
262 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
264 ----------------------------------------------------------------------
265 ----- Instance declarations for register use
267 instance UserOfLocalRegs Middle where
268 foldRegsUsed f z m = middle m
269 where middle (MidComment {}) = z
270 middle (MidAssign _lhs expr) = fold f z expr
271 middle (MidStore addr rval) = fold f (fold f z addr) rval
272 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
273 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
275 instance UserOfLocalRegs MidCallTarget where
276 foldRegsUsed _f z (PrimTarget _) = z
277 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
279 instance UserOfSlots MidCallTarget where
280 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
281 foldSlotsUsed _f z (PrimTarget _) = z
283 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
284 foldRegsUsed f z (Just x) = foldRegsUsed f z x
285 foldRegsUsed _ z Nothing = z
287 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
288 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
289 foldSlotsUsed _ z Nothing = z
291 instance UserOfLocalRegs Last where
292 foldRegsUsed f z l = last l
293 where last (LastBranch _id) = z
294 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
295 last (LastCondBranch e _ _) = foldRegsUsed f z e
296 last (LastSwitch e _tbl) = foldRegsUsed f z e
298 instance DefinerOfLocalRegs Middle where
299 foldRegsDefd f z m = middle m
300 where middle (MidComment {}) = z
301 middle (MidAssign lhs _) = fold f z lhs
302 middle (MidStore _ _) = z
303 middle (MidForeignCall _ _ fs _) = fold f z fs
304 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
306 instance DefinerOfLocalRegs Last where
307 foldRegsDefd _ z _ = z
310 ----------------------------------------------------------------------
311 ----- Instance declarations for stack slot use
313 instance UserOfSlots Middle where
314 foldSlotsUsed f z m = middle m
315 where middle (MidComment {}) = z
316 middle (MidAssign _lhs expr) = fold f z expr
317 middle (MidStore addr rval) = fold f (fold f z addr) rval
318 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
319 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
321 instance UserOfSlots Last where
322 foldSlotsUsed f z l = last l
323 where last (LastBranch _id) = z
324 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
325 last (LastCondBranch e _ _) = foldSlotsUsed f z e
326 last (LastSwitch e _tbl) = foldSlotsUsed f z e
328 instance UserOfSlots l => UserOfSlots (ZLast l) where
329 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
330 foldSlotsUsed _ z LastExit = z
332 instance DefinerOfSlots Middle where
333 foldSlotsDefd f z m = middle m
334 where middle (MidComment {}) = z
335 middle (MidAssign _ _) = z
336 middle (MidForeignCall {}) = z
337 middle (MidStore (CmmStackSlot a i) e) =
338 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
339 middle (MidStore _ _) = z
341 instance DefinerOfSlots Last where
342 foldSlotsDefd _ z _ = z
344 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
345 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
346 foldSlotsDefd _ z LastExit = z
348 ----------------------------------------------------------------------
349 ----- Code for manipulating Middle and Last nodes
351 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
352 mapExpMiddle _ m@(MidComment _) = m
353 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
354 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
355 mapExpMiddle exp (MidForeignCall s tgt fs as) =
356 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
358 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
359 foldExpMiddle _ (MidComment _) z = z
360 foldExpMiddle exp (MidAssign _ e) z = exp e z
361 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
362 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
364 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
365 mapExpLast _ l@(LastBranch _) = l
366 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
367 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
368 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
370 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
371 foldExpLast _ (LastBranch _) z = z
372 foldExpLast exp (LastCondBranch e _ _) z = exp e z
373 foldExpLast exp (LastSwitch e _) z = exp e z
374 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
376 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
377 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
378 mapExpMidcall _ m@(PrimTarget _) = m
380 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
381 foldExpMidcall exp (ForeignTarget e _) z = exp e z
382 foldExpMidcall _ (PrimTarget _) z = z
384 -- Take a transformer on expressions and apply it recursively.
385 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
386 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
387 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
390 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
391 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
392 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
393 mapExpDeepLast f = mapExpLast $ wrapRecExp f
395 -- Take a folder on expressions and apply it recursively.
396 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
397 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
398 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
399 wrapRecExpf f e z = f e z
401 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
402 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
403 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
404 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
406 ----------------------------------------------------------------------
407 -- Compute the join of facts live out of a Last node. Useful for most backward
409 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
410 joinOuts lattice env l =
411 let bot = fact_bot lattice
412 join x y = txVal $ fact_add_to lattice x y
414 (LastBranch id) -> env id
415 (LastCall _ Nothing _ _ _) -> bot
416 (LastCall _ (Just k) _ _ _) -> env k
417 (LastCondBranch _ t f) -> join (env t) (env f)
418 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
420 ----------------------------------------------------------------------
421 ----- Instance declarations for prettyprinting (avoids recursive imports)
423 instance Outputable Middle where
426 instance Outputable Last where
429 instance Outputable Convention where
432 instance Outputable ForeignConvention where
433 ppr = pprForeignConvention
435 instance Outputable ValueDirection where
436 ppr Arguments = ptext $ sLit "args"
437 ppr Results = ptext $ sLit "results"
439 instance DF.DebugNodes Middle Last
444 pprMiddle :: Middle -> SDoc
445 pprMiddle stmt = pp_stmt <+> pp_debug
447 pp_stmt = case stmt of
449 MidComment s -> text "//" <+> ftext s
452 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
455 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
457 rep = ppr ( cmmExprType expr )
459 -- call "ccall" foo(x, y)[r1, r2];
461 MidForeignCall safety target results args ->
462 hsep [ ppUnless (null results) $
463 parens (commafy $ map ppr results) <+> equals,
466 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
469 if not debugPpr then empty
472 MidComment {} -> text "MidComment"
473 MidAssign {} -> text "MidAssign"
474 MidStore {} -> text "MidStore"
475 MidForeignCall {} -> text "MidForeignCall"
477 ppr_fc :: ForeignConvention -> SDoc
478 ppr_fc (ForeignConvention c args res) =
479 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
481 ppr_safety :: ForeignSafety -> SDoc
482 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
483 ppr_safety Unsafe = text "unsafe"
485 ppr_call_target :: MidCallTarget -> SDoc
486 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
487 ppr_call_target (PrimTarget op)
488 -- HACK: We're just using a ForeignLabel to get this printed, the label
489 -- might not really be foreign.
490 = ppr (CmmLabel (mkForeignLabel
491 (mkFastString (show op))
492 Nothing ForeignLabelInThisPackage IsFunction))
494 ppr_target :: CmmExpr -> SDoc
495 ppr_target t@(CmmLit _) = ppr t
496 ppr_target fn' = parens (ppr fn')
498 pprHinted :: Outputable a => CmmHinted a -> SDoc
499 pprHinted (CmmHinted a NoHint) = ppr a
500 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
501 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
503 pprLast :: Last -> SDoc
504 pprLast stmt = pp_stmt <+> pp_debug
506 pp_stmt = case stmt of
507 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
508 LastCondBranch expr t f -> genFullCondBranch expr t f
509 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
510 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
512 pp_debug = text " //" <+> case stmt of
513 LastBranch {} -> text "LastBranch"
514 LastCondBranch {} -> text "LastCondBranch"
515 LastSwitch {} -> text "LastSwitch"
516 LastCall {} -> text "LastCall"
518 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
519 Maybe UpdFrameOffset -> SDoc
520 genBareCall fn k out res updfr_off =
521 hcat [ ptext (sLit "call"), space
522 , pprFun fn, ptext (sLit "(...)"), space
523 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
525 , ptext (sLit " with update frame") <+> ppr updfr_off
528 pprFun :: CmmExpr -> SDoc
529 pprFun f@(CmmLit _) = ppr f
530 pprFun f = parens (ppr f)
532 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
533 genFullCondBranch expr t f =
534 hsep [ ptext (sLit "if")
536 , ptext (sLit "goto")
538 , ptext (sLit "else goto")
542 pprConvention :: Convention -> SDoc
543 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
544 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
545 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
546 pprConvention Slow = text "<slow-convention>"
547 pprConvention GC = text "<gc-convention>"
548 pprConvention PrimOpCall = text "<primop-call-convention>"
549 pprConvention PrimOpReturn = text "<primop-ret-convention>"
550 pprConvention (Foreign c) = ppr c
551 pprConvention (Private {}) = text "<private-convention>"
553 pprForeignConvention :: ForeignConvention -> SDoc
554 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
556 commafy :: [SDoc] -> SDoc
557 commafy xs = hsep $ punctuate comma xs