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 = Native -- Native C-- call/return
115 | Slow -- Slow entry points: all args pushed on the stack
117 | GC -- Entry to the garbage collector: uses the node reg!
119 | PrimOp -- Calling prim ops
121 | Foreign -- Foreign call/return
125 -- Used for control transfers within a (pre-CPS) procedure All
126 -- jump sites known, never pushed on the stack (hence no SRT)
127 -- You can choose whatever calling convention you please
128 -- (provided you make sure all the call sites agree)!
129 -- This data type eventually to be extended to record the convention.
132 data ForeignConvention
134 CCallConv -- Which foreign-call convention
135 [ForeignHint] -- Extra info about the args
136 [ForeignHint] -- Extra info about the result
140 = Unsafe -- unsafe call
141 | Safe BlockId -- making infotable requires: 1. label
142 UpdFrameOffset -- 2. where the upd frame is
145 data ValueDirection = Arguments | Results
146 -- Arguments go with procedure definitions, jumps, and arguments to calls
147 -- Results go with returns and with results of calls.
150 {- Note [Foreign calls]
151 ~~~~~~~~~~~~~~~~~~~~~~~
152 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
153 Unsafe ones are easy: think of them as a "fat machine instruction".
155 Safe ones are trickier. A safe foreign call
157 ultimately expands to
158 push "return address" -- Never used to return to;
159 -- just points an info table
160 save registers into TSO
162 r = f(x) -- Make the call
166 We cannot "lower" a safe foreign call to this sequence of Cmms, because
167 after we've saved Sp all the Cmm optimiser's assumptions are broken.
168 Furthermore, currently the smart Cmm constructors know the calling
169 conventions for Haskell, the garbage collector, etc, and "lower" them
170 so that a LastCall passes no parameters or results. But the smart
171 constructors do *not* (currently) know the foreign call conventions.
173 For these reasons use MidForeignCall for all calls. The only annoying thing
174 is that a safe foreign call needs an info table.
177 ----------------------------------------------------------------------
178 ----- Splicing between blocks
179 -- Given a middle node, a block, and a successor BlockId,
180 -- we can insert the middle node between the block and the successor.
181 -- We return the updated block and a list of new blocks that must be added
183 -- The semantics is a bit tricky. We consider cases on the last node:
184 -- o For a branch, we can just insert before the branch,
185 -- but sometimes the optimizer does better if we actually insert
186 -- a fresh basic block, enabling some common blockification.
187 -- o For a conditional branch, switch statement, or call, we must insert
188 -- a new basic block.
189 -- o For a jump or return, this operation is impossible.
191 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
192 insertBetween b ms succId = insert $ goto_end $ unzip b
193 where insert (h, LastOther (LastBranch bid)) =
194 if bid == succId then
195 do (bid', bs) <- newBlocks
196 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
197 else panic "tried invalid block insertBetween"
198 insert (h, LastOther (LastCondBranch c t f)) =
199 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
200 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
201 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
202 insert (h, LastOther (LastSwitch e ks)) =
203 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
204 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
205 insert (_, LastOther (LastCall {})) =
206 panic "unimp: insertBetween after a call -- probably not a good idea"
207 insert (_, LastExit) = panic "cannot insert after exit"
208 newBlocks = do id <- liftM BlockId $ getUniqueM
209 return $ (id, [Block id $
210 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
211 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
212 else return (Just k, [])
213 mbNewBlocks Nothing = return (Nothing, [])
214 lift (id, bs) = (Just id, bs)
216 ----------------------------------------------------------------------
217 ----- Instance declarations for control flow
219 instance HavingSuccessors Last where
221 fold_succs = fold_cmm_succs
223 instance LastNode Last where
224 mkBranchNode id = LastBranch id
225 isBranchNode (LastBranch _) = True
226 isBranchNode _ = False
227 branchNodeTarget (LastBranch id) = id
228 branchNodeTarget _ = panic "asked for target of non-branch"
230 cmmSuccs :: Last -> [BlockId]
231 cmmSuccs (LastBranch id) = [id]
232 cmmSuccs (LastCall _ Nothing _ _ _) = []
233 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
234 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
235 cmmSuccs (LastSwitch _ edges) = catMaybes edges
237 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
238 fold_cmm_succs f (LastBranch id) z = f id z
239 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
240 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
241 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
242 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
244 ----------------------------------------------------------------------
245 ----- Instance declarations for register use
247 instance UserOfLocalRegs Middle where
248 foldRegsUsed f z m = middle m
249 where middle (MidComment {}) = z
250 middle (MidAssign _lhs expr) = fold f z expr
251 middle (MidStore addr rval) = fold f (fold f z addr) rval
252 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
253 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
255 instance UserOfLocalRegs MidCallTarget where
256 foldRegsUsed _f z (PrimTarget _) = z
257 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
259 instance UserOfSlots MidCallTarget where
260 foldSlotsUsed _f z (PrimTarget _) = z
261 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
263 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
264 foldRegsUsed f z (Just x) = foldRegsUsed f z x
265 foldRegsUsed _ z Nothing = z
267 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
268 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
269 foldSlotsUsed _ z Nothing = z
271 instance UserOfLocalRegs Last where
272 foldRegsUsed f z l = last l
273 where last (LastBranch _id) = z
274 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
275 last (LastCondBranch e _ _) = foldRegsUsed f z e
276 last (LastSwitch e _tbl) = foldRegsUsed f z e
278 instance DefinerOfLocalRegs Middle where
279 foldRegsDefd f z m = middle m
280 where middle (MidComment {}) = z
281 middle (MidAssign lhs _) = fold f z lhs
282 middle (MidStore _ _) = z
283 middle (MidForeignCall _ _ fs _) = fold f z fs
284 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
286 instance DefinerOfLocalRegs Last where
287 foldRegsDefd _ z _ = z
290 ----------------------------------------------------------------------
291 ----- Instance declarations for stack slot use
293 instance UserOfSlots Middle where
294 foldSlotsUsed f z m = middle m
295 where middle (MidComment {}) = z
296 middle (MidAssign _lhs expr) = fold f z expr
297 middle (MidStore addr rval) = fold f (fold f z addr) rval
298 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
299 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
301 instance UserOfSlots Last where
302 foldSlotsUsed f z l = last l
303 where last (LastBranch _id) = z
304 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
305 last (LastCondBranch e _ _) = foldSlotsUsed f z e
306 last (LastSwitch e _tbl) = foldSlotsUsed f z e
308 instance UserOfSlots l => UserOfSlots (ZLast l) where
309 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
310 foldSlotsUsed _ z LastExit = z
312 instance DefinerOfSlots Middle where
313 foldSlotsDefd f z m = middle m
314 where middle (MidComment {}) = z
315 middle (MidAssign _ _) = z
316 middle (MidForeignCall {}) = z
317 middle (MidStore (CmmStackSlot a i) e) =
318 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
319 middle (MidStore _ _) = z
321 instance DefinerOfSlots Last where
322 foldSlotsDefd _ z _ = z
324 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
325 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
326 foldSlotsDefd _ z LastExit = z
328 ----------------------------------------------------------------------
329 ----- Code for manipulating Middle and Last nodes
331 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
332 mapExpMiddle _ m@(MidComment _) = m
333 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
334 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
335 mapExpMiddle exp (MidForeignCall s tgt fs as) =
336 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
338 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
339 foldExpMiddle _ (MidComment _) z = z
340 foldExpMiddle exp (MidAssign _ e) z = exp e z
341 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
342 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
344 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
345 mapExpLast _ l@(LastBranch _) = l
346 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
347 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
348 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
350 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
351 foldExpLast _ (LastBranch _) z = z
352 foldExpLast exp (LastCondBranch e _ _) z = exp e z
353 foldExpLast exp (LastSwitch e _) z = exp e z
354 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
356 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
357 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
358 mapExpMidcall _ m@(PrimTarget _) = m
360 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
361 foldExpMidcall exp (ForeignTarget e _) z = exp e z
362 foldExpMidcall _ (PrimTarget _) z = z
364 -- Take a transformer on expressions and apply it recursively.
365 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
366 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
367 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
370 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
371 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
372 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
373 mapExpDeepLast f = mapExpLast $ wrapRecExp f
375 -- Take a folder on expressions and apply it recursively.
376 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
377 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
378 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
379 wrapRecExpf f e z = f e z
381 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
382 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
383 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
384 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
386 ----------------------------------------------------------------------
387 -- Compute the join of facts live out of a Last node. Useful for most backward
389 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
390 joinOuts lattice env l =
391 let bot = fact_bot lattice
392 join x y = txVal $ fact_add_to lattice x y
394 (LastBranch id) -> env id
395 (LastCall _ Nothing _ _ _) -> bot
396 (LastCall _ (Just k) _ _ _) -> env k
397 (LastCondBranch _ t f) -> join (env t) (env f)
398 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
400 ----------------------------------------------------------------------
401 ----- Instance declarations for prettyprinting (avoids recursive imports)
403 instance Outputable Middle where
406 instance Outputable Last where
409 instance Outputable Convention where
412 instance Outputable ForeignConvention where
413 ppr = pprForeignConvention
415 instance Outputable ValueDirection where
416 ppr Arguments = ptext $ sLit "args"
417 ppr Results = ptext $ sLit "results"
419 instance DF.DebugNodes Middle Last
424 pprMiddle :: Middle -> SDoc
425 pprMiddle stmt = pp_stmt <+> pp_debug
427 pp_stmt = case stmt of
429 MidComment s -> text "//" <+> ftext s
432 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
435 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
437 rep = ppr ( cmmExprType expr )
439 -- call "ccall" foo(x, y)[r1, r2];
441 MidForeignCall safety target results args ->
442 hsep [ if null results
444 else parens (commafy $ map ppr results) <+> equals,
447 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
450 if not debugPpr then empty
453 MidComment {} -> text "MidComment"
454 MidAssign {} -> text "MidAssign"
455 MidStore {} -> text "MidStore"
456 MidForeignCall {} -> text "MidForeignCall"
458 ppr_fc :: ForeignConvention -> SDoc
459 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
461 ppr_safety :: ForeignSafety -> SDoc
462 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
463 ppr_safety Unsafe = text "unsafe"
465 ppr_call_target :: MidCallTarget -> SDoc
466 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
467 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
469 ppr_target :: CmmExpr -> SDoc
470 ppr_target t@(CmmLit _) = ppr t
471 ppr_target fn' = parens (ppr fn')
473 pprHinted :: Outputable a => CmmHinted a -> SDoc
474 pprHinted (CmmHinted a NoHint) = ppr a
475 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
476 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
478 pprLast :: Last -> SDoc
479 pprLast stmt = pp_stmt <+> pp_debug
481 pp_stmt = case stmt of
482 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
483 LastCondBranch expr t f -> genFullCondBranch expr t f
484 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
485 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
487 pp_debug = text " //" <+> case stmt of
488 LastBranch {} -> text "LastBranch"
489 LastCondBranch {} -> text "LastCondBranch"
490 LastSwitch {} -> text "LastSwitch"
491 LastCall {} -> text "LastCall"
493 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
494 Maybe UpdFrameOffset -> SDoc
495 genBareCall fn k out res updfr_off =
496 hcat [ ptext (sLit "call"), space
497 , pprFun fn, ptext (sLit "(...)"), space
498 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
500 , ptext (sLit " with update frame") <+> ppr updfr_off
503 pprFun :: CmmExpr -> SDoc
504 pprFun f@(CmmLit _) = ppr f
505 pprFun f = parens (ppr f)
507 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
508 genFullCondBranch expr t f =
509 hsep [ ptext (sLit "if")
511 , ptext (sLit "goto")
513 , ptext (sLit "else goto")
517 pprConvention :: Convention -> SDoc
518 pprConvention (Native {}) = text "<native-convention>"
519 pprConvention Slow = text "<slow-convention>"
520 pprConvention GC = text "<gc-convention>"
521 pprConvention PrimOp = text "<primop-convention>"
522 pprConvention (Foreign c) = ppr c
523 pprConvention (Private {}) = text "<private-convention>"
525 pprForeignConvention :: ForeignConvention -> SDoc
526 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
528 commafy :: [SDoc] -> SDoc
529 commafy xs = hsep $ punctuate comma xs