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 ZipCfg as Z
33 import qualified ZipDataflow as DF
42 import Prelude hiding (zip, unzip, last)
43 import qualified Data.List as L
44 import SMRep (ByteOff)
47 ----------------------------------------------------------------------
48 ----- Type synonyms and definitions
50 type CmmGraph = LGraph Middle Last
51 type CmmAGraph = AGraph Middle Last
52 type CmmBlock = Block Middle Last
53 type CmmStackInfo = (ByteOff, Maybe ByteOff)
54 -- probably want a record; (SP offset on entry, update frame space)
55 type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
56 type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
57 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
58 type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
60 type UpdFrameOffset = ByteOff
63 = MidComment FastString
65 | MidAssign CmmReg CmmExpr -- Assign to register
67 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
68 -- given by cmmExprType of the rhs.
70 | MidForeignCall -- A foreign call; see Note [Foreign calls]
71 ForeignSafety -- Is it a safe or unsafe call?
72 MidCallTarget -- call target and convention
73 CmmFormals -- zero or more results
74 CmmActuals -- zero or more arguments
78 = LastBranch BlockId -- Goto another block in the same procedure
80 | LastCondBranch { -- conditional branch
82 cml_true, cml_false :: BlockId
84 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
85 -- The scrutinee is zero-based;
86 -- zero -> first block
87 -- one -> second block etc
88 -- Undefined outside range, and when there's a Nothing
89 | LastCall { -- A call (native or safe foreign)
90 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
91 cml_cont :: Maybe BlockId,
92 -- BlockId of continuation (Nothing for return or tail call)
93 cml_args :: ByteOff, -- byte offset for youngest outgoing arg
94 -- (includes update frame, which must be younger)
95 cml_ret_args:: ByteOff, -- byte offset for youngest incoming arg
96 cml_ret_off :: Maybe UpdFrameOffset}
97 -- stack offset for return (update frames);
98 -- The return offset should be Nothing only if we have to create
99 -- a new call, e.g. for a procpoint, in which case it's an invariant
100 -- that the call does not stand for a return or a tail call,
101 -- and the successor does not need an info table.
103 data MidCallTarget -- The target of a MidUnsafeCall
104 = ForeignTarget -- A foreign procedure
105 CmmExpr -- Its address
106 ForeignConvention -- Its calling convention
108 | PrimTarget -- A possibly-side-effecting machine operation
109 CallishMachOp -- Which one
113 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
115 | NativeNodeCall -- Native C-- call including the node argument
117 | NativeReturn -- Native C-- return
119 | Slow -- Slow entry points: all args pushed on the stack
121 | GC -- Entry to the garbage collector: uses the node reg!
123 | PrimOpCall -- Calling prim ops
125 | PrimOpReturn -- Returning from prim ops
127 | Foreign -- Foreign call/return
131 -- Used for control transfers within a (pre-CPS) procedure All
132 -- jump sites known, never pushed on the stack (hence no SRT)
133 -- You can choose whatever calling convention you please
134 -- (provided you make sure all the call sites agree)!
135 -- This data type eventually to be extended to record the convention.
138 data ForeignConvention
140 CCallConv -- Which foreign-call convention
141 [ForeignHint] -- Extra info about the args
142 [ForeignHint] -- Extra info about the result
146 = Unsafe -- unsafe call
147 | Safe BlockId -- making infotable requires: 1. label
148 UpdFrameOffset -- 2. where the upd frame is
151 data ValueDirection = Arguments | Results
152 -- Arguments go with procedure definitions, jumps, and arguments to calls
153 -- Results go with returns and with results of calls.
156 {- Note [Foreign calls]
157 ~~~~~~~~~~~~~~~~~~~~~~~
158 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
159 Unsafe ones are easy: think of them as a "fat machine instruction".
161 Safe ones are trickier. A safe foreign call
163 ultimately expands to
164 push "return address" -- Never used to return to;
165 -- just points an info table
166 save registers into TSO
168 r = f(x) -- Make the call
172 We cannot "lower" a safe foreign call to this sequence of Cmms, because
173 after we've saved Sp all the Cmm optimiser's assumptions are broken.
174 Furthermore, currently the smart Cmm constructors know the calling
175 conventions for Haskell, the garbage collector, etc, and "lower" them
176 so that a LastCall passes no parameters or results. But the smart
177 constructors do *not* (currently) know the foreign call conventions.
179 For these reasons use MidForeignCall for all calls. The only annoying thing
180 is that a safe foreign call needs an info table.
183 ----------------------------------------------------------------------
184 ----- Splicing between blocks
185 -- Given a middle node, a block, and a successor BlockId,
186 -- we can insert the middle node between the block and the successor.
187 -- We return the updated block and a list of new blocks that must be added
189 -- The semantics is a bit tricky. We consider cases on the last node:
190 -- o For a branch, we can just insert before the branch,
191 -- but sometimes the optimizer does better if we actually insert
192 -- a fresh basic block, enabling some common blockification.
193 -- o For a conditional branch, switch statement, or call, we must insert
194 -- a new basic block.
195 -- o For a jump or return, this operation is impossible.
197 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
198 insertBetween b ms succId = insert $ goto_end $ unzip b
199 where insert (h, LastOther (LastBranch bid)) =
200 if bid == succId then
201 do (bid', bs) <- newBlocks
202 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
203 else panic "tried invalid block insertBetween"
204 insert (h, LastOther (LastCondBranch c t f)) =
205 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
206 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
207 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
208 insert (h, LastOther (LastSwitch e ks)) =
209 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
210 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
211 insert (_, LastOther (LastCall {})) =
212 panic "unimp: insertBetween after a call -- probably not a good idea"
213 insert (_, LastExit) = panic "cannot insert after exit"
214 newBlocks = do id <- liftM BlockId $ getUniqueM
215 return $ (id, [Block id $
216 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
217 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
218 else return (Just k, [])
219 mbNewBlocks Nothing = return (Nothing, [])
220 lift (id, bs) = (Just id, bs)
222 ----------------------------------------------------------------------
223 ----- Instance declarations for control flow
225 instance HavingSuccessors Last where
227 fold_succs = fold_cmm_succs
229 instance LastNode Last where
230 mkBranchNode id = LastBranch id
231 isBranchNode (LastBranch _) = True
232 isBranchNode _ = False
233 branchNodeTarget (LastBranch id) = id
234 branchNodeTarget _ = panic "asked for target of non-branch"
236 cmmSuccs :: Last -> [BlockId]
237 cmmSuccs (LastBranch id) = [id]
238 cmmSuccs (LastCall _ Nothing _ _ _) = []
239 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
240 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
241 cmmSuccs (LastSwitch _ edges) = catMaybes edges
243 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
244 fold_cmm_succs f (LastBranch id) z = f id z
245 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
246 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
247 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
248 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
250 ----------------------------------------------------------------------
251 ----- Instance declarations for register use
253 instance UserOfLocalRegs Middle where
254 foldRegsUsed f z m = middle m
255 where middle (MidComment {}) = z
256 middle (MidAssign _lhs expr) = fold f z expr
257 middle (MidStore addr rval) = fold f (fold f z addr) rval
258 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
259 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
261 instance UserOfLocalRegs MidCallTarget where
262 foldRegsUsed _f z (PrimTarget _) = z
263 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
265 instance UserOfSlots MidCallTarget where
266 foldSlotsUsed _f z (PrimTarget _) = z
267 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
269 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
270 foldRegsUsed f z (Just x) = foldRegsUsed f z x
271 foldRegsUsed _ z Nothing = z
273 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
274 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
275 foldSlotsUsed _ z Nothing = z
277 instance UserOfLocalRegs Last where
278 foldRegsUsed f z l = last l
279 where last (LastBranch _id) = z
280 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
281 last (LastCondBranch e _ _) = foldRegsUsed f z e
282 last (LastSwitch e _tbl) = foldRegsUsed f z e
284 instance DefinerOfLocalRegs Middle where
285 foldRegsDefd f z m = middle m
286 where middle (MidComment {}) = z
287 middle (MidAssign lhs _) = fold f z lhs
288 middle (MidStore _ _) = z
289 middle (MidForeignCall _ _ fs _) = fold f z fs
290 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
292 instance DefinerOfLocalRegs Last where
293 foldRegsDefd _ z _ = z
296 ----------------------------------------------------------------------
297 ----- Instance declarations for stack slot use
299 instance UserOfSlots Middle where
300 foldSlotsUsed f z m = middle m
301 where middle (MidComment {}) = z
302 middle (MidAssign _lhs expr) = fold f z expr
303 middle (MidStore addr rval) = fold f (fold f z addr) rval
304 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
305 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
307 instance UserOfSlots Last where
308 foldSlotsUsed f z l = last l
309 where last (LastBranch _id) = z
310 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
311 last (LastCondBranch e _ _) = foldSlotsUsed f z e
312 last (LastSwitch e _tbl) = foldSlotsUsed f z e
314 instance UserOfSlots l => UserOfSlots (ZLast l) where
315 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
316 foldSlotsUsed _ z LastExit = z
318 instance DefinerOfSlots Middle where
319 foldSlotsDefd f z m = middle m
320 where middle (MidComment {}) = z
321 middle (MidAssign _ _) = z
322 middle (MidForeignCall {}) = z
323 middle (MidStore (CmmStackSlot a i) e) =
324 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
325 middle (MidStore _ _) = z
327 instance DefinerOfSlots Last where
328 foldSlotsDefd _ z _ = z
330 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
331 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
332 foldSlotsDefd _ z LastExit = z
334 ----------------------------------------------------------------------
335 ----- Code for manipulating Middle and Last nodes
337 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
338 mapExpMiddle _ m@(MidComment _) = m
339 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
340 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
341 mapExpMiddle exp (MidForeignCall s tgt fs as) =
342 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
344 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
345 foldExpMiddle _ (MidComment _) z = z
346 foldExpMiddle exp (MidAssign _ e) z = exp e z
347 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
348 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
350 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
351 mapExpLast _ l@(LastBranch _) = l
352 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
353 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
354 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
356 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
357 foldExpLast _ (LastBranch _) z = z
358 foldExpLast exp (LastCondBranch e _ _) z = exp e z
359 foldExpLast exp (LastSwitch e _) z = exp e z
360 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
362 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
363 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
364 mapExpMidcall _ m@(PrimTarget _) = m
366 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
367 foldExpMidcall exp (ForeignTarget e _) z = exp e z
368 foldExpMidcall _ (PrimTarget _) z = z
370 -- Take a transformer on expressions and apply it recursively.
371 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
372 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
373 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
376 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
377 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
378 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
379 mapExpDeepLast f = mapExpLast $ wrapRecExp f
381 -- Take a folder on expressions and apply it recursively.
382 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
383 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
384 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
385 wrapRecExpf f e z = f e z
387 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
388 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
389 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
390 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
392 ----------------------------------------------------------------------
393 -- Compute the join of facts live out of a Last node. Useful for most backward
395 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
396 joinOuts lattice env l =
397 let bot = fact_bot lattice
398 join x y = txVal $ fact_add_to lattice x y
400 (LastBranch id) -> env id
401 (LastCall _ Nothing _ _ _) -> bot
402 (LastCall _ (Just k) _ _ _) -> env k
403 (LastCondBranch _ t f) -> join (env t) (env f)
404 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
406 ----------------------------------------------------------------------
407 ----- Instance declarations for prettyprinting (avoids recursive imports)
409 instance Outputable Middle where
412 instance Outputable Last where
415 instance Outputable Convention where
418 instance Outputable ForeignConvention where
419 ppr = pprForeignConvention
421 instance Outputable ValueDirection where
422 ppr Arguments = ptext $ sLit "args"
423 ppr Results = ptext $ sLit "results"
425 instance DF.DebugNodes Middle Last
430 pprMiddle :: Middle -> SDoc
431 pprMiddle stmt = pp_stmt <+> pp_debug
433 pp_stmt = case stmt of
435 MidComment s -> text "//" <+> ftext s
438 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
441 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
443 rep = ppr ( cmmExprType expr )
445 -- call "ccall" foo(x, y)[r1, r2];
447 MidForeignCall safety target results args ->
448 hsep [ if null results
450 else parens (commafy $ map ppr results) <+> equals,
453 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
456 if not debugPpr then empty
459 MidComment {} -> text "MidComment"
460 MidAssign {} -> text "MidAssign"
461 MidStore {} -> text "MidStore"
462 MidForeignCall {} -> text "MidForeignCall"
464 ppr_fc :: ForeignConvention -> SDoc
465 ppr_fc (ForeignConvention c args res) =
466 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
468 ppr_safety :: ForeignSafety -> SDoc
469 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
470 ppr_safety Unsafe = text "unsafe"
472 ppr_call_target :: MidCallTarget -> SDoc
473 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
474 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
476 ppr_target :: CmmExpr -> SDoc
477 ppr_target t@(CmmLit _) = ppr t
478 ppr_target fn' = parens (ppr fn')
480 pprHinted :: Outputable a => CmmHinted a -> SDoc
481 pprHinted (CmmHinted a NoHint) = ppr a
482 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
483 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
485 pprLast :: Last -> SDoc
486 pprLast stmt = pp_stmt <+> pp_debug
488 pp_stmt = case stmt of
489 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
490 LastCondBranch expr t f -> genFullCondBranch expr t f
491 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
492 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
494 pp_debug = text " //" <+> case stmt of
495 LastBranch {} -> text "LastBranch"
496 LastCondBranch {} -> text "LastCondBranch"
497 LastSwitch {} -> text "LastSwitch"
498 LastCall {} -> text "LastCall"
500 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
501 Maybe UpdFrameOffset -> SDoc
502 genBareCall fn k out res updfr_off =
503 hcat [ ptext (sLit "call"), space
504 , pprFun fn, ptext (sLit "(...)"), space
505 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
507 , ptext (sLit " with update frame") <+> ppr updfr_off
510 pprFun :: CmmExpr -> SDoc
511 pprFun f@(CmmLit _) = ppr f
512 pprFun f = parens (ppr f)
514 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
515 genFullCondBranch expr t f =
516 hsep [ ptext (sLit "if")
518 , ptext (sLit "goto")
520 , ptext (sLit "else goto")
524 pprConvention :: Convention -> SDoc
525 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
526 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
527 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
528 pprConvention Slow = text "<slow-convention>"
529 pprConvention GC = text "<gc-convention>"
530 pprConvention PrimOpCall = text "<primop-call-convention>"
531 pprConvention PrimOpReturn = text "<primop-ret-convention>"
532 pprConvention (Foreign c) = ppr c
533 pprConvention (Private {}) = text "<private-convention>"
535 pprForeignConvention :: ForeignConvention -> SDoc
536 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
538 commafy :: [SDoc] -> SDoc
539 commafy xs = hsep $ punctuate comma xs