1 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
2 -- Norman likes local bindings
4 -- This module is pure representation and should be imported only by
5 -- clients that need to manipulate representation and know what
6 -- they're doing. Clients that need to create flow graphs should
7 -- instead import MkZipCfgCmm.
10 ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
11 , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
12 , Convention(..), ForeignConvention(..), ForeignSafety(..)
13 , ValueDirection(..), ForeignHint(..)
14 , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
15 , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
16 , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
22 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
23 , CallishMachOp(..), ForeignHint(..)
24 , CmmActuals, CmmFormals, CmmHinted(..)
25 , CmmStmt(..) -- imported in order to call ppr on Switch and to
26 -- implement pprCmmGraphLikeCmm
35 import qualified ZipDataflow as DF
44 import Prelude hiding (zip, unzip, last)
45 import SMRep (ByteOff)
48 ----------------------------------------------------------------------
49 ----- Type synonyms and definitions
51 type CmmGraph = LGraph Middle Last
52 type CmmAGraph = AGraph Middle Last
53 type CmmBlock = Block Middle Last
54 type CmmStackInfo = (ByteOff, Maybe ByteOff)
55 -- probably want a record; (SP offset on entry, update frame space)
56 type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
57 type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
58 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
59 type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
61 type UpdFrameOffset = ByteOff
64 = MidComment FastString
66 | MidAssign CmmReg CmmExpr -- Assign to register
68 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
69 -- given by cmmExprType of the rhs.
71 | MidForeignCall -- A foreign call; see Note [Foreign calls]
72 ForeignSafety -- Is it a safe or unsafe call?
73 MidCallTarget -- call target and convention
74 CmmFormals -- zero or more results
75 CmmActuals -- zero or more arguments
79 = LastBranch BlockId -- Goto another block in the same procedure
81 | LastCondBranch { -- conditional branch
83 cml_true, cml_false :: BlockId
85 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
86 -- The scrutinee is zero-based;
87 -- zero -> first block
88 -- one -> second block etc
89 -- Undefined outside range, and when there's a Nothing
90 | LastCall { -- A call (native or safe foreign)
91 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
93 cml_cont :: Maybe BlockId,
94 -- BlockId of continuation (Nothing for return or tail call)
97 -- Byte offset, from the *old* end of the Area associated with
98 -- the BlockId (if cml_cont = Nothing, then Old area), of
99 -- youngest outgoing arg. Set the stack pointer to this before
100 -- transferring control.
101 -- (NB: an update frame might also have been stored in the Old
102 -- area, but it'll be in an older part than the args.)
104 cml_ret_args :: ByteOff,
105 -- For calls *only*, the byte offset for youngest returned value
106 -- This is really needed at the *return* point rather than here
107 -- at the call, but in practice it's convenient to record it here.
109 cml_ret_off :: Maybe ByteOff
110 -- For calls *only*, the byte offset of the base of the frame that
111 -- must be described by the info table for the return point.
112 -- The older words are an update frames, which have their own
113 -- info-table and layout information
115 -- From a liveness point of view, the stack words older than
116 -- cml_ret_off are treated as live, even if the sequel of
117 -- the call goes into a loop.
120 data MidCallTarget -- The target of a MidUnsafeCall
121 = ForeignTarget -- A foreign procedure
122 CmmExpr -- Its address
123 ForeignConvention -- Its calling convention
125 | PrimTarget -- A possibly-side-effecting machine operation
126 CallishMachOp -- Which one
130 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
132 | NativeNodeCall -- Native C-- call including the node argument
134 | NativeReturn -- Native C-- return
136 | Slow -- Slow entry points: all args pushed on the stack
138 | GC -- Entry to the garbage collector: uses the node reg!
140 | PrimOpCall -- Calling prim ops
142 | PrimOpReturn -- Returning from prim ops
144 | Foreign -- Foreign call/return
148 -- Used for control transfers within a (pre-CPS) procedure All
149 -- jump sites known, never pushed on the stack (hence no SRT)
150 -- You can choose whatever calling convention you please
151 -- (provided you make sure all the call sites agree)!
152 -- This data type eventually to be extended to record the convention.
155 data ForeignConvention
157 CCallConv -- Which foreign-call convention
158 [ForeignHint] -- Extra info about the args
159 [ForeignHint] -- Extra info about the result
163 = Unsafe -- unsafe call
164 | Safe BlockId -- making infotable requires: 1. label
165 UpdFrameOffset -- 2. where the upd frame is
166 Bool -- is the call interruptible?
169 data ValueDirection = Arguments | Results
170 -- Arguments go with procedure definitions, jumps, and arguments to calls
171 -- Results go with returns and with results of calls.
174 {- Note [Foreign calls]
175 ~~~~~~~~~~~~~~~~~~~~~~~
176 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
177 Unsafe ones are easy: think of them as a "fat machine instruction".
179 Safe ones are trickier. A safe foreign call
181 ultimately expands to
182 push "return address" -- Never used to return to;
183 -- just points an info table
184 save registers into TSO
186 r = f(x) -- Make the call
190 We cannot "lower" a safe foreign call to this sequence of Cmms, because
191 after we've saved Sp all the Cmm optimiser's assumptions are broken.
192 Furthermore, currently the smart Cmm constructors know the calling
193 conventions for Haskell, the garbage collector, etc, and "lower" them
194 so that a LastCall passes no parameters or results. But the smart
195 constructors do *not* (currently) know the foreign call conventions.
197 For these reasons use MidForeignCall for all calls. The only annoying thing
198 is that a safe foreign call needs an info table.
201 ----------------------------------------------------------------------
202 ----- Splicing between blocks
203 -- Given a middle node, a block, and a successor BlockId,
204 -- we can insert the middle node between the block and the successor.
205 -- We return the updated block and a list of new blocks that must be added
207 -- The semantics is a bit tricky. We consider cases on the last node:
208 -- o For a branch, we can just insert before the branch,
209 -- but sometimes the optimizer does better if we actually insert
210 -- a fresh basic block, enabling some common blockification.
211 -- o For a conditional branch, switch statement, or call, we must insert
212 -- a new basic block.
213 -- o For a jump or return, this operation is impossible.
215 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
216 insertBetween b ms succId = insert $ goto_end $ unzip b
217 where insert (h, LastOther (LastBranch bid)) =
218 if bid == succId then
219 do (bid', bs) <- newBlocks
220 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
221 else panic "tried invalid block insertBetween"
222 insert (h, LastOther (LastCondBranch c t f)) =
223 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
224 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
225 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
226 insert (h, LastOther (LastSwitch e ks)) =
227 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
228 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
229 insert (_, LastOther (LastCall {})) =
230 panic "unimp: insertBetween after a call -- probably not a good idea"
231 insert (_, LastExit) = panic "cannot insert after exit"
232 newBlocks = do id <- liftM BlockId $ getUniqueM
233 return $ (id, [Block id $
234 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
235 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
236 else return (Just k, [])
237 mbNewBlocks Nothing = return (Nothing, [])
238 lift (id, bs) = (Just id, bs)
240 ----------------------------------------------------------------------
241 ----- Instance declarations for control flow
243 instance HavingSuccessors Last where
245 fold_succs = fold_cmm_succs
247 instance LastNode Last where
248 mkBranchNode id = LastBranch id
249 isBranchNode (LastBranch _) = True
250 isBranchNode _ = False
251 branchNodeTarget (LastBranch id) = id
252 branchNodeTarget _ = panic "asked for target of non-branch"
254 cmmSuccs :: Last -> [BlockId]
255 cmmSuccs (LastBranch id) = [id]
256 cmmSuccs (LastCall _ Nothing _ _ _) = []
257 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
258 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
259 cmmSuccs (LastSwitch _ edges) = catMaybes edges
261 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
262 fold_cmm_succs f (LastBranch id) z = f id z
263 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
264 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
265 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
266 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
268 ----------------------------------------------------------------------
269 ----- Instance declarations for register use
271 instance UserOfLocalRegs Middle where
272 foldRegsUsed f z m = middle m
273 where middle (MidComment {}) = z
274 middle (MidAssign _lhs expr) = fold f z expr
275 middle (MidStore addr rval) = fold f (fold f z addr) rval
276 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
277 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
279 instance UserOfLocalRegs MidCallTarget where
280 foldRegsUsed _f z (PrimTarget _) = z
281 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
283 instance UserOfSlots MidCallTarget where
284 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
285 foldSlotsUsed _f z (PrimTarget _) = z
287 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
288 foldRegsUsed f z (Just x) = foldRegsUsed f z x
289 foldRegsUsed _ z Nothing = z
291 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
292 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
293 foldSlotsUsed _ z Nothing = z
295 instance UserOfLocalRegs Last where
296 foldRegsUsed f z l = last l
297 where last (LastBranch _id) = z
298 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
299 last (LastCondBranch e _ _) = foldRegsUsed f z e
300 last (LastSwitch e _tbl) = foldRegsUsed f z e
302 instance DefinerOfLocalRegs Middle where
303 foldRegsDefd f z m = middle m
304 where middle (MidComment {}) = z
305 middle (MidAssign lhs _) = fold f z lhs
306 middle (MidStore _ _) = z
307 middle (MidForeignCall _ _ fs _) = fold f z fs
308 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
310 instance DefinerOfLocalRegs Last where
311 foldRegsDefd _ z _ = z
314 ----------------------------------------------------------------------
315 ----- Instance declarations for stack slot use
317 instance UserOfSlots Middle where
318 foldSlotsUsed f z m = middle m
319 where middle (MidComment {}) = z
320 middle (MidAssign _lhs expr) = fold f z expr
321 middle (MidStore addr rval) = fold f (fold f z addr) rval
322 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
323 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
325 instance UserOfSlots Last where
326 foldSlotsUsed f z l = last l
327 where last (LastBranch _id) = z
328 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
329 last (LastCondBranch e _ _) = foldSlotsUsed f z e
330 last (LastSwitch e _tbl) = foldSlotsUsed f z e
332 instance UserOfSlots l => UserOfSlots (ZLast l) where
333 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
334 foldSlotsUsed _ z LastExit = z
336 instance DefinerOfSlots Middle where
337 foldSlotsDefd f z m = middle m
338 where middle (MidComment {}) = z
339 middle (MidAssign _ _) = z
340 middle (MidForeignCall {}) = z
341 middle (MidStore (CmmStackSlot a i) e) =
342 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
343 middle (MidStore _ _) = z
345 instance DefinerOfSlots Last where
346 foldSlotsDefd _ z _ = z
348 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
349 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
350 foldSlotsDefd _ z LastExit = z
352 ----------------------------------------------------------------------
353 ----- Code for manipulating Middle and Last nodes
355 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
356 mapExpMiddle _ m@(MidComment _) = m
357 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
358 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
359 mapExpMiddle exp (MidForeignCall s tgt fs as) =
360 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
362 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
363 foldExpMiddle _ (MidComment _) z = z
364 foldExpMiddle exp (MidAssign _ e) z = exp e z
365 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
366 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
368 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
369 mapExpLast _ l@(LastBranch _) = l
370 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
371 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
372 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
374 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
375 foldExpLast _ (LastBranch _) z = z
376 foldExpLast exp (LastCondBranch e _ _) z = exp e z
377 foldExpLast exp (LastSwitch e _) z = exp e z
378 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
380 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
381 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
382 mapExpMidcall _ m@(PrimTarget _) = m
384 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
385 foldExpMidcall exp (ForeignTarget e _) z = exp e z
386 foldExpMidcall _ (PrimTarget _) z = z
388 -- Take a transformer on expressions and apply it recursively.
389 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
390 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
391 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
394 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
395 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
396 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
397 mapExpDeepLast f = mapExpLast $ wrapRecExp f
399 -- Take a folder on expressions and apply it recursively.
400 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
401 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
402 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
403 wrapRecExpf f e z = f e z
405 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
406 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
407 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
408 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
410 ----------------------------------------------------------------------
411 -- Compute the join of facts live out of a Last node. Useful for most backward
413 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
414 joinOuts lattice env l =
415 let bot = fact_bot lattice
416 join x y = txVal $ fact_add_to lattice x y
418 (LastBranch id) -> env id
419 (LastCall _ Nothing _ _ _) -> bot
420 (LastCall _ (Just k) _ _ _) -> env k
421 (LastCondBranch _ t f) -> join (env t) (env f)
422 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
424 ----------------------------------------------------------------------
425 ----- Instance declarations for prettyprinting (avoids recursive imports)
427 instance Outputable Middle where
430 instance Outputable Last where
433 instance Outputable Convention where
436 instance Outputable ForeignConvention where
437 ppr = pprForeignConvention
439 instance Outputable ValueDirection where
440 ppr Arguments = ptext $ sLit "args"
441 ppr Results = ptext $ sLit "results"
443 instance DF.DebugNodes Middle Last
448 pprMiddle :: Middle -> SDoc
449 pprMiddle stmt = pp_stmt <+> pp_debug
451 pp_stmt = case stmt of
453 MidComment s -> text "//" <+> ftext s
456 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
459 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
461 rep = ppr ( cmmExprType expr )
463 -- call "ccall" foo(x, y)[r1, r2];
465 MidForeignCall safety target results args ->
466 hsep [ ppUnless (null results) $
467 parens (commafy $ map ppr results) <+> equals,
470 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
473 if not debugPpr then empty
476 MidComment {} -> text "MidComment"
477 MidAssign {} -> text "MidAssign"
478 MidStore {} -> text "MidStore"
479 MidForeignCall {} -> text "MidForeignCall"
481 ppr_fc :: ForeignConvention -> SDoc
482 ppr_fc (ForeignConvention c args res) =
483 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
485 ppr_safety :: ForeignSafety -> SDoc
486 ppr_safety (Safe bid upd interruptible) =
487 text (if interruptible then "interruptible" else "safe") <>
488 text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
489 ppr_safety Unsafe = text "unsafe"
491 ppr_call_target :: MidCallTarget -> SDoc
492 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
493 ppr_call_target (PrimTarget op)
494 -- HACK: We're just using a ForeignLabel to get this printed, the label
495 -- might not really be foreign.
496 = ppr (CmmLabel (mkForeignLabel
497 (mkFastString (show op))
498 Nothing ForeignLabelInThisPackage IsFunction))
500 ppr_target :: CmmExpr -> SDoc
501 ppr_target t@(CmmLit _) = ppr t
502 ppr_target fn' = parens (ppr fn')
504 pprHinted :: Outputable a => CmmHinted a -> SDoc
505 pprHinted (CmmHinted a NoHint) = ppr a
506 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
507 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
509 pprLast :: Last -> SDoc
510 pprLast stmt = pp_stmt <+> pp_debug
512 pp_stmt = case stmt of
513 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
514 LastCondBranch expr t f -> genFullCondBranch expr t f
515 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
516 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
518 pp_debug = text " //" <+> case stmt of
519 LastBranch {} -> text "LastBranch"
520 LastCondBranch {} -> text "LastCondBranch"
521 LastSwitch {} -> text "LastSwitch"
522 LastCall {} -> text "LastCall"
524 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
525 Maybe UpdFrameOffset -> SDoc
526 genBareCall fn k out res updfr_off =
527 hcat [ ptext (sLit "call"), space
528 , pprFun fn, ptext (sLit "(...)"), space
529 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
531 , ptext (sLit " with update frame") <+> ppr updfr_off
534 pprFun :: CmmExpr -> SDoc
535 pprFun f@(CmmLit _) = ppr f
536 pprFun f = parens (ppr f)
538 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
539 genFullCondBranch expr t f =
540 hsep [ ptext (sLit "if")
542 , ptext (sLit "goto")
544 , ptext (sLit "else goto")
548 pprConvention :: Convention -> SDoc
549 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
550 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
551 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
552 pprConvention Slow = text "<slow-convention>"
553 pprConvention GC = text "<gc-convention>"
554 pprConvention PrimOpCall = text "<primop-call-convention>"
555 pprConvention PrimOpReturn = text "<primop-ret-convention>"
556 pprConvention (Foreign c) = ppr c
557 pprConvention (Private {}) = text "<private-convention>"
559 pprForeignConvention :: ForeignConvention -> SDoc
560 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
562 commafy :: [SDoc] -> SDoc
563 commafy xs = hsep $ punctuate comma xs