1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
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(..)
13 #include "HsVersions.h"
16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
17 , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
18 , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
27 import qualified ZipDataflow as DF
32 import Outputable hiding (empty)
33 import qualified Outputable as PP
34 import Prelude hiding (zip, unzip, last)
36 type CmmGraph = LGraph Middle Last
37 type CmmAGraph = AGraph Middle Last
38 type CmmBlock = Block Middle Last
39 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
40 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
44 | MidComment FastString
46 | MidAssign CmmReg CmmExpr -- Assign to register
48 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
49 -- given by cmmExprRep of the rhs.
51 | MidUnsafeCall -- An "unsafe" foreign call;
52 CmmCallTarget -- just a fat machine instructoin
53 CmmFormals -- zero or more results
54 CmmActuals -- zero or more arguments
56 | CopyIn -- Move parameters or results from conventional locations to registers
57 -- Note [CopyIn invariant]
60 C_SRT -- Static things kept alive by this block
61 | CopyOut Convention CmmFormals
64 = LastReturn CmmActuals -- Return from a function,
65 -- with these return values.
67 | LastJump CmmExpr CmmActuals
68 -- Tail call to another procedure
70 | LastBranch BlockId CmmFormalsWithoutKinds
71 -- To another block in the same procedure
72 -- The parameters are unused at present.
74 | LastCall { -- A call (native or safe foreign)
75 cml_target :: CmmCallTarget,
76 cml_actual :: CmmActuals, -- Zero or more arguments
77 cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
79 | LastCondBranch { -- conditional branch
81 cml_true, cml_false :: BlockId
84 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
85 -- The scrutinee is zero-based;
86 -- zero -> first block
87 -- one -> second block etc
88 -- Undefined outside range, and when there's a Nothing
91 = Argument CCallConv -- Used for function formal params
92 | Result CCallConv -- Used for function results
94 | Local -- Used for control transfers within a (pre-CPS) procedure
95 -- All jump sites known, never pushed on the stack (hence no SRT)
96 -- You can choose whatever calling convention
97 -- you please (provided you make sure
98 -- all the call sites agree)!
101 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
102 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
105 Note [CopyIn invariant]
106 ~~~~~~~~~~~~~~~~~~~~~~~
107 In principle, CopyIn ought to be a First node, but in practice, the
108 possibility raises all sorts of hairy issues with graph splicing,
109 rewriting, and so on. In the end, NR finds it better to make the
110 placement of CopyIn a dynamic invariant. This change will complicate
111 the dataflow fact for the proc-point calculation, but it should make
112 things easier in many other respects.
115 instance HavingSuccessors Last where
117 fold_succs = fold_cmm_succs
119 instance LastNode Last where
120 mkBranchNode id = LastBranch id []
121 isBranchNode (LastBranch _ []) = True
122 isBranchNode _ = False
123 branchNodeTarget (LastBranch id []) = id
124 branchNodeTarget _ = panic "asked for target of non-branch"
126 cmmSuccs :: Last -> [BlockId]
127 cmmSuccs (LastReturn {}) = []
128 cmmSuccs (LastJump {}) = []
129 cmmSuccs (LastBranch id _) = [id]
130 cmmSuccs (LastCall _ _ (Just id)) = [id]
131 cmmSuccs (LastCall _ _ Nothing) = []
132 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
133 cmmSuccs (LastSwitch _ edges) = catMaybes edges
135 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
136 fold_cmm_succs _f (LastReturn {}) z = z
137 fold_cmm_succs _f (LastJump {}) z = z
138 fold_cmm_succs f (LastBranch id _) z = f id z
139 fold_cmm_succs f (LastCall _ _ (Just id)) z = f id z
140 fold_cmm_succs _f (LastCall _ _ Nothing) z = z
141 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
142 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
145 ----------------------------------------------------------------
146 -- prettyprinting (avoids recursive imports)
148 instance Outputable Middle where
151 instance Outputable Last where
154 instance Outputable Convention where
157 instance DF.DebugNodes Middle Last
159 instance Outputable CmmGraph where
162 pprMiddle :: Middle -> SDoc
163 pprMiddle stmt = (case stmt of
167 CopyIn conv args _ ->
168 if null args then ptext SLIT("empty CopyIn")
169 else commafy (map pprHinted args) <+> equals <+>
170 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
173 if null args then PP.empty
174 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
175 parens (commafy (map pprHinted args))
178 MidComment s -> text "//" <+> ftext s
181 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
184 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
186 rep = ppr ( cmmExprRep expr )
188 -- call "ccall" foo(x, y)[r1, r2];
190 MidUnsafeCall (CmmCallee fn cconv) results args ->
191 hcat [ if null results
193 else parens (commafy $ map ppr results) <>
195 ptext SLIT("call"), space,
196 doubleQuotes(ppr cconv), space,
197 target fn, parens ( commafy $ map ppr args ),
200 target t@(CmmLit _) = ppr t
201 target fn' = parens (ppr fn')
203 MidUnsafeCall (CmmPrim op) results args ->
204 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
206 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
209 MidNop {} -> text "MidNop"
210 CopyIn {} -> text "CopyIn"
211 CopyOut {} -> text "CopyOut"
212 MidComment {} -> text "MidComment"
213 MidAssign {} -> text "MidAssign"
214 MidStore {} -> text "MidStore"
215 MidUnsafeCall {} -> text "MidUnsafeCall"
218 pprHinted :: Outputable a => (a, MachHint) -> SDoc
219 pprHinted (a, NoHint) = ppr a
220 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
221 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
222 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
224 pprLast :: Last -> SDoc
225 pprLast stmt = (case stmt of
226 LastBranch ident args -> genBranchWithArgs ident args
227 LastCondBranch expr t f -> genFullCondBranch expr t f
228 LastJump expr params -> ppr $ CmmJump expr params
229 LastReturn results -> hcat [ ptext SLIT("return"), space
230 , parens ( commafy $ map pprHinted results )
232 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
233 LastCall tgt params k -> genCall tgt params k
236 LastBranch {} -> text "LastBranch"
237 LastCondBranch {} -> text "LastCondBranch"
238 LastJump {} -> text "LastJump"
239 LastReturn {} -> text "LastReturn"
240 LastSwitch {} -> text "LastSwitch"
241 LastCall {} -> text "LastCall"
244 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
245 genCall (CmmCallee fn cconv) args k =
246 hcat [ ptext SLIT("foreign"), space
247 , doubleQuotes(ppr cconv), space
248 , target fn, parens ( commafy $ map pprHinted args ), space
249 , case k of Nothing -> ptext SLIT("never returns")
250 Just k -> ptext SLIT("returns to") <+> ppr k
253 target t@(CmmLit _) = ppr t
254 target fn' = parens (ppr fn')
256 genCall (CmmPrim op) args k =
257 hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ),
258 ptext SLIT("returns to"), space, ppr k,
261 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
262 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
263 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
264 parens (commafy (map ppr args)) <> semi
266 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
267 genFullCondBranch expr t f =
268 hsep [ ptext SLIT("if")
272 , ptext SLIT("else goto")
276 pprConvention :: Convention -> SDoc
277 pprConvention (Argument c) = ppr c
278 pprConvention (Result c) = ppr c
279 pprConvention Local = text "<local>"
281 commafy :: [SDoc] -> SDoc
282 commafy xs = hsep $ punctuate comma xs