Remove trailing whitespace
[ghc.git] / compiler / cmm / PprCmm.hs
1 {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3
4 ----------------------------------------------------------------------------
5 --
6 -- Pretty-printing of Cmm as (a superset of) C--
7 --
8 -- (c) The University of Glasgow 2004-2006
9 --
10 -----------------------------------------------------------------------------
11 --
12 -- This is where we walk over CmmNode emitting an external representation,
13 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
14 -- is the "External Core" for the Cmm layer.
15 --
16 -- As such, this should be a well-defined syntax: we want it to look nice.
17 -- Thus, we try wherever possible to use syntax defined in [1],
18 -- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
19 -- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
20 -- than C--'s bits8 .. bits64.
21 --
22 -- We try to ensure that all information available in the abstract
23 -- syntax is reproduced, or reproducible, in the concrete syntax.
24 -- Data that is not in printed out can be reconstructed according to
25 -- conventions used in the pretty printer. There are at least two such
26 -- cases:
27 -- 1) if a value has wordRep type, the type is not appended in the
28 -- output.
29 -- 2) MachOps that operate over wordRep type are printed in a
30 -- C-style, rather than as their internal MachRep name.
31 --
32 -- These conventions produce much more readable Cmm output.
33 --
34 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
35
36 module PprCmm
37 ( module PprCmmDecl
38 , module PprCmmExpr
39 )
40 where
41
42 import GhcPrelude hiding (succ)
43
44 import BlockId ()
45 import CLabel
46 import Cmm
47 import CmmUtils
48 import CmmSwitch
49 import DynFlags
50 import FastString
51 import Outputable
52 import PprCmmDecl
53 import PprCmmExpr
54 import Util
55 import PprCore ()
56
57 import BasicTypes
58 import Hoopl.Block
59 import Hoopl.Graph
60
61 -------------------------------------------------
62 -- Outputable instances
63
64 instance Outputable CmmStackInfo where
65 ppr = pprStackInfo
66
67 instance Outputable CmmTopInfo where
68 ppr = pprTopInfo
69
70
71 instance Outputable (CmmNode e x) where
72 ppr = pprNode
73
74 instance Outputable Convention where
75 ppr = pprConvention
76
77 instance Outputable ForeignConvention where
78 ppr = pprForeignConvention
79
80 instance Outputable ForeignTarget where
81 ppr = pprForeignTarget
82
83 instance Outputable CmmReturnInfo where
84 ppr = pprReturnInfo
85
86 instance Outputable (Block CmmNode C C) where
87 ppr = pprBlock
88 instance Outputable (Block CmmNode C O) where
89 ppr = pprBlock
90 instance Outputable (Block CmmNode O C) where
91 ppr = pprBlock
92 instance Outputable (Block CmmNode O O) where
93 ppr = pprBlock
94
95 instance Outputable (Graph CmmNode e x) where
96 ppr = pprGraph
97
98 instance Outputable CmmGraph where
99 ppr = pprCmmGraph
100
101 ----------------------------------------------------------
102 -- Outputting types Cmm contains
103
104 pprStackInfo :: CmmStackInfo -> SDoc
105 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
106 text "arg_space: " <> ppr arg_space <+>
107 text "updfr_space: " <> ppr updfr_space
108
109 pprTopInfo :: CmmTopInfo -> SDoc
110 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
111 vcat [text "info_tbls: " <> ppr info_tbl,
112 text "stack_info: " <> ppr stack_info]
113
114 ----------------------------------------------------------
115 -- Outputting blocks and graphs
116
117 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
118 => Block CmmNode e x -> IndexedCO e SDoc SDoc
119 pprBlock block
120 = foldBlockNodesB3 ( ($$) . ppr
121 , ($$) . (nest 4) . ppr
122 , ($$) . (nest 4) . ppr
123 )
124 block
125 empty
126
127 pprGraph :: Graph CmmNode e x -> SDoc
128 pprGraph GNil = empty
129 pprGraph (GUnit block) = ppr block
130 pprGraph (GMany entry body exit)
131 = text "{"
132 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
133 $$ text "}"
134 where pprMaybeO :: Outputable (Block CmmNode e x)
135 => MaybeO ex (Block CmmNode e x) -> SDoc
136 pprMaybeO NothingO = empty
137 pprMaybeO (JustO block) = ppr block
138
139 pprCmmGraph :: CmmGraph -> SDoc
140 pprCmmGraph g
141 = text "{" <> text "offset"
142 $$ nest 2 (vcat $ map ppr blocks)
143 $$ text "}"
144 where blocks = revPostorder g
145 -- revPostorder has the side-effect of discarding unreachable code,
146 -- so pretty-printed Cmm will omit any unreachable blocks. This can
147 -- sometimes be confusing.
148
149 ---------------------------------------------
150 -- Outputting CmmNode and types which it contains
151
152 pprConvention :: Convention -> SDoc
153 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
154 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
155 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
156 pprConvention Slow = text "<slow-convention>"
157 pprConvention GC = text "<gc-convention>"
158
159 pprForeignConvention :: ForeignConvention -> SDoc
160 pprForeignConvention (ForeignConvention c args res ret) =
161 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
162
163 pprReturnInfo :: CmmReturnInfo -> SDoc
164 pprReturnInfo CmmMayReturn = empty
165 pprReturnInfo CmmNeverReturns = text "never returns"
166
167 pprForeignTarget :: ForeignTarget -> SDoc
168 pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
169 where
170 ppr_target :: CmmExpr -> SDoc
171 ppr_target t@(CmmLit _) = ppr t
172 ppr_target fn' = parens (ppr fn')
173
174 pprForeignTarget (PrimTarget op)
175 -- HACK: We're just using a ForeignLabel to get this printed, the label
176 -- might not really be foreign.
177 = ppr
178 (CmmLabel (mkForeignLabel
179 (mkFastString (show op))
180 Nothing ForeignLabelInThisPackage IsFunction))
181
182 pprNode :: CmmNode e x -> SDoc
183 pprNode node = pp_node <+> pp_debug
184 where
185 pp_node :: SDoc
186 pp_node = sdocWithDynFlags $ \dflags -> case node of
187 -- label:
188 CmmEntry id tscope -> lbl <> colon <+>
189 (sdocWithDynFlags $ \dflags ->
190 ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
191 where
192 lbl = if gopt Opt_SuppressUniques dflags
193 then text "_lbl_"
194 else ppr id
195
196 -- // text
197 CmmComment s -> text "//" <+> ftext s
198
199 -- //tick bla<...>
200 CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
201 text "//tick" <+> ppr t
202
203 -- unwind reg = expr;
204 CmmUnwind regs ->
205 text "unwind "
206 <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
207
208 -- reg = expr;
209 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
210
211 -- rep[lv] = expr;
212 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
213 where
214 rep = sdocWithDynFlags $ \dflags ->
215 ppr ( cmmExprType dflags expr )
216
217 -- call "ccall" foo(x, y)[r1, r2];
218 -- ToDo ppr volatile
219 CmmUnsafeForeignCall target results args ->
220 hsep [ ppUnless (null results) $
221 parens (commafy $ map ppr results) <+> equals,
222 text "call",
223 ppr target <> parens (commafy $ map ppr args) <> semi]
224
225 -- goto label;
226 CmmBranch ident -> text "goto" <+> ppr ident <> semi
227
228 -- if (expr) goto t; else goto f;
229 CmmCondBranch expr t f l ->
230 hsep [ text "if"
231 , parens(ppr expr)
232 , case l of
233 Nothing -> empty
234 Just b -> parens (text "likely:" <+> ppr b)
235 , text "goto"
236 , ppr t <> semi
237 , text "else goto"
238 , ppr f <> semi
239 ]
240
241 CmmSwitch expr ids ->
242 hang (hsep [ text "switch"
243 , range
244 , if isTrivialCmmExpr expr
245 then ppr expr
246 else parens (ppr expr)
247 , text "{"
248 ])
249 4 (vcat (map ppCase cases) $$ def) $$ rbrace
250 where
251 (cases, mbdef) = switchTargetsFallThrough ids
252 ppCase (is,l) = hsep
253 [ text "case"
254 , commafy $ map integer is
255 , text ": goto"
256 , ppr l <> semi
257 ]
258 def | Just l <- mbdef = hsep
259 [ text "default:"
260 , braces (text "goto" <+> ppr l <> semi)
261 ]
262 | otherwise = empty
263
264 range = brackets $ hsep [integer lo, text "..", integer hi]
265 where (lo,hi) = switchTargetsRange ids
266
267 CmmCall tgt k regs out res updfr_off ->
268 hcat [ text "call", space
269 , pprFun tgt, parens (interpp'SP regs), space
270 , returns <+>
271 text "args: " <> ppr out <> comma <+>
272 text "res: " <> ppr res <> comma <+>
273 text "upd: " <> ppr updfr_off
274 , semi ]
275 where pprFun f@(CmmLit _) = ppr f
276 pprFun f = parens (ppr f)
277
278 returns
279 | Just r <- k = text "returns to" <+> ppr r <> comma
280 | otherwise = empty
281
282 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
283 hcat $ if i then [text "interruptible", space] else [] ++
284 [ text "foreign call", space
285 , ppr t, text "(...)", space
286 , text "returns to" <+> ppr s
287 <+> text "args:" <+> parens (ppr as)
288 <+> text "ress:" <+> parens (ppr rs)
289 , text "ret_args:" <+> ppr a
290 , text "ret_off:" <+> ppr u
291 , semi ]
292
293 pp_debug :: SDoc
294 pp_debug =
295 if not debugIsOn then empty
296 else case node of
297 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
298 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
299 CmmTick {} -> empty
300 CmmUnwind {} -> text " // CmmUnwind"
301 CmmAssign {} -> text " // CmmAssign"
302 CmmStore {} -> text " // CmmStore"
303 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
304 CmmBranch {} -> text " // CmmBranch"
305 CmmCondBranch {} -> text " // CmmCondBranch"
306 CmmSwitch {} -> text " // CmmSwitch"
307 CmmCall {} -> text " // CmmCall"
308 CmmForeignCall {} -> text " // CmmForeignCall"
309
310 commafy :: [SDoc] -> SDoc
311 commafy xs = hsep $ punctuate comma xs