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