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
33 import Prelude hiding (zip, unzip, last)
35 type CmmGraph = LGraph Middle Last
36 type CmmAGraph = AGraph Middle Last
37 type CmmBlock = Block Middle Last
38 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
39 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
43 | MidComment FastString
45 | MidAssign CmmReg CmmExpr -- Assign to register
47 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
48 -- given by cmmExprRep of the rhs.
50 | MidUnsafeCall -- An "unsafe" foreign call;
51 CmmCallTarget -- just a fat machine instructoin
52 CmmFormals -- zero or more results
53 CmmActuals -- zero or more arguments
55 | CopyIn -- Move parameters or results from conventional locations to registers
56 -- Note [CopyIn invariant]
59 C_SRT -- Static things kept alive by this block
60 | CopyOut Convention CmmFormals
63 = LastReturn CmmActuals -- Return from a function,
64 -- with these return values.
66 | LastJump CmmExpr CmmActuals
67 -- Tail call to another procedure
69 | LastBranch BlockId CmmFormalsWithoutKinds
70 -- To another block in the same procedure
71 -- The parameters are unused at present.
73 | LastCall { -- A call (native or safe foreign)
74 cml_target :: CmmCallTarget,
75 cml_actual :: CmmActuals, -- Zero or more arguments
76 cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
78 | LastCondBranch { -- conditional branch
80 cml_true, cml_false :: BlockId
83 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
84 -- The scrutinee is zero-based;
85 -- zero -> first block
86 -- one -> second block etc
87 -- Undefined outside range, and when there's a Nothing
90 = Argument CCallConv -- Used for function formal params
91 | Result CCallConv -- Used for function results
93 | Local -- Used for control transfers within a (pre-CPS) procedure
94 -- All jump sites known, never pushed on the stack (hence no SRT)
95 -- You can choose whatever calling convention
96 -- you please (provided you make sure
97 -- all the call sites agree)!
100 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
101 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
104 Note [CopyIn invariant]
105 ~~~~~~~~~~~~~~~~~~~~~~~
106 In principle, CopyIn ought to be a First node, but in practice, the
107 possibility raises all sorts of hairy issues with graph splicing,
108 rewriting, and so on. In the end, NR finds it better to make the
109 placement of CopyIn a dynamic invariant. This change will complicate
110 the dataflow fact for the proc-point calculation, but it should make
111 things easier in many other respects.
114 instance HavingSuccessors Last where
116 fold_succs = fold_cmm_succs
118 instance LastNode Last where
119 mkBranchNode id = LastBranch id []
120 isBranchNode (LastBranch _ []) = True
121 isBranchNode _ = False
122 branchNodeTarget (LastBranch id []) = id
123 branchNodeTarget _ = panic "asked for target of non-branch"
125 cmmSuccs :: Last -> [BlockId]
126 cmmSuccs (LastReturn {}) = []
127 cmmSuccs (LastJump {}) = []
128 cmmSuccs (LastBranch id _) = [id]
129 cmmSuccs (LastCall _ _ (Just id)) = [id]
130 cmmSuccs (LastCall _ _ Nothing) = []
131 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
132 cmmSuccs (LastSwitch _ edges) = catMaybes edges
134 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
135 fold_cmm_succs _f (LastReturn {}) z = z
136 fold_cmm_succs _f (LastJump {}) z = z
137 fold_cmm_succs f (LastBranch id _) z = f id z
138 fold_cmm_succs f (LastCall _ _ (Just id)) z = f id z
139 fold_cmm_succs _f (LastCall _ _ Nothing) z = z
140 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
141 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
144 ----------------------------------------------------------------
145 -- prettyprinting (avoids recursive imports)
147 instance Outputable Middle where
150 instance Outputable Last where
153 instance Outputable Convention where
156 instance DF.DebugNodes Middle Last
158 instance Outputable CmmGraph where
168 pprMiddle :: Middle -> SDoc
169 pprMiddle stmt = (case stmt of
173 CopyIn conv args _ ->
174 if null args then ptext SLIT("empty CopyIn")
175 else commafy (map pprHinted args) <+> equals <+>
176 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
179 if null args then empty
180 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
181 parens (commafy (map pprHinted args))
184 MidComment s -> text "//" <+> ftext s
187 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
190 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
192 rep = ppr ( cmmExprRep expr )
194 -- call "ccall" foo(x, y)[r1, r2];
196 MidUnsafeCall (CmmCallee fn cconv) results args ->
197 hcat [ if null results
199 else parens (commafy $ map ppr results) <>
201 ptext SLIT("call"), space,
202 doubleQuotes(ppr cconv), space,
203 target fn, parens ( commafy $ map ppr args ),
206 target t@(CmmLit _) = ppr t
207 target fn' = parens (ppr fn')
209 MidUnsafeCall (CmmPrim op) results args ->
210 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
212 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
214 if debugPpr then empty
217 MidNop {} -> text "MidNop"
218 CopyIn {} -> text "CopyIn"
219 CopyOut {} -> text "CopyOut"
220 MidComment {} -> text "MidComment"
221 MidAssign {} -> text "MidAssign"
222 MidStore {} -> text "MidStore"
223 MidUnsafeCall {} -> text "MidUnsafeCall"
226 pprHinted :: Outputable a => (a, MachHint) -> SDoc
227 pprHinted (a, NoHint) = ppr a
228 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
229 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
230 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
232 pprLast :: Last -> SDoc
233 pprLast stmt = (case stmt of
234 LastBranch ident args -> genBranchWithArgs ident args
235 LastCondBranch expr t f -> genFullCondBranch expr t f
236 LastJump expr params -> ppr $ CmmJump expr params
237 LastReturn results -> hcat [ ptext SLIT("return"), space
238 , parens ( commafy $ map pprHinted results )
240 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
241 LastCall tgt params k -> genCall tgt params k
243 if debugPpr then empty
246 LastBranch {} -> text "LastBranch"
247 LastCondBranch {} -> text "LastCondBranch"
248 LastJump {} -> text "LastJump"
249 LastReturn {} -> text "LastReturn"
250 LastSwitch {} -> text "LastSwitch"
251 LastCall {} -> text "LastCall"
253 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
254 genCall (CmmCallee fn cconv) args k =
255 hcat [ ptext SLIT("foreign"), space
256 , doubleQuotes(ppr cconv), space
257 , target fn, parens ( commafy $ map pprHinted args ), space
258 , case k of Nothing -> ptext SLIT("never returns")
259 Just k -> ptext SLIT("returns to") <+> ppr k
262 target t@(CmmLit _) = ppr t
263 target fn' = parens (ppr fn')
265 genCall (CmmPrim op) args k =
266 hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ),
267 ptext SLIT("returns to"), space, ppr k,
270 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
271 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
272 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
273 parens (commafy (map ppr args)) <> semi
275 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
276 genFullCondBranch expr t f =
277 hsep [ ptext SLIT("if")
281 , ptext SLIT("else goto")
285 pprConvention :: Convention -> SDoc
286 pprConvention (Argument c) = ppr c
287 pprConvention (Result c) = ppr c
288 pprConvention Local = text "<local>"
290 commafy :: [SDoc] -> SDoc
291 commafy xs = hsep $ punctuate comma xs