extra prettyprinting only when debugging
[ghc.git] / compiler / cmm / ZipCfgCmmRep.hs
1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
2
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.
7
8 module ZipCfgCmmRep
9 ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
10 )
11 where
12
13 #include "HsVersions.h"
14
15 import CmmExpr
16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
17 , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
18 , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
19 )
20 import PprCmm()
21
22 import CLabel
23 import ClosureInfo
24 import FastString
25 import ForeignCall
26 import MachOp
27 import qualified ZipDataflow as DF
28 import ZipCfg
29 import MkZipCfg
30
31 import Maybes
32 import Outputable
33 import Prelude hiding (zip, unzip, last)
34
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
40
41 data Middle
42 = MidNop
43 | MidComment FastString
44
45 | MidAssign CmmReg CmmExpr -- Assign to register
46
47 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
48 -- given by cmmExprRep of the rhs.
49
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
54
55 | CopyIn -- Move parameters or results from conventional locations to registers
56 -- Note [CopyIn invariant]
57 Convention
58 CmmFormals
59 C_SRT -- Static things kept alive by this block
60 | CopyOut Convention CmmFormals
61
62 data Last
63 = LastReturn CmmActuals -- Return from a function,
64 -- with these return values.
65
66 | LastJump CmmExpr CmmActuals
67 -- Tail call to another procedure
68
69 | LastBranch BlockId CmmFormalsWithoutKinds
70 -- To another block in the same procedure
71 -- The parameters are unused at present.
72
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
77
78 | LastCondBranch { -- conditional branch
79 cml_pred :: CmmExpr,
80 cml_true, cml_false :: BlockId
81 }
82
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
88
89 data Convention
90 = Argument CCallConv -- Used for function formal params
91 | Result CCallConv -- Used for function results
92
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)!
98 deriving Eq
99
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).
102
103 {-
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.
112 -}
113
114 instance HavingSuccessors Last where
115 succs = cmmSuccs
116 fold_succs = fold_cmm_succs
117
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"
124
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
133
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
142
143
144 ----------------------------------------------------------------
145 -- prettyprinting (avoids recursive imports)
146
147 instance Outputable Middle where
148 ppr s = pprMiddle s
149
150 instance Outputable Last where
151 ppr s = pprLast s
152
153 instance Outputable Convention where
154 ppr = pprConvention
155
156 instance DF.DebugNodes Middle Last
157
158 instance Outputable CmmGraph where
159 ppr = pprLgraph
160
161 debugPpr :: Bool
162 #ifdef DEBUG
163 debugPpr = True
164 #else
165 debubPpr = False
166 #endif
167
168 pprMiddle :: Middle -> SDoc
169 pprMiddle stmt = (case stmt of
170
171 MidNop -> semi
172
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("...")
177
178 CopyOut conv args ->
179 if null args then empty
180 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
181 parens (commafy (map pprHinted args))
182
183 -- // text
184 MidComment s -> text "//" <+> ftext s
185
186 -- reg = expr;
187 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
188
189 -- rep[lv] = expr;
190 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
191 where
192 rep = ppr ( cmmExprRep expr )
193
194 -- call "ccall" foo(x, y)[r1, r2];
195 -- ToDo ppr volatile
196 MidUnsafeCall (CmmCallee fn cconv) results args ->
197 hcat [ if null results
198 then empty
199 else parens (commafy $ map ppr results) <>
200 ptext SLIT(" = "),
201 ptext SLIT("call"), space,
202 doubleQuotes(ppr cconv), space,
203 target fn, parens ( commafy $ map ppr args ),
204 semi ]
205 where
206 target t@(CmmLit _) = ppr t
207 target fn' = parens (ppr fn')
208
209 MidUnsafeCall (CmmPrim op) results args ->
210 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
211 where
212 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
213 ) <>
214 if debugPpr then empty
215 else text " //" <+>
216 case stmt of
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"
224
225
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
231
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 )
239 , semi ]
240 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
241 LastCall tgt params k -> genCall tgt params k
242 ) <>
243 if debugPpr then empty
244 else text " //" <+>
245 case stmt of
246 LastBranch {} -> text "LastBranch"
247 LastCondBranch {} -> text "LastCondBranch"
248 LastJump {} -> text "LastJump"
249 LastReturn {} -> text "LastReturn"
250 LastSwitch {} -> text "LastSwitch"
251 LastCall {} -> text "LastCall"
252
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
260 , semi ]
261 where
262 target t@(CmmLit _) = ppr t
263 target fn' = parens (ppr fn')
264
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,
268 semi ]
269
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
274
275 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
276 genFullCondBranch expr t f =
277 hsep [ ptext SLIT("if")
278 , parens(ppr expr)
279 , ptext SLIT("goto")
280 , ppr t <> semi
281 , ptext SLIT("else goto")
282 , ppr f <> semi
283 ]
284
285 pprConvention :: Convention -> SDoc
286 pprConvention (Argument c) = ppr c
287 pprConvention (Result c) = ppr c
288 pprConvention Local = text "<local>"
289
290 commafy :: [SDoc] -> SDoc
291 commafy xs = hsep $ punctuate comma xs