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
41 import Prelude hiding (zip, unzip, last)
42 import qualified Data.List as L
43 import SMRep (ByteOff)
46 ----------------------------------------------------------------------
47 ----- Type synonyms and definitions
49 type CmmGraph = LGraph Middle Last
50 type CmmAGraph = AGraph Middle Last
51 type CmmBlock = Block Middle Last
52 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
53 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
54 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
55 type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
57 type UpdFrameOffset = ByteOff
60 = MidComment FastString
62 | MidAssign CmmReg CmmExpr -- Assign to register
64 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
65 -- given by cmmExprType of the rhs.
67 | MidForeignCall -- A foreign call; see Note [Foreign calls]
68 ForeignSafety -- Is it a safe or unsafe call?
69 MidCallTarget -- call target and convention
70 CmmFormals -- zero or more results
71 CmmActuals -- zero or more arguments
75 = LastBranch BlockId -- Goto another block in the same procedure
77 | LastCondBranch { -- conditional branch
79 cml_true, cml_false :: BlockId
81 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
82 -- The scrutinee is zero-based;
83 -- zero -> first block
84 -- one -> second block etc
85 -- Undefined outside range, and when there's a Nothing
86 | LastCall { -- A call (native or safe foreign)
87 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
88 cml_cont :: Maybe BlockId,
89 -- BlockId of continuation (Nothing for return or tail call)
90 cml_args :: ByteOff, -- byte offset for youngest outgoing arg
91 -- (includes update frame, which must be younger)
92 cml_ret_off :: Maybe UpdFrameOffset}
93 -- stack offset for return (update frames);
94 -- The return offset should be Nothing only if we have to create
95 -- a new call, e.g. for a procpoint, in which case it's an invariant
96 -- that the call does not stand for a return or a tail call,
97 -- and the successor does not need an info table.
99 data MidCallTarget -- The target of a MidUnsafeCall
100 = ForeignTarget -- A foreign procedure
101 CmmExpr -- Its address
102 ForeignConvention -- Its calling convention
104 | PrimTarget -- A possibly-side-effecting machine operation
105 CallishMachOp -- Which one
109 = Native -- Native C-- call/return
111 | Slow -- Slow entry points: all args pushed on the stack
113 | GC -- Entry to the garbage collector: uses the node reg!
115 | PrimOp -- Calling prim ops
117 | Foreign -- Foreign call/return
121 -- Used for control transfers within a (pre-CPS) procedure All
122 -- jump sites known, never pushed on the stack (hence no SRT)
123 -- You can choose whatever calling convention you please
124 -- (provided you make sure all the call sites agree)!
125 -- This data type eventually to be extended to record the convention.
128 data ForeignConvention
130 CCallConv -- Which foreign-call convention
131 [ForeignHint] -- Extra info about the args
132 [ForeignHint] -- Extra info about the result
136 = Unsafe -- unsafe call
137 | Safe BlockId -- making infotable requires: 1. label
138 UpdFrameOffset -- 2. where the upd frame is
141 data ValueDirection = Arguments | Results
142 -- Arguments go with procedure definitions, jumps, and arguments to calls
143 -- Results go with returns and with results of calls.
146 {- Note [Foreign calls]
147 ~~~~~~~~~~~~~~~~~~~~~~~
148 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
149 Unsafe ones are easy: think of them as a "fat machine instruction".
151 Safe ones are trickier. A safe foreign call
153 ultimately expands to
154 push "return address" -- Never used to return to;
155 -- just points an info table
156 save registers into TSO
158 r = f(x) -- Make the call
162 We cannot "lower" a safe foreign call to this sequence of Cmms, because
163 after we've saved Sp all the Cmm optimiser's assumptions are broken.
164 Furthermore, currently the smart Cmm constructors know the calling
165 conventions for Haskell, the garbage collector, etc, and "lower" them
166 so that a LastCall passes no parameters or results. But the smart
167 constructors do *not* (currently) know the foreign call conventions.
169 For these reasons use MidForeignCall for all calls. The only annoying thing
170 is that a safe foreign call needs an info table.
173 ----------------------------------------------------------------------
174 ----- Splicing between blocks
175 -- Given a middle node, a block, and a successor BlockId,
176 -- we can insert the middle node between the block and the successor.
177 -- We return the updated block and a list of new blocks that must be added
179 -- The semantics is a bit tricky. We consider cases on the last node:
180 -- o For a branch, we can just insert before the branch,
181 -- but sometimes the optimizer does better if we actually insert
182 -- a fresh basic block, enabling some common blockification.
183 -- o For a conditional branch, switch statement, or call, we must insert
184 -- a new basic block.
185 -- o For a jump or return, this operation is impossible.
187 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
188 insertBetween b ms succId = insert $ goto_end $ unzip b
189 where insert (h, LastOther (LastBranch bid)) =
190 if bid == succId then
191 do (bid', bs) <- newBlocks
192 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
193 else panic "tried invalid block insertBetween"
194 insert (h, LastOther (LastCondBranch c t f)) =
195 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
196 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
197 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
198 insert (h, LastOther (LastSwitch e ks)) =
199 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
200 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
201 insert (_, LastOther (LastCall {})) =
202 panic "unimp: insertBetween after a call -- probably not a good idea"
203 insert (_, LastExit) = panic "cannot insert after exit"
204 newBlocks = do id <- liftM BlockId $ getUniqueM
205 return $ (id, [Block id emptyStackInfo $
206 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
207 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
208 else return (Just k, [])
209 mbNewBlocks Nothing = return (Nothing, [])
210 lift (id, bs) = (Just id, bs)
212 ----------------------------------------------------------------------
213 ----- Instance declarations for control flow
215 instance HavingSuccessors Last where
217 fold_succs = fold_cmm_succs
219 instance LastNode Last where
220 mkBranchNode id = LastBranch id
221 isBranchNode (LastBranch _) = True
222 isBranchNode _ = False
223 branchNodeTarget (LastBranch id) = id
224 branchNodeTarget _ = panic "asked for target of non-branch"
226 cmmSuccs :: Last -> [BlockId]
227 cmmSuccs (LastBranch id) = [id]
228 cmmSuccs (LastCall _ Nothing _ _) = []
229 cmmSuccs (LastCall _ (Just id) _ _) = [id]
230 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
231 cmmSuccs (LastSwitch _ edges) = catMaybes edges
233 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
234 fold_cmm_succs f (LastBranch id) z = f id z
235 fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
236 fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
237 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
238 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
240 ----------------------------------------------------------------------
241 ----- Instance declarations for register use
243 instance UserOfLocalRegs Middle where
244 foldRegsUsed f z m = middle m
245 where middle (MidComment {}) = z
246 middle (MidAssign _lhs expr) = fold f z expr
247 middle (MidStore addr rval) = fold f (fold f z addr) rval
248 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
249 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
251 instance UserOfLocalRegs MidCallTarget where
252 foldRegsUsed _f z (PrimTarget _) = z
253 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
255 instance UserOfSlots MidCallTarget where
256 foldSlotsUsed _f z (PrimTarget _) = z
257 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
259 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
260 foldRegsUsed f z (Just x) = foldRegsUsed f z x
261 foldRegsUsed _ z Nothing = z
263 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
264 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
265 foldSlotsUsed _ z Nothing = z
267 instance UserOfLocalRegs Last where
268 foldRegsUsed f z l = last l
269 where last (LastBranch _id) = z
270 last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
271 last (LastCondBranch e _ _) = foldRegsUsed f z e
272 last (LastSwitch e _tbl) = foldRegsUsed f z e
274 instance DefinerOfLocalRegs Middle where
275 foldRegsDefd f z m = middle m
276 where middle (MidComment {}) = z
277 middle (MidAssign _lhs _) = fold f z _lhs
278 middle (MidStore _ _) = z
279 middle (MidForeignCall _ _ fs _) = fold f z fs
280 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
282 instance DefinerOfLocalRegs Last where
283 foldRegsDefd _ z _ = z
286 ----------------------------------------------------------------------
287 ----- Instance declarations for stack slot use
289 instance UserOfSlots Middle where
290 foldSlotsUsed f z m = middle m
291 where middle (MidComment {}) = z
292 middle (MidAssign _lhs expr) = fold f z expr
293 middle (MidStore addr rval) = fold f (fold f z addr) rval
294 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
295 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
297 instance UserOfSlots Last where
298 foldSlotsUsed f z l = last l
299 where last (LastBranch _id) = z
300 last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
301 last (LastCondBranch e _ _) = foldSlotsUsed f z e
302 last (LastSwitch e _tbl) = foldSlotsUsed f z e
304 instance UserOfSlots l => UserOfSlots (ZLast l) where
305 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
306 foldSlotsUsed _ z LastExit = z
308 instance DefinerOfSlots Middle where
309 foldSlotsDefd f z m = middle m
310 where middle (MidComment {}) = z
311 middle (MidAssign _ _) = z
312 middle (MidForeignCall {}) = z
313 middle (MidStore (CmmStackSlot a i) e) =
314 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
315 middle (MidStore _ _) = z
317 instance DefinerOfSlots Last where
318 foldSlotsDefd _ z _ = z
320 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
321 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
322 foldSlotsDefd _ z LastExit = z
324 ----------------------------------------------------------------------
325 ----- Code for manipulating Middle and Last nodes
327 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
328 mapExpMiddle _ m@(MidComment _) = m
329 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
330 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
331 mapExpMiddle exp (MidForeignCall s tgt fs as) =
332 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
334 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
335 foldExpMiddle _ (MidComment _) z = z
336 foldExpMiddle exp (MidAssign _ e) z = exp e z
337 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
338 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
340 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
341 mapExpLast _ l@(LastBranch _) = l
342 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
343 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
344 mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
346 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
347 foldExpLast _ (LastBranch _) z = z
348 foldExpLast exp (LastCondBranch e _ _) z = exp e z
349 foldExpLast exp (LastSwitch e _) z = exp e z
350 foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
352 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
353 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
354 mapExpMidcall _ m@(PrimTarget _) = m
356 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
357 foldExpMidcall exp (ForeignTarget e _) z = exp e z
358 foldExpMidcall _ (PrimTarget _) z = z
360 -- Take a transformer on expressions and apply it recursively.
361 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
362 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
363 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
366 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
367 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
368 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
369 mapExpDeepLast f = mapExpLast $ wrapRecExp f
371 -- Take a folder on expressions and apply it recursively.
372 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
373 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
374 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
375 wrapRecExpf f e z = f e z
377 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
378 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
379 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
380 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
382 ----------------------------------------------------------------------
383 -- Compute the join of facts live out of a Last node. Useful for most backward
385 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
386 joinOuts lattice env l =
387 let bot = fact_bot lattice
388 join x y = txVal $ fact_add_to lattice x y
390 (LastBranch id) -> env id
391 (LastCall _ Nothing _ _) -> bot
392 (LastCall _ (Just k) _ _) -> env k
393 (LastCondBranch _ t f) -> join (env t) (env f)
394 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
396 ----------------------------------------------------------------------
397 ----- Instance declarations for prettyprinting (avoids recursive imports)
399 instance Outputable Middle where
402 instance Outputable Last where
405 instance Outputable Convention where
408 instance Outputable ForeignConvention where
409 ppr = pprForeignConvention
411 instance Outputable ValueDirection where
412 ppr Arguments = ptext $ sLit "args"
413 ppr Results = ptext $ sLit "results"
415 instance DF.DebugNodes Middle Last
420 pprMiddle :: Middle -> SDoc
421 pprMiddle stmt = pp_stmt <+> pp_debug
423 pp_stmt = case stmt of
425 MidComment s -> text "//" <+> ftext s
428 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
431 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
433 rep = ppr ( cmmExprType expr )
435 -- call "ccall" foo(x, y)[r1, r2];
437 MidForeignCall safety target results args ->
438 hsep [ if null results
440 else parens (commafy $ map ppr results) <+> equals,
443 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
446 if not debugPpr then empty
449 MidComment {} -> text "MidComment"
450 MidAssign {} -> text "MidAssign"
451 MidStore {} -> text "MidStore"
452 MidForeignCall {} -> text "MidForeignCall"
454 ppr_fc :: ForeignConvention -> SDoc
455 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
457 ppr_safety :: ForeignSafety -> SDoc
458 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
459 ppr_safety Unsafe = text "unsafe"
461 ppr_call_target :: MidCallTarget -> SDoc
462 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
463 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
465 ppr_target :: CmmExpr -> SDoc
466 ppr_target t@(CmmLit _) = ppr t
467 ppr_target fn' = parens (ppr fn')
469 pprHinted :: Outputable a => CmmHinted a -> SDoc
470 pprHinted (CmmHinted a NoHint) = ppr a
471 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
472 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
474 pprLast :: Last -> SDoc
475 pprLast stmt = pp_stmt <+> pp_debug
477 pp_stmt = case stmt of
478 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
479 LastCondBranch expr t f -> genFullCondBranch expr t f
480 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
481 LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
483 pp_debug = text " //" <+> case stmt of
484 LastBranch {} -> text "LastBranch"
485 LastCondBranch {} -> text "LastCondBranch"
486 LastSwitch {} -> text "LastSwitch"
487 LastCall {} -> text "LastCall"
489 genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
490 genBareCall fn k off updfr_off =
491 hcat [ ptext (sLit "call"), space
492 , pprFun fn, ptext (sLit "(...)"), space
493 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
494 , ptext (sLit " with update frame") <+> ppr updfr_off
497 pprFun :: CmmExpr -> SDoc
498 pprFun f@(CmmLit _) = ppr f
499 pprFun f = parens (ppr f)
501 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
502 genFullCondBranch expr t f =
503 hsep [ ptext (sLit "if")
505 , ptext (sLit "goto")
507 , ptext (sLit "else goto")
511 pprConvention :: Convention -> SDoc
512 pprConvention (Native {}) = text "<native-convention>"
513 pprConvention Slow = text "<slow-convention>"
514 pprConvention GC = text "<gc-convention>"
515 pprConvention PrimOp = text "<primop-convention>"
516 pprConvention (Foreign c) = ppr c
517 pprConvention (Private {}) = text "<private-convention>"
519 pprForeignConvention :: ForeignConvention -> SDoc
520 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
522 commafy :: [SDoc] -> SDoc
523 commafy xs = hsep $ punctuate comma xs