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 CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
54 type CmmTopZ = GenCmmTop CmmStatic CmmInfo 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!
89 cml_cont :: Maybe BlockId,
90 -- BlockId of continuation (Nothing for return or tail call)
91 cml_args :: ByteOff, -- byte offset for youngest outgoing arg
92 -- (includes update frame, which must be younger)
93 cml_ret_off :: Maybe UpdFrameOffset}
94 -- stack offset for return (update frames);
95 -- The return offset should be Nothing only if we have to create
96 -- a new call, e.g. for a procpoint, in which case it's an invariant
97 -- that the call does not stand for a return or a tail call,
98 -- and the successor does not need an info table.
100 data MidCallTarget -- The target of a MidUnsafeCall
101 = ForeignTarget -- A foreign procedure
102 CmmExpr -- Its address
103 ForeignConvention -- Its calling convention
105 | PrimTarget -- A possibly-side-effecting machine operation
106 CallishMachOp -- Which one
110 = Native -- Native C-- call/return
112 | Slow -- Slow entry points: all args pushed on the stack
114 | GC -- Entry to the garbage collector: uses the node reg!
116 | PrimOp -- Calling prim ops
118 | Foreign -- Foreign call/return
122 -- Used for control transfers within a (pre-CPS) procedure All
123 -- jump sites known, never pushed on the stack (hence no SRT)
124 -- You can choose whatever calling convention you please
125 -- (provided you make sure all the call sites agree)!
126 -- This data type eventually to be extended to record the convention.
129 data ForeignConvention
131 CCallConv -- Which foreign-call convention
132 [ForeignHint] -- Extra info about the args
133 [ForeignHint] -- Extra info about the result
137 = Unsafe -- unsafe call
138 | Safe BlockId -- making infotable requires: 1. label
139 UpdFrameOffset -- 2. where the upd frame is
142 data ValueDirection = Arguments | Results
143 -- Arguments go with procedure definitions, jumps, and arguments to calls
144 -- Results go with returns and with results of calls.
147 {- Note [Foreign calls]
148 ~~~~~~~~~~~~~~~~~~~~~~~
149 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
150 Unsafe ones are easy: think of them as a "fat machine instruction".
152 Safe ones are trickier. A safe foreign call
154 ultimately expands to
155 push "return address" -- Never used to return to;
156 -- just points an info table
157 save registers into TSO
159 r = f(x) -- Make the call
163 We cannot "lower" a safe foreign call to this sequence of Cmms, because
164 after we've saved Sp all the Cmm optimiser's assumptions are broken.
165 Furthermore, currently the smart Cmm constructors know the calling
166 conventions for Haskell, the garbage collector, etc, and "lower" them
167 so that a LastCall passes no parameters or results. But the smart
168 constructors do *not* (currently) know the foreign call conventions.
170 For these reasons use MidForeignCall for all calls. The only annoying thing
171 is that a safe foreign call needs an info table.
174 ----------------------------------------------------------------------
175 ----- Splicing between blocks
176 -- Given a middle node, a block, and a successor BlockId,
177 -- we can insert the middle node between the block and the successor.
178 -- We return the updated block and a list of new blocks that must be added
180 -- The semantics is a bit tricky. We consider cases on the last node:
181 -- o For a branch, we can just insert before the branch,
182 -- but sometimes the optimizer does better if we actually insert
183 -- a fresh basic block, enabling some common blockification.
184 -- o For a conditional branch, switch statement, or call, we must insert
185 -- a new basic block.
186 -- o For a jump or return, this operation is impossible.
188 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
189 insertBetween b ms succId = insert $ goto_end $ unzip b
190 where insert (h, LastOther (LastBranch bid)) =
191 if bid == succId then
192 do (bid', bs) <- newBlocks
193 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
194 else panic "tried invalid block insertBetween"
195 insert (h, LastOther (LastCondBranch c t f)) =
196 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
197 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
198 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
199 insert (h, LastOther (LastSwitch e ks)) =
200 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
201 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
202 insert (_, LastOther (LastCall {})) =
203 panic "unimp: insertBetween after a call -- probably not a good idea"
204 insert (_, LastExit) = panic "cannot insert after exit"
205 newBlocks = do id <- liftM BlockId $ getUniqueM
206 return $ (id, [Block id emptyStackInfo $
207 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
208 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
209 else return (Just k, [])
210 mbNewBlocks Nothing = return (Nothing, [])
211 lift (id, bs) = (Just id, bs)
213 ----------------------------------------------------------------------
214 ----- Instance declarations for control flow
216 instance HavingSuccessors Last where
218 fold_succs = fold_cmm_succs
220 instance LastNode Last where
221 mkBranchNode id = LastBranch id
222 isBranchNode (LastBranch _) = True
223 isBranchNode _ = False
224 branchNodeTarget (LastBranch id) = id
225 branchNodeTarget _ = panic "asked for target of non-branch"
227 cmmSuccs :: Last -> [BlockId]
228 cmmSuccs (LastBranch id) = [id]
229 cmmSuccs (LastCall _ Nothing _ _) = []
230 cmmSuccs (LastCall _ (Just id) _ _) = [id]
231 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
232 cmmSuccs (LastSwitch _ edges) = catMaybes edges
234 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
235 fold_cmm_succs f (LastBranch id) z = f id z
236 fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
237 fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
238 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
239 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
241 ----------------------------------------------------------------------
242 ----- Instance declarations for register use
244 instance UserOfLocalRegs Middle where
245 foldRegsUsed f z m = middle m
246 where middle (MidComment {}) = z
247 middle (MidAssign _lhs expr) = fold f z expr
248 middle (MidStore addr rval) = fold f (fold f z addr) rval
249 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
250 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
252 instance UserOfLocalRegs MidCallTarget where
253 foldRegsUsed _f z (PrimTarget _) = z
254 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
256 instance UserOfSlots MidCallTarget where
257 foldSlotsUsed _f z (PrimTarget _) = z
258 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
260 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
261 foldRegsUsed f z (Just x) = foldRegsUsed f z x
262 foldRegsUsed _ z Nothing = z
264 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
265 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
266 foldSlotsUsed _ z Nothing = z
268 instance UserOfLocalRegs Last where
269 foldRegsUsed f z l = last l
270 where last (LastBranch _id) = z
271 last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
272 last (LastCondBranch e _ _) = foldRegsUsed f z e
273 last (LastSwitch e _tbl) = foldRegsUsed f z e
275 instance DefinerOfLocalRegs Middle where
276 foldRegsDefd f z m = middle m
277 where middle (MidComment {}) = z
278 middle (MidAssign _lhs _) = fold f z _lhs
279 middle (MidStore _ _) = z
280 middle (MidForeignCall _ _ fs _) = fold f z fs
281 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
283 instance DefinerOfLocalRegs Last where
284 foldRegsDefd _ z _ = z
287 ----------------------------------------------------------------------
288 ----- Instance declarations for stack slot use
290 instance UserOfSlots Middle where
291 foldSlotsUsed f z m = middle m
292 where middle (MidComment {}) = z
293 middle (MidAssign _lhs expr) = fold f z expr
294 middle (MidStore addr rval) = fold f (fold f z addr) rval
295 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
296 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
298 instance UserOfSlots Last where
299 foldSlotsUsed f z l = last l
300 where last (LastBranch _id) = z
301 last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
302 last (LastCondBranch e _ _) = foldSlotsUsed f z e
303 last (LastSwitch e _tbl) = foldSlotsUsed f z e
305 instance UserOfSlots l => UserOfSlots (ZLast l) where
306 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
307 foldSlotsUsed _ z LastExit = z
309 instance DefinerOfSlots Middle where
310 foldSlotsDefd f z m = middle m
311 where middle (MidComment {}) = z
312 middle (MidAssign _ _) = z
313 middle (MidForeignCall {}) = z
314 middle (MidStore (CmmStackSlot a i) e) =
315 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
316 middle (MidStore _ _) = z
318 instance DefinerOfSlots Last where
319 foldSlotsDefd _ z _ = z
321 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
322 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
323 foldSlotsDefd _ z LastExit = z
325 ----------------------------------------------------------------------
326 ----- Code for manipulating Middle and Last nodes
328 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
329 mapExpMiddle _ m@(MidComment _) = m
330 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
331 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
332 mapExpMiddle exp (MidForeignCall s tgt fs as) =
333 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
335 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
336 foldExpMiddle _ (MidComment _) z = z
337 foldExpMiddle exp (MidAssign _ e) z = exp e z
338 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
339 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
341 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
342 mapExpLast _ l@(LastBranch _) = l
343 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
344 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
345 mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
347 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
348 foldExpLast _ (LastBranch _) z = z
349 foldExpLast exp (LastCondBranch e _ _) z = exp e z
350 foldExpLast exp (LastSwitch e _) z = exp e z
351 foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
353 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
354 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
355 mapExpMidcall _ m@(PrimTarget _) = m
357 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
358 foldExpMidcall exp (ForeignTarget e _) z = exp e z
359 foldExpMidcall _ (PrimTarget _) z = z
361 -- Take a transformer on expressions and apply it recursively.
362 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
363 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
364 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
367 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
368 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
369 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
370 mapExpDeepLast f = mapExpLast $ wrapRecExp f
372 -- Take a folder on expressions and apply it recursively.
373 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
374 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
375 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
376 wrapRecExpf f e z = f e z
378 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
379 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
380 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
381 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
383 ----------------------------------------------------------------------
384 -- Compute the join of facts live out of a Last node. Useful for most backward
386 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
387 joinOuts lattice env l =
388 let bot = fact_bot lattice
389 join x y = txVal $ fact_add_to lattice x y
391 (LastBranch id) -> env id
392 (LastCall _ Nothing _ _) -> bot
393 (LastCall _ (Just k) _ _) -> env k
394 (LastCondBranch _ t f) -> join (env t) (env f)
395 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
397 ----------------------------------------------------------------------
398 ----- Instance declarations for prettyprinting (avoids recursive imports)
400 instance Outputable Middle where
403 instance Outputable Last where
406 instance Outputable Convention where
409 instance Outputable ForeignConvention where
410 ppr = pprForeignConvention
412 instance Outputable ValueDirection where
413 ppr Arguments = ptext $ sLit "args"
414 ppr Results = ptext $ sLit "results"
416 instance DF.DebugNodes Middle Last
421 pprMiddle :: Middle -> SDoc
422 pprMiddle stmt = pp_stmt <+> pp_debug
424 pp_stmt = case stmt of
426 MidComment s -> text "//" <+> ftext s
429 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
432 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
434 rep = ppr ( cmmExprType expr )
436 -- call "ccall" foo(x, y)[r1, r2];
438 MidForeignCall safety target results args ->
439 hsep [ if null results
441 else parens (commafy $ map ppr results) <+> equals,
444 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
447 if not debugPpr then empty
450 MidComment {} -> text "MidComment"
451 MidAssign {} -> text "MidAssign"
452 MidStore {} -> text "MidStore"
453 MidForeignCall {} -> text "MidForeignCall"
455 ppr_fc :: ForeignConvention -> SDoc
456 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
458 ppr_safety :: ForeignSafety -> SDoc
459 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
460 ppr_safety Unsafe = text "unsafe"
462 ppr_call_target :: MidCallTarget -> SDoc
463 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
464 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
466 ppr_target :: CmmExpr -> SDoc
467 ppr_target t@(CmmLit _) = ppr t
468 ppr_target fn' = parens (ppr fn')
470 pprHinted :: Outputable a => CmmHinted a -> SDoc
471 pprHinted (CmmHinted a NoHint) = ppr a
472 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
473 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
475 pprLast :: Last -> SDoc
476 pprLast stmt = pp_stmt <+> pp_debug
478 pp_stmt = case stmt of
479 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
480 LastCondBranch expr t f -> genFullCondBranch expr t f
481 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
482 LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
484 pp_debug = text " //" <+> case stmt of
485 LastBranch {} -> text "LastBranch"
486 LastCondBranch {} -> text "LastCondBranch"
487 LastSwitch {} -> text "LastSwitch"
488 LastCall {} -> text "LastCall"
490 genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
491 genBareCall fn k off updfr_off =
492 hcat [ ptext (sLit "call"), space
493 , pprFun fn, ptext (sLit "(...)"), space
494 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
495 , ptext (sLit " with update frame") <+> ppr updfr_off
498 pprFun :: CmmExpr -> SDoc
499 pprFun f@(CmmLit _) = ppr f
500 pprFun f = parens (ppr f)
502 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
503 genFullCondBranch expr t f =
504 hsep [ ptext (sLit "if")
506 , ptext (sLit "goto")
508 , ptext (sLit "else goto")
512 pprConvention :: Convention -> SDoc
513 pprConvention (Native {}) = text "<native-convention>"
514 pprConvention Slow = text "<slow-convention>"
515 pprConvention GC = text "<gc-convention>"
516 pprConvention PrimOp = text "<primop-convention>"
517 pprConvention (Foreign c) = ppr c
518 pprConvention (Private {}) = text "<private-convention>"
520 pprForeignConvention :: ForeignConvention -> SDoc
521 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
523 commafy :: [SDoc] -> SDoc
524 commafy xs = hsep $ punctuate comma xs