Fix #11407.
[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.cminusminus.org/. We differ
19 -- 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 BlockId ()
43 import CLabel
44 import Cmm
45 import CmmUtils
46 import CmmSwitch
47 import DynFlags
48 import FastString
49 import Outputable
50 import PprCmmDecl
51 import PprCmmExpr
52 import Util
53 import PprCore ()
54
55 import BasicTypes
56 import Compiler.Hoopl
57 import Data.List
58 import Prelude hiding (succ)
59
60 -------------------------------------------------
61 -- Outputable instances
62
63 instance Outputable CmmStackInfo where
64 ppr = pprStackInfo
65
66 instance Outputable CmmTopInfo where
67 ppr = pprTopInfo
68
69
70 instance Outputable (CmmNode e x) where
71 ppr = pprNode
72
73 instance Outputable Convention where
74 ppr = pprConvention
75
76 instance Outputable ForeignConvention where
77 ppr = pprForeignConvention
78
79 instance Outputable ForeignTarget where
80 ppr = pprForeignTarget
81
82 instance Outputable CmmReturnInfo where
83 ppr = pprReturnInfo
84
85 instance Outputable (Block CmmNode C C) where
86 ppr = pprBlock
87 instance Outputable (Block CmmNode C O) where
88 ppr = pprBlock
89 instance Outputable (Block CmmNode O C) where
90 ppr = pprBlock
91 instance Outputable (Block CmmNode O O) where
92 ppr = pprBlock
93
94 instance Outputable (Graph CmmNode e x) where
95 ppr = pprGraph
96
97 instance Outputable CmmGraph where
98 ppr = pprCmmGraph
99
100 ----------------------------------------------------------
101 -- Outputting types Cmm contains
102
103 pprStackInfo :: CmmStackInfo -> SDoc
104 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
105 text "arg_space: " <> ppr arg_space <+>
106 text "updfr_space: " <> ppr updfr_space
107
108 pprTopInfo :: CmmTopInfo -> SDoc
109 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
110 vcat [text "info_tbl: " <> ppr info_tbl,
111 text "stack_info: " <> ppr stack_info]
112
113 ----------------------------------------------------------
114 -- Outputting blocks and graphs
115
116 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
117 => Block CmmNode e x -> IndexedCO e SDoc SDoc
118 pprBlock block
119 = foldBlockNodesB3 ( ($$) . ppr
120 , ($$) . (nest 4) . ppr
121 , ($$) . (nest 4) . ppr
122 )
123 block
124 empty
125
126 pprGraph :: Graph CmmNode e x -> SDoc
127 pprGraph GNil = empty
128 pprGraph (GUnit block) = ppr block
129 pprGraph (GMany entry body exit)
130 = text "{"
131 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
132 $$ text "}"
133 where pprMaybeO :: Outputable (Block CmmNode e x)
134 => MaybeO ex (Block CmmNode e x) -> SDoc
135 pprMaybeO NothingO = empty
136 pprMaybeO (JustO block) = ppr block
137
138 pprCmmGraph :: CmmGraph -> SDoc
139 pprCmmGraph g
140 = text "{" <> text "offset"
141 $$ nest 2 (vcat $ map ppr blocks)
142 $$ text "}"
143 where blocks = postorderDfs g
144 -- postorderDfs has the side-effect of discarding unreachable code,
145 -- so pretty-printed Cmm will omit any unreachable blocks. This can
146 -- sometimes be confusing.
147
148 ---------------------------------------------
149 -- Outputting CmmNode and types which it contains
150
151 pprConvention :: Convention -> SDoc
152 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
153 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
154 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
155 pprConvention Slow = text "<slow-convention>"
156 pprConvention GC = text "<gc-convention>"
157
158 pprForeignConvention :: ForeignConvention -> SDoc
159 pprForeignConvention (ForeignConvention c args res ret) =
160 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
161
162 pprReturnInfo :: CmmReturnInfo -> SDoc
163 pprReturnInfo CmmMayReturn = empty
164 pprReturnInfo CmmNeverReturns = text "never returns"
165
166 pprForeignTarget :: ForeignTarget -> SDoc
167 pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
168 where
169 ppr_target :: CmmExpr -> SDoc
170 ppr_target t@(CmmLit _) = ppr t
171 ppr_target fn' = parens (ppr fn')
172
173 pprForeignTarget (PrimTarget op)
174 -- HACK: We're just using a ForeignLabel to get this printed, the label
175 -- might not really be foreign.
176 = ppr
177 (CmmLabel (mkForeignLabel
178 (mkFastString (show op))
179 Nothing ForeignLabelInThisPackage IsFunction))
180
181 pprNode :: CmmNode e x -> SDoc
182 pprNode node = pp_node <+> pp_debug
183 where
184 pp_node :: SDoc
185 pp_node = sdocWithDynFlags $ \dflags -> case node of
186 -- label:
187 CmmEntry id tscope -> ppr id <> colon <+>
188 (sdocWithDynFlags $ \dflags ->
189 ppWhen (gopt Opt_PprShowTicks dflags) (text "//" <+> ppr tscope))
190
191 -- // text
192 CmmComment s -> text "//" <+> ftext s
193
194 -- //tick bla<...>
195 CmmTick t -> if gopt Opt_PprShowTicks dflags
196 then text "//tick" <+> ppr t
197 else empty
198
199 -- unwind reg = expr;
200 CmmUnwind r e -> text "unwind " <> ppr r <+> char '=' <+> ppr e
201
202 -- reg = expr;
203 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
204
205 -- rep[lv] = expr;
206 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
207 where
208 rep = sdocWithDynFlags $ \dflags ->
209 ppr ( cmmExprType dflags expr )
210
211 -- call "ccall" foo(x, y)[r1, r2];
212 -- ToDo ppr volatile
213 CmmUnsafeForeignCall target results args ->
214 hsep [ ppUnless (null results) $
215 parens (commafy $ map ppr results) <+> equals,
216 text "call",
217 ppr target <> parens (commafy $ map ppr args) <> semi]
218
219 -- goto label;
220 CmmBranch ident -> text "goto" <+> ppr ident <> semi
221
222 -- if (expr) goto t; else goto f;
223 CmmCondBranch expr t f l ->
224 hsep [ text "if"
225 , parens(ppr expr)
226 , case l of
227 Nothing -> empty
228 Just b -> parens (text "likely:" <+> ppr b)
229 , text "goto"
230 , ppr t <> semi
231 , text "else goto"
232 , ppr f <> semi
233 ]
234
235 CmmSwitch expr ids ->
236 hang (hsep [ text "switch"
237 , range
238 , if isTrivialCmmExpr expr
239 then ppr expr
240 else parens (ppr expr)
241 , text "{"
242 ])
243 4 (vcat (map ppCase cases) $$ def) $$ rbrace
244 where
245 (cases, mbdef) = switchTargetsFallThrough ids
246 ppCase (is,l) = hsep
247 [ text "case"
248 , commafy $ map integer is
249 , text ": goto"
250 , ppr l <> semi
251 ]
252 def | Just l <- mbdef = hsep
253 [ text "default: goto"
254 , ppr l <> semi
255 ]
256 | otherwise = empty
257
258 range = brackets $ hsep [integer lo, text "..", integer hi]
259 where (lo,hi) = switchTargetsRange ids
260
261 CmmCall tgt k regs out res updfr_off ->
262 hcat [ text "call", space
263 , pprFun tgt, parens (interpp'SP regs), space
264 , returns <+>
265 text "args: " <> ppr out <> comma <+>
266 text "res: " <> ppr res <> comma <+>
267 text "upd: " <> ppr updfr_off
268 , semi ]
269 where pprFun f@(CmmLit _) = ppr f
270 pprFun f = parens (ppr f)
271
272 returns
273 | Just r <- k = text "returns to" <+> ppr r <> comma
274 | otherwise = empty
275
276 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
277 hcat $ if i then [text "interruptible", space] else [] ++
278 [ text "foreign call", space
279 , ppr t, text "(...)", space
280 , text "returns to" <+> ppr s
281 <+> text "args:" <+> parens (ppr as)
282 <+> text "ress:" <+> parens (ppr rs)
283 , text "ret_args:" <+> ppr a
284 , text "ret_off:" <+> ppr u
285 , semi ]
286
287 pp_debug :: SDoc
288 pp_debug =
289 if not debugIsOn then empty
290 else case node of
291 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
292 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
293 CmmTick {} -> empty
294 CmmUnwind {} -> text " // CmmUnwind"
295 CmmAssign {} -> text " // CmmAssign"
296 CmmStore {} -> text " // CmmStore"
297 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
298 CmmBranch {} -> text " // CmmBranch"
299 CmmCondBranch {} -> text " // CmmCondBranch"
300 CmmSwitch {} -> text " // CmmSwitch"
301 CmmCall {} -> text " // CmmCall"
302 CmmForeignCall {} -> text " // CmmForeignCall"
303
304 commafy :: [SDoc] -> SDoc
305 commafy xs = hsep $ punctuate comma xs