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
168 Bool -- is the call interruptible?
171 data ValueDirection = Arguments | Results
172 -- Arguments go with procedure definitions, jumps, and arguments to calls
173 -- Results go with returns and with results of calls.
176 {- Note [Foreign calls]
177 ~~~~~~~~~~~~~~~~~~~~~~~
178 A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
179 Unsafe ones are easy: think of them as a "fat machine instruction".
181 Safe ones are trickier. A safe foreign call
183 ultimately expands to
184 push "return address" -- Never used to return to;
185 -- just points an info table
186 save registers into TSO
188 r = f(x) -- Make the call
192 We cannot "lower" a safe foreign call to this sequence of Cmms, because
193 after we've saved Sp all the Cmm optimiser's assumptions are broken.
194 Furthermore, currently the smart Cmm constructors know the calling
195 conventions for Haskell, the garbage collector, etc, and "lower" them
196 so that a LastCall passes no parameters or results. But the smart
197 constructors do *not* (currently) know the foreign call conventions.
199 For these reasons use MidForeignCall for all calls. The only annoying thing
200 is that a safe foreign call needs an info table.
203 ----------------------------------------------------------------------
204 ----- Splicing between blocks
205 -- Given a middle node, a block, and a successor BlockId,
206 -- we can insert the middle node between the block and the successor.
207 -- We return the updated block and a list of new blocks that must be added
209 -- The semantics is a bit tricky. We consider cases on the last node:
210 -- o For a branch, we can just insert before the branch,
211 -- but sometimes the optimizer does better if we actually insert
212 -- a fresh basic block, enabling some common blockification.
213 -- o For a conditional branch, switch statement, or call, we must insert
214 -- a new basic block.
215 -- o For a jump or return, this operation is impossible.
217 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
218 insertBetween b ms succId = insert $ goto_end $ unzip b
219 where insert (h, LastOther (LastBranch bid)) =
220 if bid == succId then
221 do (bid', bs) <- newBlocks
222 return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
223 else panic "tried invalid block insertBetween"
224 insert (h, LastOther (LastCondBranch c t f)) =
225 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
226 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
227 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
228 insert (h, LastOther (LastSwitch e ks)) =
229 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
230 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
231 insert (_, LastOther (LastCall {})) =
232 panic "unimp: insertBetween after a call -- probably not a good idea"
233 insert (_, LastExit) = panic "cannot insert after exit"
234 newBlocks = do id <- liftM BlockId $ getUniqueM
235 return $ (id, [Block id $
236 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
237 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
238 else return (Just k, [])
239 mbNewBlocks Nothing = return (Nothing, [])
240 lift (id, bs) = (Just id, bs)
242 ----------------------------------------------------------------------
243 ----- Instance declarations for control flow
245 instance HavingSuccessors Last where
247 fold_succs = fold_cmm_succs
249 instance LastNode Last where
250 mkBranchNode id = LastBranch id
251 isBranchNode (LastBranch _) = True
252 isBranchNode _ = False
253 branchNodeTarget (LastBranch id) = id
254 branchNodeTarget _ = panic "asked for target of non-branch"
256 cmmSuccs :: Last -> [BlockId]
257 cmmSuccs (LastBranch id) = [id]
258 cmmSuccs (LastCall _ Nothing _ _ _) = []
259 cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
260 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
261 cmmSuccs (LastSwitch _ edges) = catMaybes edges
263 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
264 fold_cmm_succs f (LastBranch id) z = f id z
265 fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
266 fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
267 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
268 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
270 ----------------------------------------------------------------------
271 ----- Instance declarations for register use
273 instance UserOfLocalRegs Middle where
274 foldRegsUsed f z m = middle m
275 where middle (MidComment {}) = z
276 middle (MidAssign _lhs expr) = fold f z expr
277 middle (MidStore addr rval) = fold f (fold f z addr) rval
278 middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
279 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
281 instance UserOfLocalRegs MidCallTarget where
282 foldRegsUsed _f z (PrimTarget _) = z
283 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
285 instance UserOfSlots MidCallTarget where
286 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
287 foldSlotsUsed _f z (PrimTarget _) = z
289 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
290 foldRegsUsed f z (Just x) = foldRegsUsed f z x
291 foldRegsUsed _ z Nothing = z
293 instance (UserOfSlots a) => UserOfSlots (Maybe a) where
294 foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
295 foldSlotsUsed _ z Nothing = z
297 instance UserOfLocalRegs Last where
298 foldRegsUsed f z l = last l
299 where last (LastBranch _id) = z
300 last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
301 last (LastCondBranch e _ _) = foldRegsUsed f z e
302 last (LastSwitch e _tbl) = foldRegsUsed f z e
304 instance DefinerOfLocalRegs Middle where
305 foldRegsDefd f z m = middle m
306 where middle (MidComment {}) = z
307 middle (MidAssign lhs _) = fold f z lhs
308 middle (MidStore _ _) = z
309 middle (MidForeignCall _ _ fs _) = fold f z fs
310 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
312 instance DefinerOfLocalRegs Last where
313 foldRegsDefd _ z _ = z
316 ----------------------------------------------------------------------
317 ----- Instance declarations for stack slot use
319 instance UserOfSlots Middle where
320 foldSlotsUsed f z m = middle m
321 where middle (MidComment {}) = z
322 middle (MidAssign _lhs expr) = fold f z expr
323 middle (MidStore addr rval) = fold f (fold f z addr) rval
324 middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
325 fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
327 instance UserOfSlots Last where
328 foldSlotsUsed f z l = last l
329 where last (LastBranch _id) = z
330 last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
331 last (LastCondBranch e _ _) = foldSlotsUsed f z e
332 last (LastSwitch e _tbl) = foldSlotsUsed f z e
334 instance UserOfSlots l => UserOfSlots (ZLast l) where
335 foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
336 foldSlotsUsed _ z LastExit = z
338 instance DefinerOfSlots Middle where
339 foldSlotsDefd f z m = middle m
340 where middle (MidComment {}) = z
341 middle (MidAssign _ _) = z
342 middle (MidForeignCall {}) = z
343 middle (MidStore (CmmStackSlot a i) e) =
344 f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
345 middle (MidStore _ _) = z
347 instance DefinerOfSlots Last where
348 foldSlotsDefd _ z _ = z
350 instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
351 foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
352 foldSlotsDefd _ z LastExit = z
354 ----------------------------------------------------------------------
355 ----- Code for manipulating Middle and Last nodes
357 mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
358 mapExpMiddle _ m@(MidComment _) = m
359 mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
360 mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
361 mapExpMiddle exp (MidForeignCall s tgt fs as) =
362 MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
364 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
365 foldExpMiddle _ (MidComment _) z = z
366 foldExpMiddle exp (MidAssign _ e) z = exp e z
367 foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
368 foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
370 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
371 mapExpLast _ l@(LastBranch _) = l
372 mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
373 mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
374 mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
376 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
377 foldExpLast _ (LastBranch _) z = z
378 foldExpLast exp (LastCondBranch e _ _) z = exp e z
379 foldExpLast exp (LastSwitch e _) z = exp e z
380 foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
382 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
383 mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
384 mapExpMidcall _ m@(PrimTarget _) = m
386 foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
387 foldExpMidcall exp (ForeignTarget e _) z = exp e z
388 foldExpMidcall _ (PrimTarget _) z = z
390 -- Take a transformer on expressions and apply it recursively.
391 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
392 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
393 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
396 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
397 mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
398 mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
399 mapExpDeepLast f = mapExpLast $ wrapRecExp f
401 -- Take a folder on expressions and apply it recursively.
402 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
403 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
404 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
405 wrapRecExpf f e z = f e z
407 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
408 foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
409 foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
410 foldExpDeepLast f = foldExpLast $ wrapRecExpf f
412 ----------------------------------------------------------------------
413 -- Compute the join of facts live out of a Last node. Useful for most backward
415 joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
416 joinOuts lattice env l =
417 let bot = fact_bot lattice
418 join x y = txVal $ fact_add_to lattice x y
420 (LastBranch id) -> env id
421 (LastCall _ Nothing _ _ _) -> bot
422 (LastCall _ (Just k) _ _ _) -> env k
423 (LastCondBranch _ t f) -> join (env t) (env f)
424 (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
426 ----------------------------------------------------------------------
427 ----- Instance declarations for prettyprinting (avoids recursive imports)
429 instance Outputable Middle where
432 instance Outputable Last where
435 instance Outputable Convention where
438 instance Outputable ForeignConvention where
439 ppr = pprForeignConvention
441 instance Outputable ValueDirection where
442 ppr Arguments = ptext $ sLit "args"
443 ppr Results = ptext $ sLit "results"
445 instance DF.DebugNodes Middle Last
450 pprMiddle :: Middle -> SDoc
451 pprMiddle stmt = pp_stmt <+> pp_debug
453 pp_stmt = case stmt of
455 MidComment s -> text "//" <+> ftext s
458 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
461 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
463 rep = ppr ( cmmExprType expr )
465 -- call "ccall" foo(x, y)[r1, r2];
467 MidForeignCall safety target results args ->
468 hsep [ ppUnless (null results) $
469 parens (commafy $ map ppr results) <+> equals,
472 ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
475 if not debugPpr then empty
478 MidComment {} -> text "MidComment"
479 MidAssign {} -> text "MidAssign"
480 MidStore {} -> text "MidStore"
481 MidForeignCall {} -> text "MidForeignCall"
483 ppr_fc :: ForeignConvention -> SDoc
484 ppr_fc (ForeignConvention c args res) =
485 doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
487 ppr_safety :: ForeignSafety -> SDoc
488 ppr_safety (Safe bid upd interruptible) =
489 text (if interruptible then "interruptible" else "safe") <>
490 text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
491 ppr_safety Unsafe = text "unsafe"
493 ppr_call_target :: MidCallTarget -> SDoc
494 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
495 ppr_call_target (PrimTarget op)
496 -- HACK: We're just using a ForeignLabel to get this printed, the label
497 -- might not really be foreign.
498 = ppr (CmmLabel (mkForeignLabel
499 (mkFastString (show op))
500 Nothing ForeignLabelInThisPackage IsFunction))
502 ppr_target :: CmmExpr -> SDoc
503 ppr_target t@(CmmLit _) = ppr t
504 ppr_target fn' = parens (ppr fn')
506 pprHinted :: Outputable a => CmmHinted a -> SDoc
507 pprHinted (CmmHinted a NoHint) = ppr a
508 pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
509 pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
511 pprLast :: Last -> SDoc
512 pprLast stmt = pp_stmt <+> pp_debug
514 pp_stmt = case stmt of
515 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
516 LastCondBranch expr t f -> genFullCondBranch expr t f
517 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
518 LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
520 pp_debug = text " //" <+> case stmt of
521 LastBranch {} -> text "LastBranch"
522 LastCondBranch {} -> text "LastCondBranch"
523 LastSwitch {} -> text "LastSwitch"
524 LastCall {} -> text "LastCall"
526 genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
527 Maybe UpdFrameOffset -> SDoc
528 genBareCall fn k out res updfr_off =
529 hcat [ ptext (sLit "call"), space
530 , pprFun fn, ptext (sLit "(...)"), space
531 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
533 , ptext (sLit " with update frame") <+> ppr updfr_off
536 pprFun :: CmmExpr -> SDoc
537 pprFun f@(CmmLit _) = ppr f
538 pprFun f = parens (ppr f)
540 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
541 genFullCondBranch expr t f =
542 hsep [ ptext (sLit "if")
544 , ptext (sLit "goto")
546 , ptext (sLit "else goto")
550 pprConvention :: Convention -> SDoc
551 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
552 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
553 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
554 pprConvention Slow = text "<slow-convention>"
555 pprConvention GC = text "<gc-convention>"
556 pprConvention PrimOpCall = text "<primop-call-convention>"
557 pprConvention PrimOpReturn = text "<primop-ret-convention>"
558 pprConvention (Foreign c) = ppr c
559 pprConvention (Private {}) = text "<private-convention>"
561 pprForeignConvention :: ForeignConvention -> SDoc
562 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
564 commafy :: [SDoc] -> SDoc
565 commafy xs = hsep $ punctuate comma xs