Remove PlatformOutputable
[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 {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}
34 module PprCmm
35 ( module PprCmmDecl
36 , module PprCmmExpr
37 )
38 where
39
40 import BlockId ()
41 import CLabel
42 import Cmm
43 import CmmUtils
44 import FastString
45 import Outputable
46 import PprCmmDecl
47 import PprCmmExpr
48 import Util
49
50 import BasicTypes
51 import Platform
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 x = sdocWithPlatform $ \platform -> pprTopInfo platform x
64
65
66 instance Outputable (CmmNode e x) where
67 ppr x = sdocWithPlatform $ \platform -> pprNode platform x
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 x = sdocWithPlatform $ \platform -> pprForeignTarget platform x
77
78
79 instance Outputable (Block CmmNode C C) where
80 ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
81 instance Outputable (Block CmmNode C O) where
82 ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
83 instance Outputable (Block CmmNode O C) where
84 ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
85 instance Outputable (Block CmmNode O O) where
86 ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
87
88 instance Outputable (Graph CmmNode e x) where
89 ppr x = sdocWithPlatform $ \platform -> pprGraph platform x
90
91 instance Outputable CmmGraph where
92 ppr g = sdocWithPlatform $ \platform -> pprCmmGraph platform g
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 :: Platform -> CmmTopInfo -> SDoc
103 pprTopInfo _ (TopInfo {info_tbl=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 => Platform -> 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 :: Platform -> 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 :: Platform -> 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 pprConvention (Foreign c) = ppr c
151 pprConvention (Private {}) = text "<private-convention>"
152
153 pprForeignConvention :: ForeignConvention -> SDoc
154 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
155
156 pprForeignTarget :: Platform -> ForeignTarget -> SDoc
157 pprForeignTarget _ (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
158 where ppr_fc :: ForeignConvention -> SDoc
159 ppr_fc (ForeignConvention c args res) =
160 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
161 ppr_target :: CmmExpr -> SDoc
162 ppr_target t@(CmmLit _) = ppr t
163 ppr_target fn' = parens (ppr fn')
164
165 pprForeignTarget _ (PrimTarget op)
166 -- HACK: We're just using a ForeignLabel to get this printed, the label
167 -- might not really be foreign.
168 = ppr
169 (CmmLabel (mkForeignLabel
170 (mkFastString (show op))
171 Nothing ForeignLabelInThisPackage IsFunction))
172
173 pprNode :: Platform -> CmmNode e x -> SDoc
174 pprNode _ node = pp_node <+> pp_debug
175 where
176 pp_node :: SDoc
177 pp_node = case node of
178 -- label:
179 CmmEntry id -> ppr id <> colon
180
181 -- // text
182 CmmComment s -> text "//" <+> ftext s
183
184 -- reg = expr;
185 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
186
187 -- rep[lv] = expr;
188 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
189 where
190 rep = ppr ( cmmExprType expr )
191
192 -- call "ccall" foo(x, y)[r1, r2];
193 -- ToDo ppr volatile
194 CmmUnsafeForeignCall target results args ->
195 hsep [ ppUnless (null results) $
196 parens (commafy $ map ppr results) <+> equals,
197 ptext $ sLit "call",
198 ppr target <> parens (commafy $ map ppr args) <> semi]
199
200 -- goto label;
201 CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
202
203 -- if (expr) goto t; else goto f;
204 CmmCondBranch expr t f ->
205 hsep [ ptext (sLit "if")
206 , parens(ppr expr)
207 , ptext (sLit "goto")
208 , ppr t <> semi
209 , ptext (sLit "else goto")
210 , ppr f <> semi
211 ]
212
213 CmmSwitch expr maybe_ids ->
214 hang (hcat [ ptext (sLit "switch [0 .. ")
215 , int (length maybe_ids - 1)
216 , ptext (sLit "] ")
217 , if isTrivialCmmExpr expr
218 then ppr expr
219 else parens (ppr expr)
220 , ptext (sLit " {")
221 ])
222 4 (vcat ( map caseify pairs )) $$ rbrace
223 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
224 snds a b = (snd a) == (snd b)
225 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
226 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
227 caseify as = let (is,ids) = unzip as
228 in hsep [ ptext (sLit "case")
229 , hcat (punctuate comma (map int is))
230 , ptext (sLit ": goto")
231 , ppr (head [ id | Just id <- ids]) <> semi ]
232
233 CmmCall tgt k out res updfr_off ->
234 hcat [ ptext (sLit "call"), space
235 , pprFun tgt, ptext (sLit "(...)"), space
236 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
237 <+> parens (ppr res)
238 , ptext (sLit " with update frame") <+> ppr updfr_off
239 , semi ]
240 where pprFun f@(CmmLit _) = ppr f
241 pprFun f = parens (ppr f)
242
243 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
244 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
245 [ ptext (sLit "foreign call"), space
246 , ppr t, ptext (sLit "(...)"), space
247 , ptext (sLit "returns to") <+> ppr s
248 <+> ptext (sLit "args:") <+> parens (ppr as)
249 <+> ptext (sLit "ress:") <+> parens (ppr rs)
250 , ptext (sLit " with update frame") <+> ppr u
251 , semi ]
252
253 pp_debug :: SDoc
254 pp_debug =
255 if not debugIsOn then empty
256 else case node of
257 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
258 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
259 CmmAssign {} -> text " // CmmAssign"
260 CmmStore {} -> text " // CmmStore"
261 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
262 CmmBranch {} -> text " // CmmBranch"
263 CmmCondBranch {} -> text " // CmmCondBranch"
264 CmmSwitch {} -> text " // CmmSwitch"
265 CmmCall {} -> text " // CmmCall"
266 CmmForeignCall {} -> text " // CmmForeignCall"
267
268 commafy :: [SDoc] -> SDoc
269 commafy xs = hsep $ punctuate comma xs