Remove more redundant Platform arguments
[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 Compiler.Hoopl
52 import Data.List
53 import Prelude hiding (succ)
54
55 -------------------------------------------------
56 -- Outputable instances
57
58 instance Outputable CmmStackInfo where
59 ppr = pprStackInfo
60
61 instance Outputable CmmTopInfo where
62 ppr = pprTopInfo
63
64
65 instance Outputable (CmmNode e x) where
66 ppr = pprNode
67
68 instance Outputable Convention where
69 ppr = pprConvention
70
71 instance Outputable ForeignConvention where
72 ppr = pprForeignConvention
73
74 instance Outputable ForeignTarget where
75 ppr = pprForeignTarget
76
77
78 instance Outputable (Block CmmNode C C) where
79 ppr = pprBlock
80 instance Outputable (Block CmmNode C O) where
81 ppr = pprBlock
82 instance Outputable (Block CmmNode O C) where
83 ppr = pprBlock
84 instance Outputable (Block CmmNode O O) where
85 ppr = pprBlock
86
87 instance Outputable (Graph CmmNode e x) where
88 ppr = pprGraph
89
90 instance Outputable CmmGraph where
91 ppr = pprCmmGraph
92
93 ----------------------------------------------------------
94 -- Outputting types Cmm contains
95
96 pprStackInfo :: CmmStackInfo -> SDoc
97 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
98 ptext (sLit "arg_space: ") <> ppr arg_space <+>
99 ptext (sLit "updfr_space: ") <> ppr updfr_space
100
101 pprTopInfo :: CmmTopInfo -> SDoc
102 pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
103 vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
104 ptext (sLit "stack_info: ") <> ppr stack_info]
105
106 ----------------------------------------------------------
107 -- Outputting blocks and graphs
108
109 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
110 => Block CmmNode e x -> IndexedCO e SDoc SDoc
111 pprBlock block
112 = foldBlockNodesB3 ( ($$) . ppr
113 , ($$) . (nest 4) . ppr
114 , ($$) . (nest 4) . ppr
115 )
116 block
117 empty
118
119 pprGraph :: Graph CmmNode e x -> SDoc
120 pprGraph GNil = empty
121 pprGraph (GUnit block) = ppr block
122 pprGraph (GMany entry body exit)
123 = text "{"
124 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
125 $$ text "}"
126 where pprMaybeO :: Outputable (Block CmmNode e x)
127 => MaybeO ex (Block CmmNode e x) -> SDoc
128 pprMaybeO NothingO = empty
129 pprMaybeO (JustO block) = ppr block
130
131 pprCmmGraph :: CmmGraph -> SDoc
132 pprCmmGraph g
133 = text "{" <> text "offset"
134 $$ nest 2 (vcat $ map ppr blocks)
135 $$ text "}"
136 where blocks = postorderDfs g
137
138 ---------------------------------------------
139 -- Outputting CmmNode and types which it contains
140
141 pprConvention :: Convention -> SDoc
142 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
143 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
144 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
145 pprConvention Slow = text "<slow-convention>"
146 pprConvention GC = text "<gc-convention>"
147 pprConvention PrimOpCall = text "<primop-call-convention>"
148 pprConvention PrimOpReturn = text "<primop-ret-convention>"
149 pprConvention (Foreign c) = ppr c
150 pprConvention (Private {}) = text "<private-convention>"
151
152 pprForeignConvention :: ForeignConvention -> SDoc
153 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
154
155 pprForeignTarget :: ForeignTarget -> SDoc
156 pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
157 where ppr_fc :: ForeignConvention -> SDoc
158 ppr_fc (ForeignConvention c args res) =
159 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
160 ppr_target :: CmmExpr -> SDoc
161 ppr_target t@(CmmLit _) = ppr t
162 ppr_target fn' = parens (ppr fn')
163
164 pprForeignTarget (PrimTarget op)
165 -- HACK: We're just using a ForeignLabel to get this printed, the label
166 -- might not really be foreign.
167 = ppr
168 (CmmLabel (mkForeignLabel
169 (mkFastString (show op))
170 Nothing ForeignLabelInThisPackage IsFunction))
171
172 pprNode :: CmmNode e x -> SDoc
173 pprNode node = pp_node <+> pp_debug
174 where
175 pp_node :: SDoc
176 pp_node = case node of
177 -- label:
178 CmmEntry id -> ppr id <> colon
179
180 -- // text
181 CmmComment s -> text "//" <+> ftext s
182
183 -- reg = expr;
184 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
185
186 -- rep[lv] = expr;
187 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
188 where
189 rep = ppr ( cmmExprType 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 out res updfr_off ->
233 hcat [ ptext (sLit "call"), space
234 , pprFun tgt, ptext (sLit "(...)"), space
235 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
236 <+> parens (ppr res)
237 , ptext (sLit " with update frame") <+> ppr updfr_off
238 , semi ]
239 where pprFun f@(CmmLit _) = ppr f
240 pprFun f = parens (ppr f)
241
242 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
243 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
244 [ ptext (sLit "foreign call"), space
245 , ppr t, ptext (sLit "(...)"), space
246 , ptext (sLit "returns to") <+> ppr s
247 <+> ptext (sLit "args:") <+> parens (ppr as)
248 <+> ptext (sLit "ress:") <+> parens (ppr rs)
249 , ptext (sLit " with update frame") <+> ppr u
250 , semi ]
251
252 pp_debug :: SDoc
253 pp_debug =
254 if not debugIsOn then empty
255 else case node of
256 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
257 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
258 CmmAssign {} -> text " // CmmAssign"
259 CmmStore {} -> text " // CmmStore"
260 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
261 CmmBranch {} -> text " // CmmBranch"
262 CmmCondBranch {} -> text " // CmmCondBranch"
263 CmmSwitch {} -> text " // CmmSwitch"
264 CmmCall {} -> text " // CmmCall"
265 CmmForeignCall {} -> text " // CmmForeignCall"
266
267 commafy :: [SDoc] -> SDoc
268 commafy xs = hsep $ punctuate comma xs