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 ZipDataflow as DF
41 import Prelude hiding (zip, unzip, last)
42 import SMRep (ByteOff)
45 ----------------------------------------------------------------------
46 ----- Type synonyms and definitions
48 type CmmGraph = LGraph Middle Last
49 type CmmAGraph = AGraph Middle Last
50 type CmmBlock = Block Middle Last
51 type CmmStackInfo = (ByteOff, Maybe ByteOff)
52 -- probably want a record; (SP offset on entry, update frame space)
53 type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
54 type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, 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_args:: ByteOff, -- byte offset for youngest incoming arg
94 cml_ret_off :: Maybe UpdFrameOffset}
95 -- stack offset for return (update frames);
96 -- The return offset should be Nothing only if we have to create
97 -- a new call, e.g. for a procpoint, in which case it's an invariant
98 -- that the call does not stand for a return or a tail call,
99 -- and the successor does not need an info table.
101 data MidCallTarget -- The target of a MidUnsafeCall
102 = ForeignTarget -- A foreign procedure
103 CmmExpr -- Its address
104 ForeignConvention -- Its calling convention
106 | PrimTarget -- A possibly-side-effecting machine operation
107 CallishMachOp -- Which one
111 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
113 | NativeNodeCall -- Native C-- call including the node argument
115 | NativeReturn -- Native C-- return
117 | Slow -- Slow entry points: all args pushed on the stack
119 | GC -- Entry to the garbage collector: uses the node reg!
121 | PrimOpCall -- Calling prim ops
123 | PrimOpReturn -- Returning from prim ops
125 | Foreign -- Foreign call/return
129 -- Used for control transfers within a (pre-CPS) procedure All
130 -- jump sites known, never pushed on the stack (hence no SRT)
131 -- You can choose whatever calling convention you please
132 -- (provided you make sure all the call sites agree)!
133 -- This data type eventually to be extended to record the convention.
136 data ForeignConvention
138 CCallConv -- Which foreign-call convention
139 [ForeignHint] -- Extra info about the args
140 [ForeignHint] -- Extra info about the result
144 = Unsafe -- unsafe call
145 | Safe BlockId -- making infotable requires: 1. label
146 UpdFrameOffset -- 2. where the upd frame is
149 data ValueDirection = Arguments | Results
150 -- Arguments go with procedure definitions, jumps, and arguments to calls
151 -- Results go with returns and with results of calls.
154 {- Note [Foreign calls]
155 ~~~~~~~~~~~~~~~~~~~~~~~
156 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
157 Unsafe ones are easy: think of them as a "fat machine instruction".
159 Safe ones are trickier. A safe foreign call
161 ultimately expands to
162 push "return address" -- Never used to return to;
163 -- just points an info table
164 save registers into TSO
166 r = f(x) -- Make the call
170 We cannot "lower" a safe foreign call to this sequence of Cmms, because
171 after we've saved Sp all the Cmm optimiser's assumptions are broken.
172 Furthermore, currently the smart Cmm constructors know the calling
173 conventions for Haskell, the garbage collector, etc, and "lower" them
174 so that a LastCall passes no parameters or results. But the smart
175 constructors do *not* (currently) know the foreign call conventions.
177 For these reasons use MidForeignCall for all calls. The only annoying thing
178 is that a safe foreign call needs an info table.
181 ----------------------------------------------------------------------
182 ----- Splicing between blocks
183 -- Given a middle node, a block, and a successor BlockId,
184 -- we can insert the middle node between the block and the successor.
185 -- We return the updated block and a list of new blocks that must be added
187 -- The semantics is a bit tricky. We consider cases on the last node:
188 -- o For a branch, we can just insert before the branch,
189 -- but sometimes the optimizer does better if we actually insert
190 -- a fresh basic block, enabling some common blockification.
191 -- o For a conditional branch, switch statement, or call, we must insert
192 -- a new basic block.
193 -- o For a jump or return, this operation is impossible.
195 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
196 insertBetween b ms succId = insert $ goto_end $ unzip b
197 where insert (h, LastOther (LastBranch bid)) =
198 if bid == succId then
199 do (bid', bs) <- newBlocks
200 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
201 else panic "tried invalid block insertBetween"
202 insert (h, LastOther (LastCondBranch c t f)) =
203 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
204 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
205 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
206 insert (h, LastOther (LastSwitch e ks)) =
207 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
208 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
209 insert (_, LastOther (LastCall {})) =
210 panic "unimp: insertBetween after a call -- probably not a good idea"
211 insert (_, LastExit) = panic "cannot insert after exit"
212 newBlocks = do id <- liftM BlockId $ getUniqueM
213 return $ (id, [Block id $
214 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
215 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
216 else return (Just k, [])
217 mbNewBlocks Nothing = return (Nothing, [])
218 lift (id, bs) = (Just id, bs)
220 ----------------------------------------------------------------------
221 ----- Instance declarations for control flow
223 instance HavingSuccessors Last where
225 fold_succs = fold_cmm_succs
227 instance LastNode Last where
228 mkBranchNode id = LastBranch id
229 isBranchNode (LastBranch _) = True
230 isBranchNode _ = False
231 branchNodeTarget (LastBranch id) = id
232 branchNodeTarget _ = panic "asked for target of non-branch"
234 cmmSuccs :: Last -> [BlockId]
235 cmmSuccs (LastBranch id) = [id]
236 cmmSuccs (LastCall _ Nothing _ _ _) = []
237 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
238 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
239 cmmSuccs (LastSwitch _ edges) = catMaybes edges
241 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
242 fold_cmm_succs f (LastBranch id) z = f id z
243 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
244 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
245 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
246 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
248 ----------------------------------------------------------------------
249 ----- Instance declarations for register use
251 instance UserOfLocalRegs Middle where
252 foldRegsUsed f z m = middle m
253 where middle (MidComment {}) = z
254 middle (MidAssign _lhs expr) = fold f z expr
255 middle (MidStore addr rval) = fold f (fold f z addr) rval
256 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
257 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
259 instance UserOfLocalRegs MidCallTarget where
260 foldRegsUsed _f z (PrimTarget _) = z
261 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
263 instance UserOfSlots MidCallTarget where
264 foldSlotsUsed _f z (PrimTarget _) = z
265 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
267 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
268 foldRegsUsed f z (Just x) = foldRegsUsed f z x
269 foldRegsUsed _ z Nothing = z
271 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
272 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
273 foldSlotsUsed _ z Nothing = z
275 instance UserOfLocalRegs Last where
276 foldRegsUsed f z l = last l
277 where last (LastBranch _id) = z
278 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
279 last (LastCondBranch e _ _) = foldRegsUsed f z e
280 last (LastSwitch e _tbl) = foldRegsUsed f z e
282 instance DefinerOfLocalRegs Middle where
283 foldRegsDefd f z m = middle m
284 where middle (MidComment {}) = z
285 middle (MidAssign lhs _) = fold f z lhs
286 middle (MidStore _ _) = z
287 middle (MidForeignCall _ _ fs _) = fold f z fs
288 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
290 instance DefinerOfLocalRegs Last where
291 foldRegsDefd _ z _ = z
294 ----------------------------------------------------------------------
295 ----- Instance declarations for stack slot use
297 instance UserOfSlots Middle where
298 foldSlotsUsed f z m = middle m
299 where middle (MidComment {}) = z
300 middle (MidAssign _lhs expr) = fold f z expr
301 middle (MidStore addr rval) = fold f (fold f z addr) rval
302 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
303 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
305 instance UserOfSlots Last where
306 foldSlotsUsed f z l = last l
307 where last (LastBranch _id) = z
308 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
309 last (LastCondBranch e _ _) = foldSlotsUsed f z e
310 last (LastSwitch e _tbl) = foldSlotsUsed f z e
312 instance UserOfSlots l => UserOfSlots (ZLast l) where
313 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
314 foldSlotsUsed _ z LastExit = z
316 instance DefinerOfSlots Middle where
317 foldSlotsDefd f z m = middle m
318 where middle (MidComment {}) = z
319 middle (MidAssign _ _) = z
320 middle (MidForeignCall {}) = z
321 middle (MidStore (CmmStackSlot a i) e) =
322 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
323 middle (MidStore _ _) = z
325 instance DefinerOfSlots Last where
326 foldSlotsDefd _ z _ = z
328 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
329 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
330 foldSlotsDefd _ z LastExit = z
332 ----------------------------------------------------------------------
333 ----- Code for manipulating Middle and Last nodes
335 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
336 mapExpMiddle _ m@(MidComment _) = m
337 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
338 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
339 mapExpMiddle exp (MidForeignCall s tgt fs as) =
340 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
342 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
343 foldExpMiddle _ (MidComment _) z = z
344 foldExpMiddle exp (MidAssign _ e) z = exp e z
345 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
346 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
348 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
349 mapExpLast _ l@(LastBranch _) = l
350 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
351 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
352 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
354 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
355 foldExpLast _ (LastBranch _) z = z
356 foldExpLast exp (LastCondBranch e _ _) z = exp e z
357 foldExpLast exp (LastSwitch e _) z = exp e z
358 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
360 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
361 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
362 mapExpMidcall _ m@(PrimTarget _) = m
364 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
365 foldExpMidcall exp (ForeignTarget e _) z = exp e z
366 foldExpMidcall _ (PrimTarget _) z = z
368 -- Take a transformer on expressions and apply it recursively.
369 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
370 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
371 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
374 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
375 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
376 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
377 mapExpDeepLast f = mapExpLast $ wrapRecExp f
379 -- Take a folder on expressions and apply it recursively.
380 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
381 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
382 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
383 wrapRecExpf f e z = f e z
385 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
386 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
387 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
388 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
390 ----------------------------------------------------------------------
391 -- Compute the join of facts live out of a Last node. Useful for most backward
393 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
394 joinOuts lattice env l =
395 let bot = fact_bot lattice
396 join x y = txVal $ fact_add_to lattice x y
398 (LastBranch id) -> env id
399 (LastCall _ Nothing _ _ _) -> bot
400 (LastCall _ (Just k) _ _ _) -> env k
401 (LastCondBranch _ t f) -> join (env t) (env f)
402 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
404 ----------------------------------------------------------------------
405 ----- Instance declarations for prettyprinting (avoids recursive imports)
407 instance Outputable Middle where
410 instance Outputable Last where
413 instance Outputable Convention where
416 instance Outputable ForeignConvention where
417 ppr = pprForeignConvention
419 instance Outputable ValueDirection where
420 ppr Arguments = ptext $ sLit "args"
421 ppr Results = ptext $ sLit "results"
423 instance DF.DebugNodes Middle Last
428 pprMiddle :: Middle -> SDoc
429 pprMiddle stmt = pp_stmt <+> pp_debug
431 pp_stmt = case stmt of
433 MidComment s -> text "//" <+> ftext s
436 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
439 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
441 rep = ppr ( cmmExprType expr )
443 -- call "ccall" foo(x, y)[r1, r2];
445 MidForeignCall safety target results args ->
446 hsep [ if null results
448 else parens (commafy $ map ppr results) <+> equals,
451 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
454 if not debugPpr then empty
457 MidComment {} -> text "MidComment"
458 MidAssign {} -> text "MidAssign"
459 MidStore {} -> text "MidStore"
460 MidForeignCall {} -> text "MidForeignCall"
462 ppr_fc :: ForeignConvention -> SDoc
463 ppr_fc (ForeignConvention c args res) =
464 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
466 ppr_safety :: ForeignSafety -> SDoc
467 ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
468 ppr_safety Unsafe = text "unsafe"
470 ppr_call_target :: MidCallTarget -> SDoc
471 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
472 ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
474 ppr_target :: CmmExpr -> SDoc
475 ppr_target t@(CmmLit _) = ppr t
476 ppr_target fn' = parens (ppr fn')
478 pprHinted :: Outputable a => CmmHinted a -> SDoc
479 pprHinted (CmmHinted a NoHint) = ppr a
480 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
481 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
483 pprLast :: Last -> SDoc
484 pprLast stmt = pp_stmt <+> pp_debug
486 pp_stmt = case stmt of
487 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
488 LastCondBranch expr t f -> genFullCondBranch expr t f
489 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
490 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
492 pp_debug = text " //" <+> case stmt of
493 LastBranch {} -> text "LastBranch"
494 LastCondBranch {} -> text "LastCondBranch"
495 LastSwitch {} -> text "LastSwitch"
496 LastCall {} -> text "LastCall"
498 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
499 Maybe UpdFrameOffset -> SDoc
500 genBareCall fn k out res updfr_off =
501 hcat [ ptext (sLit "call"), space
502 , pprFun fn, ptext (sLit "(...)"), space
503 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
505 , ptext (sLit " with update frame") <+> ppr updfr_off
508 pprFun :: CmmExpr -> SDoc
509 pprFun f@(CmmLit _) = ppr f
510 pprFun f = parens (ppr f)
512 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
513 genFullCondBranch expr t f =
514 hsep [ ptext (sLit "if")
516 , ptext (sLit "goto")
518 , ptext (sLit "else goto")
522 pprConvention :: Convention -> SDoc
523 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
524 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
525 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
526 pprConvention Slow = text "<slow-convention>"
527 pprConvention GC = text "<gc-convention>"
528 pprConvention PrimOpCall = text "<primop-call-convention>"
529 pprConvention PrimOpReturn = text "<primop-ret-convention>"
530 pprConvention (Foreign c) = ppr c
531 pprConvention (Private {}) = text "<private-convention>"
533 pprForeignConvention :: ForeignConvention -> SDoc
534 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
536 commafy :: [SDoc] -> SDoc
537 commafy xs = hsep $ punctuate comma xs