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