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