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, -- bytes offset for youngest outgoing arg
91 cml_ret_off :: Maybe UpdFrameOffset}
92 -- stack offset for return (update frames);
93 -- The return offset should be Nothing only if we have to create
94 -- a new call, e.g. for a procpoint, in which case it's an invariant
95 -- that the call does not stand for a return or a tail call,
96 -- and the successor does not need an info table.
98 data MidCallTarget -- The target of a MidUnsafeCall
99 = ForeignTarget -- A foreign procedure
100 CmmExpr -- Its address
101 ForeignConvention -- Its calling convention
103 | PrimTarget -- A possibly-side-effecting machine operation
104 CallishMachOp -- Which one
108 = Native -- Native C-- call/return
110 | Slow -- Slow entry points: all args pushed on the stack
112 | GC -- Entry to the garbage collector: uses the node reg!
114 | PrimOp -- Calling prim ops
116 | Foreign -- Foreign call/return
120 -- Used for control transfers within a (pre-CPS) procedure All
121 -- jump sites known, never pushed on the stack (hence no SRT)
122 -- You can choose whatever calling convention you please
123 -- (provided you make sure all the call sites agree)!
124 -- This data type eventually to be extended to record the convention.
127 data ForeignConvention
129 CCallConv -- Which foreign-call convention
130 [ForeignHint] -- Extra info about the args
131 [ForeignHint] -- Extra info about the result
135 = Unsafe -- unsafe call
136 | Safe BlockId -- making infotable requires: 1. label
137 UpdFrameOffset -- 2. where the upd frame is
140 data ValueDirection = Arguments | Results
141 -- Arguments go with procedure definitions, jumps, and arguments to calls
142 -- Results go with returns and with results of calls.
145 ----------------------------------------------------------------------
146 ----- Splicing between blocks
147 -- Given a middle node, a block, and a successor BlockId,
148 -- we can insert the middle node between the block and the successor.
149 -- We return the updated block and a list of new blocks that must be added
151 -- The semantics is a bit tricky. We consider cases on the last node:
152 -- o For a branch, we can just insert before the branch,
153 -- but sometimes the optimizer does better if we actually insert
154 -- a fresh basic block, enabling some common blockification.
155 -- o For a conditional branch, switch statement, or call, we must insert
156 -- a new basic block.
157 -- o For a jump or return, this operation is impossible.
159 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
160 insertBetween b ms succId = insert $ goto_end $ unzip b
161 where insert (h, LastOther (LastBranch bid)) =
162 if bid == succId then
163 do (bid', bs) <- newBlocks
164 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
165 else panic "tried invalid block insertBetween"
166 insert (h, LastOther (LastCondBranch c t f)) =
167 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
168 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
169 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
170 insert (h, LastOther (LastSwitch e ks)) =
171 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
172 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
173 insert (_, LastOther (LastCall {})) =
174 panic "unimp: insertBetween after a call -- probably not a good idea"
175 insert (_, LastExit) = panic "cannot insert after exit"
176 newBlocks = do id <- liftM BlockId $ getUniqueM
177 return $ (id, [Block id emptyStackInfo $
178 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
179 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
180 else return (Just k, [])
181 mbNewBlocks Nothing = return (Nothing, [])
182 lift (id, bs) = (Just id, bs)
184 ----------------------------------------------------------------------
185 ----- Instance declarations for control flow
187 instance HavingSuccessors Last where
189 fold_succs = fold_cmm_succs
191 instance LastNode Last where
192 mkBranchNode id = LastBranch id
193 isBranchNode (LastBranch _) = True
194 isBranchNode _ = False
195 branchNodeTarget (LastBranch id) = id
196 branchNodeTarget _ = panic "asked for target of non-branch"
198 cmmSuccs :: Last -> [BlockId]
199 cmmSuccs (LastBranch id) = [id]
200 cmmSuccs (LastCall _ Nothing _ _) = []
201 cmmSuccs (LastCall _ (Just id) _ _) = [id]
202 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
203 cmmSuccs (LastSwitch _ edges) = catMaybes edges
205 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
206 fold_cmm_succs f (LastBranch id) z = f id z
207 fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
208 fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
209 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
210 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
212 ----------------------------------------------------------------------
213 ----- Instance declarations for register use
215 instance UserOfLocalRegs Middle where
216 foldRegsUsed f z m = middle m
217 where middle (MidComment {}) = z
218 middle (MidAssign _lhs expr) = fold f z expr
219 middle (MidStore addr rval) = fold f (fold f z addr) rval
220 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
221 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
223 instance UserOfLocalRegs MidCallTarget where
224 foldRegsUsed _f z (PrimTarget _) = z
225 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
227 instance UserOfSlots MidCallTarget where
228 foldSlotsUsed _f z (PrimTarget _) = z
229 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
231 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
232 foldRegsUsed f z (Just x) = foldRegsUsed f z x
233 foldRegsUsed _ z Nothing = z
235 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
236 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
237 foldSlotsUsed _ z Nothing = z
239 instance UserOfLocalRegs Last where
240 foldRegsUsed f z l = last l
241 where last (LastBranch _id) = z
242 last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
243 last (LastCondBranch e _ _) = foldRegsUsed f z e
244 last (LastSwitch e _tbl) = foldRegsUsed f z e
246 instance DefinerOfLocalRegs Middle where
247 foldRegsDefd f z m = middle m
248 where middle (MidComment {}) = z
249 middle (MidAssign _lhs _) = fold f z _lhs
250 middle (MidStore _ _) = z
251 middle (MidForeignCall _ _ fs _) = fold f z fs
252 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
254 instance DefinerOfLocalRegs Last where
255 foldRegsDefd _ z _ = z
258 ----------------------------------------------------------------------
259 ----- Instance declarations for stack slot use
261 instance UserOfSlots Middle where
262 foldSlotsUsed f z m = middle m
263 where middle (MidComment {}) = z
264 middle (MidAssign _lhs expr) = fold f z expr
265 middle (MidStore addr rval) = fold f (fold f z addr) rval
266 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
267 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
269 instance UserOfSlots Last where
270 foldSlotsUsed f z l = last l
271 where last (LastBranch _id) = z
272 last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
273 last (LastCondBranch e _ _) = foldSlotsUsed f z e
274 last (LastSwitch e _tbl) = foldSlotsUsed f z e
276 instance UserOfSlots l => UserOfSlots (ZLast l) where
277 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
278 foldSlotsUsed _ z LastExit = z
280 instance DefinerOfSlots Middle where
281 foldSlotsDefd f z m = middle m
282 where middle (MidComment {}) = z
283 middle (MidAssign _ _) = z
284 middle (MidForeignCall {}) = z
285 middle (MidStore (CmmStackSlot a i) e) =
286 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
287 middle (MidStore _ _) = z
289 instance DefinerOfSlots Last where
290 foldSlotsDefd _ z _ = z
292 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
293 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
294 foldSlotsDefd _ z LastExit = z
296 ----------------------------------------------------------------------
297 ----- Code for manipulating Middle and Last nodes
299 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
300 mapExpMiddle _ m@(MidComment _) = m
301 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
302 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
303 mapExpMiddle exp (MidForeignCall s tgt fs as) =
304 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
306 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
307 foldExpMiddle _ (MidComment _) z = z
308 foldExpMiddle exp (MidAssign _ e) z = exp e z
309 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
310 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
312 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
313 mapExpLast _ l@(LastBranch _) = l
314 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
315 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
316 mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
318 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
319 foldExpLast _ (LastBranch _) z = z
320 foldExpLast exp (LastCondBranch e _ _) z = exp e z
321 foldExpLast exp (LastSwitch e _) z = exp e z
322 foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
324 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
325 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
326 mapExpMidcall _ m@(PrimTarget _) = m
328 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
329 foldExpMidcall exp (ForeignTarget e _) z = exp e z
330 foldExpMidcall _ (PrimTarget _) z = z
332 -- Take a transformer on expressions and apply it recursively.
333 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
334 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
335 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
338 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
339 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
340 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
341 mapExpDeepLast f = mapExpLast $ wrapRecExp f
343 -- Take a folder on expressions and apply it recursively.
344 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
345 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
346 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
347 wrapRecExpf f e z = f e z
349 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
350 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
351 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
352 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
354 ----------------------------------------------------------------------
355 -- Compute the join of facts live out of a Last node. Useful for most backward
357 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
358 joinOuts lattice env l =
359 let bot = fact_bot lattice
360 join x y = txVal $ fact_add_to lattice x y
362 (LastBranch id) -> env id
363 (LastCall _ Nothing _ _) -> bot
364 (LastCall _ (Just k) _ _) -> env k
365 (LastCondBranch _ t f) -> join (env t) (env f)
366 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
368 ----------------------------------------------------------------------
369 ----- Instance declarations for prettyprinting (avoids recursive imports)
371 instance Outputable Middle where
374 instance Outputable Last where
377 instance Outputable Convention where
380 instance Outputable ForeignConvention where
381 ppr = pprForeignConvention
383 instance Outputable ValueDirection where
384 ppr Arguments = ptext $ sLit "args"
385 ppr Results = ptext $ sLit "results"
387 instance DF.DebugNodes Middle Last
392 pprMiddle :: Middle -> SDoc
393 pprMiddle stmt = pp_stmt <+> pp_debug
395 pp_stmt = case stmt of
397 MidComment s -> text "//" <+> ftext s
400 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
403 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
405 rep = ppr ( cmmExprType expr )
407 -- call "ccall" foo(x, y)[r1, r2];
409 MidForeignCall safety target results args ->
410 hsep [ if null results
412 else parens (commafy $ map ppr results) <+> equals,
415 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
418 if not debugPpr then empty
421 MidComment {} -> text "MidComment"
422 MidAssign {} -> text "MidAssign"
423 MidStore {} -> text "MidStore"
424 MidForeignCall {} -> text "MidForeignCall"
426 ppr_fc :: ForeignConvention -> SDoc
427 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
429 ppr_safety :: ForeignSafety -> SDoc
430 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
431 ppr_safety Unsafe = text "unsafe"
433 ppr_call_target :: MidCallTarget -> SDoc
434 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
435 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
437 ppr_target :: CmmExpr -> SDoc
438 ppr_target t@(CmmLit _) = ppr t
439 ppr_target fn' = parens (ppr fn')
441 pprHinted :: Outputable a => CmmHinted a -> SDoc
442 pprHinted (CmmHinted a NoHint) = ppr a
443 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
444 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
446 pprLast :: Last -> SDoc
447 pprLast stmt = pp_stmt <+> pp_debug
449 pp_stmt = case stmt of
450 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
451 LastCondBranch expr t f -> genFullCondBranch expr t f
452 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
453 LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
455 pp_debug = text " //" <+> case stmt of
456 LastBranch {} -> text "LastBranch"
457 LastCondBranch {} -> text "LastCondBranch"
458 LastSwitch {} -> text "LastSwitch"
459 LastCall {} -> text "LastCall"
461 genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
462 genBareCall fn k off updfr_off =
463 hcat [ ptext (sLit "call"), space
464 , pprFun fn, ptext (sLit "(...)"), space
465 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
466 , ptext (sLit " with update frame") <+> ppr updfr_off
469 pprFun :: CmmExpr -> SDoc
470 pprFun f@(CmmLit _) = ppr f
471 pprFun f = parens (ppr f)
473 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
474 genFullCondBranch expr t f =
475 hsep [ ptext (sLit "if")
477 , ptext (sLit "goto")
479 , ptext (sLit "else goto")
483 pprConvention :: Convention -> SDoc
484 pprConvention (Native {}) = text "<native-convention>"
485 pprConvention Slow = text "<slow-convention>"
486 pprConvention GC = text "<gc-convention>"
487 pprConvention PrimOp = text "<primop-convention>"
488 pprConvention (Foreign c) = ppr c
489 pprConvention (Private {}) = text "<private-convention>"
491 pprForeignConvention :: ForeignConvention -> SDoc
492 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
494 commafy :: [SDoc] -> SDoc
495 commafy xs = hsep $ punctuate comma xs