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;
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 ----------------------------------------------------------------------
147 ----- Splicing between blocks
148 -- Given a middle node, a block, and a successor BlockId,
149 -- we can insert the middle node between the block and the successor.
150 -- We return the updated block and a list of new blocks that must be added
152 -- The semantics is a bit tricky. We consider cases on the last node:
153 -- o For a branch, we can just insert before the branch,
154 -- but sometimes the optimizer does better if we actually insert
155 -- a fresh basic block, enabling some common blockification.
156 -- o For a conditional branch, switch statement, or call, we must insert
157 -- a new basic block.
158 -- o For a jump or return, this operation is impossible.
160 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
161 insertBetween b ms succId = insert $ goto_end $ unzip b
162 where insert (h, LastOther (LastBranch bid)) =
163 if bid == succId then
164 do (bid', bs) <- newBlocks
165 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
166 else panic "tried invalid block insertBetween"
167 insert (h, LastOther (LastCondBranch c t f)) =
168 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
169 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
170 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
171 insert (h, LastOther (LastSwitch e ks)) =
172 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
173 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
174 insert (_, LastOther (LastCall {})) =
175 panic "unimp: insertBetween after a call -- probably not a good idea"
176 insert (_, LastExit) = panic "cannot insert after exit"
177 newBlocks = do id <- liftM BlockId $ getUniqueM
178 return $ (id, [Block id emptyStackInfo $
179 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
180 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
181 else return (Just k, [])
182 mbNewBlocks Nothing = return (Nothing, [])
183 lift (id, bs) = (Just id, bs)
185 ----------------------------------------------------------------------
186 ----- Instance declarations for control flow
188 instance HavingSuccessors Last where
190 fold_succs = fold_cmm_succs
192 instance LastNode Last where
193 mkBranchNode id = LastBranch id
194 isBranchNode (LastBranch _) = True
195 isBranchNode _ = False
196 branchNodeTarget (LastBranch id) = id
197 branchNodeTarget _ = panic "asked for target of non-branch"
199 cmmSuccs :: Last -> [BlockId]
200 cmmSuccs (LastBranch id) = [id]
201 cmmSuccs (LastCall _ Nothing _ _) = []
202 cmmSuccs (LastCall _ (Just id) _ _) = [id]
203 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
204 cmmSuccs (LastSwitch _ edges) = catMaybes edges
206 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
207 fold_cmm_succs f (LastBranch id) z = f id z
208 fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
209 fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
210 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
211 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
213 ----------------------------------------------------------------------
214 ----- Instance declarations for register use
216 instance UserOfLocalRegs Middle where
217 foldRegsUsed f z m = middle m
218 where middle (MidComment {}) = z
219 middle (MidAssign _lhs expr) = fold f z expr
220 middle (MidStore addr rval) = fold f (fold f z addr) rval
221 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
222 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
224 instance UserOfLocalRegs MidCallTarget where
225 foldRegsUsed _f z (PrimTarget _) = z
226 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
228 instance UserOfSlots MidCallTarget where
229 foldSlotsUsed _f z (PrimTarget _) = z
230 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
232 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
233 foldRegsUsed f z (Just x) = foldRegsUsed f z x
234 foldRegsUsed _ z Nothing = z
236 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
237 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
238 foldSlotsUsed _ z Nothing = z
240 instance UserOfLocalRegs Last where
241 foldRegsUsed f z l = last l
242 where last (LastBranch _id) = z
243 last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
244 last (LastCondBranch e _ _) = foldRegsUsed f z e
245 last (LastSwitch e _tbl) = foldRegsUsed f z e
247 instance DefinerOfLocalRegs Middle where
248 foldRegsDefd f z m = middle m
249 where middle (MidComment {}) = z
250 middle (MidAssign _lhs _) = fold f z _lhs
251 middle (MidStore _ _) = z
252 middle (MidForeignCall _ _ fs _) = fold f z fs
253 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
255 instance DefinerOfLocalRegs Last where
256 foldRegsDefd _ z _ = z
259 ----------------------------------------------------------------------
260 ----- Instance declarations for stack slot use
262 instance UserOfSlots Middle where
263 foldSlotsUsed f z m = middle m
264 where middle (MidComment {}) = z
265 middle (MidAssign _lhs expr) = fold f z expr
266 middle (MidStore addr rval) = fold f (fold f z addr) rval
267 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
268 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
270 instance UserOfSlots Last where
271 foldSlotsUsed f z l = last l
272 where last (LastBranch _id) = z
273 last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
274 last (LastCondBranch e _ _) = foldSlotsUsed f z e
275 last (LastSwitch e _tbl) = foldSlotsUsed f z e
277 instance UserOfSlots l => UserOfSlots (ZLast l) where
278 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
279 foldSlotsUsed _ z LastExit = z
281 instance DefinerOfSlots Middle where
282 foldSlotsDefd f z m = middle m
283 where middle (MidComment {}) = z
284 middle (MidAssign _ _) = z
285 middle (MidForeignCall {}) = z
286 middle (MidStore (CmmStackSlot a i) e) =
287 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
288 middle (MidStore _ _) = z
290 instance DefinerOfSlots Last where
291 foldSlotsDefd _ z _ = z
293 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
294 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
295 foldSlotsDefd _ z LastExit = z
297 ----------------------------------------------------------------------
298 ----- Code for manipulating Middle and Last nodes
300 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
301 mapExpMiddle _ m@(MidComment _) = m
302 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
303 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
304 mapExpMiddle exp (MidForeignCall s tgt fs as) =
305 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
307 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
308 foldExpMiddle _ (MidComment _) z = z
309 foldExpMiddle exp (MidAssign _ e) z = exp e z
310 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
311 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
313 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
314 mapExpLast _ l@(LastBranch _) = l
315 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
316 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
317 mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
319 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
320 foldExpLast _ (LastBranch _) z = z
321 foldExpLast exp (LastCondBranch e _ _) z = exp e z
322 foldExpLast exp (LastSwitch e _) z = exp e z
323 foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
325 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
326 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
327 mapExpMidcall _ m@(PrimTarget _) = m
329 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
330 foldExpMidcall exp (ForeignTarget e _) z = exp e z
331 foldExpMidcall _ (PrimTarget _) z = z
333 -- Take a transformer on expressions and apply it recursively.
334 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
335 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
336 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
339 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
340 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
341 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
342 mapExpDeepLast f = mapExpLast $ wrapRecExp f
344 -- Take a folder on expressions and apply it recursively.
345 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
346 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
347 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
348 wrapRecExpf f e z = f e z
350 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
351 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
352 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
353 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
355 ----------------------------------------------------------------------
356 -- Compute the join of facts live out of a Last node. Useful for most backward
358 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
359 joinOuts lattice env l =
360 let bot = fact_bot lattice
361 join x y = txVal $ fact_add_to lattice x y
363 (LastBranch id) -> env id
364 (LastCall _ Nothing _ _) -> bot
365 (LastCall _ (Just k) _ _) -> env k
366 (LastCondBranch _ t f) -> join (env t) (env f)
367 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
369 ----------------------------------------------------------------------
370 ----- Instance declarations for prettyprinting (avoids recursive imports)
372 instance Outputable Middle where
375 instance Outputable Last where
378 instance Outputable Convention where
381 instance Outputable ForeignConvention where
382 ppr = pprForeignConvention
384 instance Outputable ValueDirection where
385 ppr Arguments = ptext $ sLit "args"
386 ppr Results = ptext $ sLit "results"
388 instance DF.DebugNodes Middle Last
393 pprMiddle :: Middle -> SDoc
394 pprMiddle stmt = pp_stmt <+> pp_debug
396 pp_stmt = case stmt of
398 MidComment s -> text "//" <+> ftext s
401 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
404 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
406 rep = ppr ( cmmExprType expr )
408 -- call "ccall" foo(x, y)[r1, r2];
410 MidForeignCall safety target results args ->
411 hsep [ if null results
413 else parens (commafy $ map ppr results) <+> equals,
416 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
419 if not debugPpr then empty
422 MidComment {} -> text "MidComment"
423 MidAssign {} -> text "MidAssign"
424 MidStore {} -> text "MidStore"
425 MidForeignCall {} -> text "MidForeignCall"
427 ppr_fc :: ForeignConvention -> SDoc
428 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
430 ppr_safety :: ForeignSafety -> SDoc
431 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
432 ppr_safety Unsafe = text "unsafe"
434 ppr_call_target :: MidCallTarget -> SDoc
435 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
436 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
438 ppr_target :: CmmExpr -> SDoc
439 ppr_target t@(CmmLit _) = ppr t
440 ppr_target fn' = parens (ppr fn')
442 pprHinted :: Outputable a => CmmHinted a -> SDoc
443 pprHinted (CmmHinted a NoHint) = ppr a
444 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
445 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
447 pprLast :: Last -> SDoc
448 pprLast stmt = pp_stmt <+> pp_debug
450 pp_stmt = case stmt of
451 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
452 LastCondBranch expr t f -> genFullCondBranch expr t f
453 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
454 LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
456 pp_debug = text " //" <+> case stmt of
457 LastBranch {} -> text "LastBranch"
458 LastCondBranch {} -> text "LastCondBranch"
459 LastSwitch {} -> text "LastSwitch"
460 LastCall {} -> text "LastCall"
462 genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
463 genBareCall fn k off updfr_off =
464 hcat [ ptext (sLit "call"), space
465 , pprFun fn, ptext (sLit "(...)"), space
466 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
467 , ptext (sLit " with update frame") <+> ppr updfr_off
470 pprFun :: CmmExpr -> SDoc
471 pprFun f@(CmmLit _) = ppr f
472 pprFun f = parens (ppr f)
474 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
475 genFullCondBranch expr t f =
476 hsep [ ptext (sLit "if")
478 , ptext (sLit "goto")
480 , ptext (sLit "else goto")
484 pprConvention :: Convention -> SDoc
485 pprConvention (Native {}) = text "<native-convention>"
486 pprConvention Slow = text "<slow-convention>"
487 pprConvention GC = text "<gc-convention>"
488 pprConvention PrimOp = text "<primop-convention>"
489 pprConvention (Foreign c) = ppr c
490 pprConvention (Private {}) = text "<private-convention>"
492 pprForeignConvention :: ForeignConvention -> SDoc
493 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
495 commafy :: [SDoc] -> SDoc
496 commafy xs = hsep $ punctuate comma xs