Add unwind information to Cmm
[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 tscope -> ppr id <> colon <+>
187 (sdocWithDynFlags $ \dflags ->
188 ppWhen (gopt Opt_PprShowTicks dflags) (text "//" <+> ppr tscope))
189
190 -- // text
191 CmmComment s -> text "//" <+> ftext s
192
193 -- //tick bla<...>
194 CmmTick t -> if gopt Opt_PprShowTicks dflags
195 then ptext (sLit "//tick") <+> ppr t
196 else empty
197
198 -- unwind reg = expr;
199 CmmUnwind r e -> ptext (sLit "unwind ") <> ppr r <+> char '=' <+> ppr e
200
201 -- reg = expr;
202 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
203
204 -- rep[lv] = expr;
205 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
206 where
207 rep = sdocWithDynFlags $ \dflags ->
208 ppr ( cmmExprType dflags expr )
209
210 -- call "ccall" foo(x, y)[r1, r2];
211 -- ToDo ppr volatile
212 CmmUnsafeForeignCall target results args ->
213 hsep [ ppUnless (null results) $
214 parens (commafy $ map ppr results) <+> equals,
215 ptext $ sLit "call",
216 ppr target <> parens (commafy $ map ppr args) <> semi]
217
218 -- goto label;
219 CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
220
221 -- if (expr) goto t; else goto f;
222 CmmCondBranch expr t f ->
223 hsep [ ptext (sLit "if")
224 , parens(ppr expr)
225 , ptext (sLit "goto")
226 , ppr t <> semi
227 , ptext (sLit "else goto")
228 , ppr f <> semi
229 ]
230
231 CmmSwitch expr maybe_ids ->
232 hang (hcat [ ptext (sLit "switch [0 .. ")
233 , int (length maybe_ids - 1)
234 , ptext (sLit "] ")
235 , if isTrivialCmmExpr expr
236 then ppr expr
237 else parens (ppr expr)
238 , ptext (sLit " {")
239 ])
240 4 (vcat ( map caseify pairs )) $$ rbrace
241 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
242 snds a b = (snd a) == (snd b)
243 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
244 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
245 caseify as = let (is,ids) = unzip as
246 in hsep [ ptext (sLit "case")
247 , hcat (punctuate comma (map int is))
248 , ptext (sLit ": goto")
249 , ppr (head [ id | Just id <- ids]) <> semi ]
250
251 CmmCall tgt k regs out res updfr_off ->
252 hcat [ ptext (sLit "call"), space
253 , pprFun tgt, parens (interpp'SP regs), space
254 , returns <+>
255 ptext (sLit "args: ") <> ppr out <> comma <+>
256 ptext (sLit "res: ") <> ppr res <> comma <+>
257 ptext (sLit "upd: ") <> ppr updfr_off
258 , semi ]
259 where pprFun f@(CmmLit _) = ppr f
260 pprFun f = parens (ppr f)
261
262 returns
263 | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma
264 | otherwise = empty
265
266 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
267 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
268 [ ptext (sLit "foreign call"), space
269 , ppr t, ptext (sLit "(...)"), space
270 , ptext (sLit "returns to") <+> ppr s
271 <+> ptext (sLit "args:") <+> parens (ppr as)
272 <+> ptext (sLit "ress:") <+> parens (ppr rs)
273 , ptext (sLit "ret_args:") <+> ppr a
274 , ptext (sLit "ret_off:") <+> ppr u
275 , semi ]
276
277 pp_debug :: SDoc
278 pp_debug =
279 if not debugIsOn then empty
280 else case node of
281 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
282 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
283 CmmTick {} -> empty
284 CmmUnwind {} -> text " // CmmUnwind"
285 CmmAssign {} -> text " // CmmAssign"
286 CmmStore {} -> text " // CmmStore"
287 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
288 CmmBranch {} -> text " // CmmBranch"
289 CmmCondBranch {} -> text " // CmmCondBranch"
290 CmmSwitch {} -> text " // CmmSwitch"
291 CmmCall {} -> text " // CmmCall"
292 CmmForeignCall {} -> text " // CmmForeignCall"
293
294 commafy :: [SDoc] -> SDoc
295 commafy xs = hsep $ punctuate comma xs