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(..)
16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
17 , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
18 , CmmStmt(..) -- imported in order to call ppr on Switch and to
19 -- implement pprCmmGraphLikeCmm
20 , CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
21 , CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm
31 import qualified ZipCfg as Z
32 import qualified ZipDataflow0 as DF
40 import Prelude hiding (zip, unzip, last)
42 ----------------------------------------------------------------------
43 ----- Type synonyms and definitions
45 type CmmGraph = LGraph Middle Last
46 type CmmAGraph = AGraph Middle Last
47 type CmmBlock = Block Middle Last
48 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
49 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
52 = MidComment FastString
54 | MidAssign CmmReg CmmExpr -- Assign to register
56 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
57 -- given by cmmExprRep of the rhs.
59 | MidUnsafeCall -- An "unsafe" foreign call;
60 CmmCallTarget -- just a fat machine instructoin
61 CmmFormals -- zero or more results
62 CmmActuals -- zero or more arguments
64 | MidAddToContext -- push a frame on the stack;
65 -- I will return to this frame
66 CmmExpr -- The frame's return address; it must be
67 -- preceded by an info table that describes the
69 [CmmExpr] -- The frame's live variables, to go on the
70 -- stack with the first one at the young end
72 | CopyIn -- Move incoming parameters or results from conventional
73 -- locations to registers. Note [CopyIn invariant]
75 CmmFormals -- eventually [CmmKind] will be used only for foreign
76 -- calls and will migrate into 'Convention' (helping to
77 -- drain "the swamp"), leaving this as [LocalReg]
78 C_SRT -- Static things kept alive by this block
80 | CopyOut Convention CmmActuals
81 -- Move outgoing parameters or results from registers to
82 -- conventional locations. Every 'LastReturn',
83 -- 'LastJump', or 'LastCall' must be dominated by a
84 -- matching 'CopyOut' in the same basic block.
85 -- As above, '[CmmKind]' will migrate into the foreign calling
86 -- convention, leaving the actuals as '[CmmExpr]'.
89 = LastBranch BlockId -- Goto another block in the same procedure
91 | LastCondBranch { -- conditional branch
93 cml_true, cml_false :: BlockId
96 | LastReturn -- Return from a function; values in a previous CopyOut node
98 | LastJump CmmExpr -- Tail call to another procedure; args in a CopyOut node
100 | LastCall { -- A call (native or safe foreign); args in CopyOut node
101 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
102 cml_cont :: Maybe BlockId } -- BlockId of continuation, if call returns
104 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
105 -- The scrutinee is zero-based;
106 -- zero -> first block
107 -- one -> second block etc
108 -- Undefined outside range, and when there's a Nothing
111 = ConventionStandard CCallConv ValueDirection
113 -- Used for control transfers within a (pre-CPS) procedure All
114 -- jump sites known, never pushed on the stack (hence no SRT)
115 -- You can choose whatever calling convention you please
116 -- (provided you make sure all the call sites agree)!
117 -- This data type eventually to be extended to record the convention.
121 data ValueDirection = Arguments | Results
122 -- Arguments go with procedure definitions, jumps, and arguments to calls
123 -- Results go with returns and with results of calls.
127 Note [CopyIn invariant]
128 ~~~~~~~~~~~~~~~~~~~~~~~
129 One might wish for CopyIn to be a First node, but in practice, the
130 possibility raises all sorts of hairy issues with graph splicing,
131 rewriting, and so on. In the end, NR finds it better to make the
132 placement of CopyIn a dynamic invariant; it should normally be the first
133 Middle node in the basic block in which it occurs.
136 ----------------------------------------------------------------------
137 ----- Instance declarations for control flow
139 instance HavingSuccessors Last where
141 fold_succs = fold_cmm_succs
143 instance LastNode Last where
144 mkBranchNode id = LastBranch id
145 isBranchNode (LastBranch _) = True
146 isBranchNode _ = False
147 branchNodeTarget (LastBranch id) = id
148 branchNodeTarget _ = panic "asked for target of non-branch"
150 cmmSuccs :: Last -> [BlockId]
151 cmmSuccs (LastReturn {}) = []
152 cmmSuccs (LastJump {}) = []
153 cmmSuccs (LastBranch id) = [id]
154 cmmSuccs (LastCall _ (Just id)) = [id]
155 cmmSuccs (LastCall _ Nothing) = []
156 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
157 cmmSuccs (LastSwitch _ edges) = catMaybes edges
159 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
160 fold_cmm_succs _f (LastReturn {}) z = z
161 fold_cmm_succs _f (LastJump {}) z = z
162 fold_cmm_succs f (LastBranch id) z = f id z
163 fold_cmm_succs f (LastCall _ (Just id)) z = f id z
164 fold_cmm_succs _f (LastCall _ Nothing) z = z
165 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
166 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
168 ----------------------------------------------------------------------
169 ----- Instance declarations for register use
171 instance UserOfLocalRegs Middle where
172 foldRegsUsed f z m = middle m
173 where middle (MidComment {}) = z
174 middle (MidAssign _lhs expr) = fold f z expr
175 middle (MidStore addr rval) = fold f (fold f z addr) rval
176 middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
177 middle (MidAddToContext ra args) = fold f (fold f z ra) args
178 middle (CopyIn _ _formals _) = z
179 middle (CopyOut _ actuals) = fold f z actuals
180 fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
182 instance UserOfLocalRegs Last where
183 foldRegsUsed f z m = last m
184 where last (LastReturn) = z
185 last (LastJump e) = foldRegsUsed f z e
186 last (LastBranch _id) = z
187 last (LastCall tgt _) = foldRegsUsed f z tgt
188 last (LastCondBranch e _ _) = foldRegsUsed f z e
189 last (LastSwitch e _tbl) = foldRegsUsed f z e
192 ----------------------------------------------------------------------
193 ----- Instance declarations for prettyprinting (avoids recursive imports)
195 instance Outputable Middle where
198 instance Outputable Last where
201 instance Outputable Convention where
204 instance DF.DebugNodes Middle Last
209 pprMiddle :: Middle -> SDoc
210 pprMiddle stmt = pp_stmt <+> pp_debug
212 pp_stmt = case stmt of
214 CopyIn conv args _ ->
215 if null args then ptext (sLit "empty CopyIn")
216 else commafy (map pprKinded args) <+> equals <+>
217 ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...")
220 ptext (sLit "next, pass") <+> doubleQuotes(ppr conv) <+>
221 parens (commafy (map pprKinded args))
224 MidComment s -> text "//" <+> ftext s
227 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
230 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
232 rep = ppr ( cmmExprRep expr )
234 -- call "ccall" foo(x, y)[r1, r2];
236 MidUnsafeCall (CmmCallee fn cconv) results args ->
237 hcat [ if null results
239 else parens (commafy $ map ppr results) <>
241 ptext (sLit "call"), space,
242 doubleQuotes(ppr cconv), space,
243 ppr_target fn, parens ( commafy $ map ppr args ),
246 MidUnsafeCall (CmmPrim op) results args ->
247 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
249 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
251 MidAddToContext ra args ->
252 hcat [ ptext (sLit "return via ")
253 , ppr_target ra, parens (commafy $ map ppr args), semi ]
256 if not debugPpr then empty
259 CopyIn {} -> text "CopyIn"
260 CopyOut {} -> text "CopyOut"
261 MidComment {} -> text "MidComment"
262 MidAssign {} -> text "MidAssign"
263 MidStore {} -> text "MidStore"
264 MidUnsafeCall {} -> text "MidUnsafeCall"
265 MidAddToContext {} -> text "MidAddToContext"
268 ppr_target :: CmmExpr -> SDoc
269 ppr_target t@(CmmLit _) = ppr t
270 ppr_target fn' = parens (ppr fn')
273 pprKinded :: Outputable a => CmmKinded a -> SDoc
274 pprKinded (CmmKinded a NoHint) = ppr a
275 pprKinded (CmmKinded a PtrHint) = doubleQuotes (text "address") <+> ppr a
276 pprKinded (CmmKinded a SignedHint) = doubleQuotes (text "signed") <+> ppr a
277 pprKinded (CmmKinded a FloatHint) = doubleQuotes (text "float") <+> ppr a
279 pprLast :: Last -> SDoc
280 pprLast stmt = (case stmt of
281 LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
282 LastCondBranch expr t f -> genFullCondBranch expr t f
283 LastJump expr -> hcat [ ptext (sLit "jump"), space, pprFun expr
284 , ptext (sLit "(...)"), semi]
285 LastReturn -> hcat [ ptext (sLit "return"), space
286 , ptext (sLit "(...)"), semi]
287 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
288 LastCall tgt k -> genBareCall tgt k
290 if debugPpr then empty
293 LastBranch {} -> text "LastBranch"
294 LastCondBranch {} -> text "LastCondBranch"
295 LastJump {} -> text "LastJump"
296 LastReturn {} -> text "LastReturn"
297 LastSwitch {} -> text "LastSwitch"
298 LastCall {} -> text "LastCall"
300 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
302 hcat [ ptext (sLit "call"), space
303 , pprFun fn, ptext (sLit "(...)"), space
304 , case k of Nothing -> ptext (sLit "never returns")
305 Just k -> ptext (sLit "returns to") <+> ppr k
309 pprFun :: CmmExpr -> SDoc
310 pprFun f@(CmmLit _) = ppr f
311 pprFun f = parens (ppr f)
313 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
314 genFullCondBranch expr t f =
315 hsep [ ptext (sLit "if")
317 , ptext (sLit "goto")
319 , ptext (sLit "else goto")
323 pprConvention :: Convention -> SDoc
324 pprConvention (ConventionStandard c _) = ppr c
325 pprConvention (ConventionPrivate {} ) = text "<private-convention>"
327 commafy :: [SDoc] -> SDoc
328 commafy xs = hsep $ punctuate comma xs
331 ----------------------------------------------------------------
332 -- | The purpose of this function is to print a Cmm zipper graph "as if it were"
333 -- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
334 -- code are dodgy as well.
336 pprCmmGraphLikeCmm :: CmmGraph -> SDoc
337 pprCmmGraphLikeCmm g = vcat (swallow blocks)
338 where blocks = Z.postorder_dfs g
339 swallow :: [CmmBlock] -> [SDoc]
341 swallow (Z.Block id t : rest) = tail id [] Nothing t rest
342 tail id prev' out (Z.ZTail (CopyOut conv args) t) rest =
343 if isJust out then panic "multiple CopyOut nodes in one basic block"
345 tail id (prev') (Just (conv, args)) t rest
346 tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
347 tail id prev' out (Z.ZLast Z.LastExit) rest = exit id prev' out rest
348 tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
349 mid (CopyIn _ [] _) = text "// proc point (no parameters)"
350 mid m@(CopyIn {}) = ppr m <+> text "(proc point)"
353 | id == Z.lg_entry g, entry_has_no_pred =
354 vcat (text "<entry>" : reverse prev')
355 | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
356 last id prev' out l n =
357 let endblock stmt = block' id (stmt : prev') : swallow n in
362 | tgt == id', unique_pred id'
363 -> tail id prev' out t bs -- optimize out redundant labels
364 _ -> endblock (ppr $ CmmBranch tgt)
365 l@(LastCondBranch expr tid fid) ->
366 let ft id = text "// fall through to " <> ppr id in
369 | id' == fid, isNothing out ->
370 tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
371 | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
372 tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
373 _ -> endblock $ with_out out l
374 l@(LastJump {}) -> endblock $ with_out out l
375 l@(LastReturn {}) -> endblock $ with_out out l
376 l@(LastSwitch {}) -> endblock $ with_out out l
377 l@(LastCall _ Nothing) -> endblock $ with_out out l
378 l@(LastCall tgt (Just k))
379 | Z.Block id' (Z.ZTail (CopyIn _ ress srt) t) : bs <- n,
380 Just (conv, args) <- out,
382 let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
383 tgt' = CmmCallee tgt (cconv_of_conv conv)
384 ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
385 in if unique_pred k then
386 tail id (ppcall : prev') Nothing t bs
389 | Z.Block id' t : bs <- n, id' == k, unique_pred k,
390 Just (conv, args) <- out,
391 Just (ress, srt) <- findCopyIn t ->
392 let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
393 tgt' = CmmCallee tgt (cconv_of_conv conv)
395 ptext (sLit "// delayed CopyIn follows previous call")
396 in tail id (delayed : ppr call : prev') Nothing t bs
397 | otherwise -> endblock $ with_out out l
398 findCopyIn (Z.ZTail (CopyIn _ ress srt) _) = Just (ress, srt)
399 findCopyIn (Z.ZTail _ t) = findCopyIn t
400 findCopyIn (Z.ZLast _) = Nothing
401 exit id prev' out n = -- highly irregular (assertion violation?)
402 let endblock stmt = block' id (stmt : prev') : swallow n in
403 case out of Nothing -> endblock (text "// <exit>")
404 Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
407 entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
409 Just s -> isEmptyUniqSet s
413 in case Z.lookupBlockEnv preds id of
415 Just s -> if sizeUniqSet s == 1 then
416 Z.extendBlockSet single id
418 in Z.fold_blocks add Z.emptyBlockSet g
419 unique_pred id = Z.elemBlockSet id single_preds
420 cconv_of_conv (ConventionStandard conv _) = conv
421 cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
423 with_out :: Maybe (Convention, CmmActuals) -> Last -> SDoc
424 with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
425 with_out (Just (conv, args)) l = last l
426 where last (LastCall e k) =
427 hcat [ptext (sLit "... = foreign "),
428 doubleQuotes(ppr conv), space,
429 ppr_target e, parens ( commafy $ map ppr args ),
430 ptext (sLit " \"safe\""),
431 case k of Nothing -> ptext (sLit " never returns")
434 last (LastReturn) = ppr (CmmReturn args)
435 last (LastJump e) = ppr (CmmJump e args)
436 last l = ppr (CopyOut conv args) $$ ppr l
437 ppr_target (CmmLit lit) = ppr lit
438 ppr_target fn' = parens (ppr fn')
439 commafy xs = hsep $ punctuate comma xs