More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[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 PlatformOutputable CmmTopInfo where
63 pprPlatform = pprTopInfo
64
65
66 instance PlatformOutputable (CmmNode e x) where
67 pprPlatform = pprNode
68
69 instance Outputable Convention where
70 ppr = pprConvention
71
72 instance Outputable ForeignConvention where
73 ppr = pprForeignConvention
74
75 instance PlatformOutputable ForeignTarget where
76 pprPlatform = pprForeignTarget
77
78
79 instance PlatformOutputable (Block CmmNode C C) where
80 pprPlatform = pprBlock
81 instance PlatformOutputable (Block CmmNode C O) where
82 pprPlatform = pprBlock
83 instance PlatformOutputable (Block CmmNode O C) where
84 pprPlatform = pprBlock
85 instance PlatformOutputable (Block CmmNode O O) where
86 pprPlatform = pprBlock
87
88 instance PlatformOutputable (Graph CmmNode e x) where
89 pprPlatform = pprGraph
90
91 instance PlatformOutputable CmmGraph where
92 pprPlatform platform = pprCmmGraph platform
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 platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
104 vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform 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 platform block
113 = foldBlockNodesB3 ( ($$) . pprPlatform platform
114 , ($$) . (nest 4) . pprPlatform platform
115 , ($$) . (nest 4) . pprPlatform platform
116 )
117 block
118 empty
119
120 pprGraph :: Platform -> Graph CmmNode e x -> SDoc
121 pprGraph _ GNil = empty
122 pprGraph platform (GUnit block) = pprPlatform platform block
123 pprGraph platform (GMany entry body exit)
124 = text "{"
125 $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
126 $$ text "}"
127 where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
128 => MaybeO ex (Block CmmNode e x) -> SDoc
129 pprMaybeO NothingO = empty
130 pprMaybeO (JustO block) = pprPlatform platform block
131
132 pprCmmGraph :: Platform -> CmmGraph -> SDoc
133 pprCmmGraph platform g
134 = text "{" <> text "offset"
135 $$ nest 2 (vcat $ map (pprPlatform platform) 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 platform (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 _) = pprPlatform platform t
163 ppr_target fn' = parens (pprPlatform platform fn')
164
165 pprForeignTarget platform (PrimTarget op)
166 -- HACK: We're just using a ForeignLabel to get this printed, the label
167 -- might not really be foreign.
168 = pprPlatform platform
169 (CmmLabel (mkForeignLabel
170 (mkFastString (show op))
171 Nothing ForeignLabelInThisPackage IsFunction))
172
173 pprNode :: Platform -> CmmNode e x -> SDoc
174 pprNode platform 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 <+> pprPlatform platform expr <> semi
186
187 -- rep[lv] = expr;
188 CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform 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 pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) 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(pprPlatform platform 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 pprPlatform platform expr
219 else parens (pprPlatform platform 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 _) = pprPlatform platform f
241 pprFun f = parens (pprPlatform platform 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 , pprPlatform platform t, ptext (sLit "(...)"), space
247 , ptext (sLit "returns to") <+> ppr s
248 <+> ptext (sLit "args:") <+> parens (pprPlatform platform 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