3 -- This module is pure representation and should be imported only by
4 -- clients that need to manipulate representation and know what
5 -- they're doing. Clients that need to create flow graphs should
6 -- instead import MkZipCfgCmm.
9 ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
10 , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint
11 , insertBetween, pprCmmGraphLikeCmm
17 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
18 , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
19 , CmmStmt(..) -- imported in order to call ppr on Switch and to
20 -- implement pprCmmGraphLikeCmm
21 , CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
22 , CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm
32 import qualified ZipCfg as Z
33 import qualified ZipDataflow as DF
41 import Prelude hiding (zip, unzip, last)
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 CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
52 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
53 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
54 type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
57 = MidComment FastString
59 | MidAssign CmmReg CmmExpr -- Assign to register
61 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
62 -- given by cmmExprRep of the rhs.
64 | MidUnsafeCall -- An "unsafe" foreign call;
65 CmmCallTarget -- just a fat machine instruction
66 CmmFormals -- zero or more results
67 CmmActuals -- zero or more arguments
69 | MidAddToContext -- push a frame on the stack;
70 -- I will return to this frame
71 CmmExpr -- The frame's return address; it must be
72 -- preceded by an info table that describes the
74 [CmmExpr] -- The frame's live variables, to go on the
75 -- stack with the first one at the young end
77 | CopyIn -- Move incoming parameters or results from conventional
78 -- locations to registers. Note [CopyIn invariant]
80 CmmFormals -- eventually [CmmKind] will be used only for foreign
81 -- calls and will migrate into 'Convention' (helping to
82 -- drain "the swamp"), leaving this as [LocalReg]
83 C_SRT -- Static things kept alive by this block
85 | CopyOut Convention CmmActuals
86 -- Move outgoing parameters or results from registers to
87 -- conventional locations. Every 'LastReturn',
88 -- 'LastJump', or 'LastCall' must be dominated by a
89 -- matching 'CopyOut' in the same basic block.
90 -- As above, '[CmmKind]' will migrate into the foreign calling
91 -- convention, leaving the actuals as '[CmmExpr]'.
95 = LastBranch BlockId -- Goto another block in the same procedure
97 | LastCondBranch { -- conditional branch
99 cml_true, cml_false :: BlockId
102 | LastReturn -- Return from a function; values in a previous CopyOut node
104 | LastJump CmmExpr -- Tail call to another procedure; args in a CopyOut node
106 | LastCall { -- A call (native or safe foreign); args in CopyOut node
107 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
108 cml_cont :: Maybe BlockId } -- BlockId of continuation, if call returns
110 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
111 -- The scrutinee is zero-based;
112 -- zero -> first block
113 -- one -> second block etc
114 -- Undefined outside range, and when there's a Nothing
117 = ConventionStandard CCallConv ValueDirection
119 -- Used for control transfers within a (pre-CPS) procedure All
120 -- jump sites known, never pushed on the stack (hence no SRT)
121 -- You can choose whatever calling convention you please
122 -- (provided you make sure all the call sites agree)!
123 -- This data type eventually to be extended to record the convention.
127 data ValueDirection = Arguments | Results
128 -- Arguments go with procedure definitions, jumps, and arguments to calls
129 -- Results go with returns and with results of calls.
133 Note [CopyIn invariant]
134 ~~~~~~~~~~~~~~~~~~~~~~~
135 One might wish for CopyIn to be a First node, but in practice, the
136 possibility raises all sorts of hairy issues with graph splicing,
137 rewriting, and so on. In the end, NR finds it better to make the
138 placement of CopyIn a dynamic invariant; it should normally be the first
139 Middle node in the basic block in which it occurs.
142 ----------------------------------------------------------------------
143 ----- Splicing between blocks
144 -- Given a middle node, a block, and a successor BlockId,
145 -- we can insert the middle node between the block and the successor.
146 -- We return the updated block and a list of new blocks that must be added
148 -- The semantics is a bit tricky. We consider cases on the last node:
149 -- o For a branch, we can just insert before the branch,
150 -- but sometimes the optimizer does better if we actually insert
151 -- a fresh basic block, enabling some common blockification.
152 -- o For a conditional branch, switch statement, or call, we must insert
153 -- a new basic block.
154 -- o For a jump, or return, this operation is impossible.
156 insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
157 insertBetween b ms succId = insert $ goto_end $ unzip b
158 where insert (h, LastOther (LastBranch bid)) =
159 if bid == succId then
160 do (bid', bs) <- newBlocks
161 return (zipht h $ ZLast $ LastOther (LastBranch bid'), bs)
162 else panic "tried to insert between non-adjacent blocks"
163 insert (h, LastOther (LastCondBranch c t f)) =
164 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
165 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
166 return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
167 insert (h, LastOther (LastCall e (Just k))) =
169 do (id', bs) <- newBlocks
170 return (zipht h $ ZLast $ LastOther (LastCall e (Just id')), bs)
171 else panic "tried to insert between non-adjacent blocks"
172 insert (_, LastOther (LastCall _ Nothing)) =
173 panic "cannot insert after non-returning call"
174 insert (h, LastOther (LastSwitch e ks)) =
175 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
176 return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
177 insert (_, LastOther LastReturn) = panic "cannot insert after return"
178 insert (_, LastOther (LastJump _)) = panic "cannot insert after jump"
179 insert (_, LastExit) = panic "cannot insert after exit"
180 newBlocks = do id <- liftM BlockId $ getUniqueM
181 return $ (id, [Block id $
182 foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
183 mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
184 else return (Just k, [])
185 mbNewBlocks Nothing = return (Nothing, [])
186 lift (id, bs) = (Just id, bs)
189 ----------------------------------------------------------------------
190 ----- Instance declarations for control flow
192 instance HavingSuccessors Last where
194 fold_succs = fold_cmm_succs
196 instance LastNode Last where
197 mkBranchNode id = LastBranch id
198 isBranchNode (LastBranch _) = True
199 isBranchNode _ = False
200 branchNodeTarget (LastBranch id) = id
201 branchNodeTarget _ = panic "asked for target of non-branch"
203 cmmSuccs :: Last -> [BlockId]
204 cmmSuccs (LastReturn {}) = []
205 cmmSuccs (LastJump {}) = []
206 cmmSuccs (LastBranch id) = [id]
207 cmmSuccs (LastCall _ (Just id)) = [id]
208 cmmSuccs (LastCall _ Nothing) = []
209 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
210 cmmSuccs (LastSwitch _ edges) = catMaybes edges
212 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
213 fold_cmm_succs _f (LastReturn {}) z = z
214 fold_cmm_succs _f (LastJump {}) z = z
215 fold_cmm_succs f (LastBranch id) z = f id z
216 fold_cmm_succs f (LastCall _ (Just id)) z = f id z
217 fold_cmm_succs _f (LastCall _ Nothing) z = z
218 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
219 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
221 ----------------------------------------------------------------------
222 ----- Instance declarations for register use
224 instance UserOfLocalRegs Middle where
225 foldRegsUsed f z m = middle m
226 where middle (MidComment {}) = z
227 middle (MidAssign _lhs expr) = fold f z expr
228 middle (MidStore addr rval) = fold f (fold f z addr) rval
229 middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
230 middle (MidAddToContext ra args) = fold f (fold f z ra) args
231 middle (CopyIn _ _formals _) = z
232 middle (CopyOut _ actuals) = fold f z actuals
233 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
235 instance UserOfLocalRegs Last where
236 foldRegsUsed f z l = last l
237 where last (LastReturn) = z
238 last (LastJump e) = foldRegsUsed f z e
239 last (LastBranch _id) = z
240 last (LastCall tgt _) = foldRegsUsed f z tgt
241 last (LastCondBranch e _ _) = foldRegsUsed f z e
242 last (LastSwitch e _tbl) = foldRegsUsed f z e
244 instance DefinerOfLocalRegs Middle where
245 foldRegsDefd f z m = middle m
246 where middle (MidComment {}) = z
247 middle (MidAssign _lhs _) = fold f z _lhs
248 middle (MidStore _ _) = z
249 middle (MidUnsafeCall _ _ _) = z
250 middle (MidAddToContext _ _) = z
251 middle (CopyIn _ _formals _) = fold f z _formals
252 middle (CopyOut _ _) = z
253 fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
255 instance DefinerOfLocalRegs Last where
256 foldRegsDefd _ z l = last l
257 where last (LastReturn) = z
258 last (LastJump _) = z
259 last (LastBranch _) = z
260 last (LastCall _ _) = z
261 last (LastCondBranch _ _ _) = z
262 last (LastSwitch _ _) = z
264 ----------------------------------------------------------------------
265 ----- Instance declarations for prettyprinting (avoids recursive imports)
267 instance Outputable Middle where
270 instance Outputable Last where
273 instance Outputable Convention where
276 instance DF.DebugNodes Middle Last
281 pprMiddle :: Middle -> SDoc
282 pprMiddle stmt = pp_stmt <+> pp_debug
284 pp_stmt = case stmt of
286 CopyIn conv args _ ->
287 if null args then ptext (sLit "empty CopyIn")
288 else commafy (map pprKinded args) <+> equals <+>
289 ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...")
292 ptext (sLit "PreCopyOut: next, pass") <+> doubleQuotes(ppr conv) <+>
293 parens (commafy (map pprKinded args))
296 MidComment s -> text "//" <+> ftext s
299 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
302 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
304 rep = ppr ( cmmExprRep expr )
306 -- call "ccall" foo(x, y)[r1, r2];
308 MidUnsafeCall (CmmCallee fn cconv) results args ->
309 hcat [ if null results
311 else parens (commafy $ map ppr results) <>
313 ptext (sLit "call"), space,
314 doubleQuotes(ppr cconv), space,
315 ppr_target fn, parens ( commafy $ map ppr args ),
318 MidUnsafeCall (CmmPrim op) results args ->
319 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
321 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
323 MidAddToContext ra args ->
324 hcat [ ptext (sLit "return via ")
325 , ppr_target ra, parens (commafy $ map ppr args), semi ]
328 if not debugPpr then empty
331 CopyIn {} -> text "CopyIn"
332 CopyOut {} -> text "CopyOut"
333 MidComment {} -> text "MidComment"
334 MidAssign {} -> text "MidAssign"
335 MidStore {} -> text "MidStore"
336 MidUnsafeCall {} -> text "MidUnsafeCall"
337 MidAddToContext {} -> text "MidAddToContext"
340 ppr_target :: CmmExpr -> SDoc
341 ppr_target t@(CmmLit _) = ppr t
342 ppr_target fn' = parens (ppr fn')
345 pprKinded :: Outputable a => CmmKinded a -> SDoc
346 pprKinded (CmmKinded a NoHint) = ppr a
347 pprKinded (CmmKinded a PtrHint) = doubleQuotes (text "address") <+> ppr a
348 pprKinded (CmmKinded a SignedHint) = doubleQuotes (text "signed") <+> ppr a
349 pprKinded (CmmKinded a FloatHint) = doubleQuotes (text "float") <+> ppr a
351 pprLast :: Last -> SDoc
352 pprLast stmt = (case stmt of
353 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
354 LastCondBranch expr t f -> genFullCondBranch expr t f
355 LastJump expr -> hcat [ ptext (sLit "jump"), space, pprFun expr
356 , ptext (sLit "(...)"), semi]
357 LastReturn -> hcat [ ptext (sLit "return"), space
358 , ptext (sLit "(...)"), semi]
359 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
360 LastCall tgt k -> genBareCall tgt k
362 if debugPpr then empty
365 LastBranch {} -> text "LastBranch"
366 LastCondBranch {} -> text "LastCondBranch"
367 LastJump {} -> text "LastJump"
368 LastReturn {} -> text "LastReturn"
369 LastSwitch {} -> text "LastSwitch"
370 LastCall {} -> text "LastCall"
372 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
374 hcat [ ptext (sLit "call"), space
375 , pprFun fn, ptext (sLit "(...)"), space
376 , case k of Nothing -> ptext (sLit "never returns")
377 Just k -> ptext (sLit "returns to") <+> ppr k
381 pprFun :: CmmExpr -> SDoc
382 pprFun f@(CmmLit _) = ppr f
383 pprFun f = parens (ppr f)
385 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
386 genFullCondBranch expr t f =
387 hsep [ ptext (sLit "if")
389 , ptext (sLit "goto")
391 , ptext (sLit "else goto")
395 pprConvention :: Convention -> SDoc
396 pprConvention (ConventionStandard c _) = ppr c
397 pprConvention (ConventionPrivate {} ) = text "<private-convention>"
399 commafy :: [SDoc] -> SDoc
400 commafy xs = hsep $ punctuate comma xs
403 ----------------------------------------------------------------
404 -- | The purpose of this function is to print a Cmm zipper graph "as if it were"
405 -- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
406 -- code are dodgy as well.
408 pprCmmGraphLikeCmm :: CmmGraph -> SDoc
409 pprCmmGraphLikeCmm g = vcat (swallow blocks)
410 where blocks = Z.postorder_dfs g
411 swallow :: [CmmBlock] -> [SDoc]
413 swallow (Z.Block id t : rest) = tail id [] Nothing t rest
414 tail id prev' out (Z.ZTail (CopyOut conv args) t) rest =
415 if isJust out then panic "multiple CopyOut nodes in one basic block"
417 tail id (prev') (Just (conv, args)) t rest
418 tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
419 tail id prev' out (Z.ZLast Z.LastExit) rest = exit id prev' out rest
420 tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
421 mid (CopyIn _ [] _) = text "// proc point (no parameters)"
422 mid m@(CopyIn {}) = ppr m <+> text "(proc point)"
425 | id == Z.lg_entry g, entry_has_no_pred =
426 vcat (text "<entry>" : reverse prev')
427 | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
428 last id prev' out l n =
429 let endblock stmt = block' id (stmt : prev') : swallow n in
434 | tgt == id', unique_pred id'
435 -> tail id prev' out t bs -- optimize out redundant labels
436 _ -> endblock (ppr $ CmmBranch tgt)
437 l@(LastCondBranch expr tid fid) ->
438 let ft id = text "// fall through to " <> ppr id in
441 | id' == fid, isNothing out ->
442 tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
443 | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
444 tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
445 _ -> endblock $ with_out out l
446 l@(LastJump {}) -> endblock $ with_out out l
447 l@(LastReturn {}) -> endblock $ with_out out l
448 l@(LastSwitch {}) -> endblock $ with_out out l
449 l@(LastCall _ Nothing) -> endblock $ with_out out l
450 l@(LastCall tgt (Just k))
451 | Z.Block id' (Z.ZTail (CopyIn _ ress srt) t) : bs <- n,
452 Just (conv, args) <- out,
454 let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
455 tgt' = CmmCallee tgt (cconv_of_conv conv)
456 ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
457 in if unique_pred k then
458 tail id (ppcall : prev') Nothing t bs
461 | Z.Block id' t : bs <- n, id' == k, unique_pred k,
462 Just (conv, args) <- out,
463 Just (ress, srt) <- findCopyIn t ->
464 let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
465 tgt' = CmmCallee tgt (cconv_of_conv conv)
467 ptext (sLit "// delayed CopyIn follows previous call")
468 in tail id (delayed : ppr call : prev') Nothing t bs
469 | otherwise -> endblock $ with_out out l
470 findCopyIn (Z.ZTail (CopyIn _ ress srt) _) = Just (ress, srt)
471 findCopyIn (Z.ZTail _ t) = findCopyIn t
472 findCopyIn (Z.ZLast _) = Nothing
473 exit id prev' out n = -- highly irregular (assertion violation?)
474 let endblock stmt = block' id (stmt : prev') : swallow n in
475 case out of Nothing -> endblock (text "// <exit>")
476 Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
479 entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
481 Just s -> isEmptyUniqSet s
485 in case lookupBlockEnv preds id of
487 Just s -> if sizeUniqSet s == 1 then
488 extendBlockSet single id
490 in Z.fold_blocks add emptyBlockSet g
491 unique_pred id = elemBlockSet id single_preds
492 cconv_of_conv (ConventionStandard conv _) = conv
493 cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
495 with_out :: Maybe (Convention, CmmActuals) -> Last -> SDoc
496 with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
497 with_out (Just (conv, args)) l = last l
498 where last (LastCall e k) =
499 hcat [ptext (sLit "... = foreign "),
500 doubleQuotes(ppr conv), space,
501 ppr_target e, parens ( commafy $ map ppr args ),
502 ptext (sLit " \"safe\""),
503 case k of Nothing -> ptext (sLit " never returns")
506 last (LastReturn) = ppr (CmmReturn args)
507 last (LastJump e) = ppr (CmmJump e args)
508 last l = ppr (CopyOut conv args) $$ ppr l
509 ppr_target (CmmLit lit) = ppr lit
510 ppr_target fn' = parens (ppr fn')
511 commafy xs = hsep $ punctuate comma xs