Fold testsuite.git into ghc.git (re #8545)
[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 instance Outputable CmmReturnInfo where
79 ppr = pprReturnInfo
80
81 instance Outputable (Block CmmNode C C) where
82 ppr = pprBlock
83 instance Outputable (Block CmmNode C O) where
84 ppr = pprBlock
85 instance Outputable (Block CmmNode O C) where
86 ppr = pprBlock
87 instance Outputable (Block CmmNode O O) where
88 ppr = pprBlock
89
90 instance Outputable (Graph CmmNode e x) where
91 ppr = pprGraph
92
93 instance Outputable CmmGraph where
94 ppr = pprCmmGraph
95
96 ----------------------------------------------------------
97 -- Outputting types Cmm contains
98
99 pprStackInfo :: CmmStackInfo -> SDoc
100 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
101 ptext (sLit "arg_space: ") <> ppr arg_space <+>
102 ptext (sLit "updfr_space: ") <> ppr updfr_space
103
104 pprTopInfo :: CmmTopInfo -> SDoc
105 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
106 vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
107 ptext (sLit "stack_info: ") <> ppr stack_info]
108
109 ----------------------------------------------------------
110 -- Outputting blocks and graphs
111
112 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
113 => Block CmmNode e x -> IndexedCO e SDoc SDoc
114 pprBlock block
115 = foldBlockNodesB3 ( ($$) . ppr
116 , ($$) . (nest 4) . ppr
117 , ($$) . (nest 4) . ppr
118 )
119 block
120 empty
121
122 pprGraph :: Graph CmmNode e x -> SDoc
123 pprGraph GNil = empty
124 pprGraph (GUnit block) = ppr block
125 pprGraph (GMany entry body exit)
126 = text "{"
127 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
128 $$ text "}"
129 where pprMaybeO :: Outputable (Block CmmNode e x)
130 => MaybeO ex (Block CmmNode e x) -> SDoc
131 pprMaybeO NothingO = empty
132 pprMaybeO (JustO block) = ppr block
133
134 pprCmmGraph :: CmmGraph -> SDoc
135 pprCmmGraph g
136 = text "{" <> text "offset"
137 $$ nest 2 (vcat $ map ppr blocks)
138 $$ text "}"
139 where blocks = postorderDfs g
140
141 ---------------------------------------------
142 -- Outputting CmmNode and types which it contains
143
144 pprConvention :: Convention -> SDoc
145 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
146 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
147 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
148 pprConvention Slow = text "<slow-convention>"
149 pprConvention GC = text "<gc-convention>"
150
151 pprForeignConvention :: ForeignConvention -> SDoc
152 pprForeignConvention (ForeignConvention c args res ret) =
153 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
154
155 pprReturnInfo :: CmmReturnInfo -> SDoc
156 pprReturnInfo CmmMayReturn = empty
157 pprReturnInfo CmmNeverReturns = ptext (sLit "never returns")
158
159 pprForeignTarget :: ForeignTarget -> SDoc
160 pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
161 where
162 ppr_target :: CmmExpr -> SDoc
163 ppr_target t@(CmmLit _) = ppr t
164 ppr_target fn' = parens (ppr fn')
165
166 pprForeignTarget (PrimTarget op)
167 -- HACK: We're just using a ForeignLabel to get this printed, the label
168 -- might not really be foreign.
169 = ppr
170 (CmmLabel (mkForeignLabel
171 (mkFastString (show op))
172 Nothing ForeignLabelInThisPackage IsFunction))
173
174 pprNode :: CmmNode e x -> SDoc
175 pprNode node = pp_node <+> pp_debug
176 where
177 pp_node :: SDoc
178 pp_node = case node of
179 -- label:
180 CmmEntry id -> ppr id <> colon
181
182 -- // text
183 CmmComment s -> text "//" <+> ftext s
184
185 -- reg = expr;
186 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
187
188 -- rep[lv] = expr;
189 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
190 where
191 rep = sdocWithDynFlags $ \dflags ->
192 ppr ( cmmExprType dflags expr )
193
194 -- call "ccall" foo(x, y)[r1, r2];
195 -- ToDo ppr volatile
196 CmmUnsafeForeignCall target results args ->
197 hsep [ ppUnless (null results) $
198 parens (commafy $ map ppr results) <+> equals,
199 ptext $ sLit "call",
200 ppr target <> parens (commafy $ map ppr args) <> semi]
201
202 -- goto label;
203 CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
204
205 -- if (expr) goto t; else goto f;
206 CmmCondBranch expr t f ->
207 hsep [ ptext (sLit "if")
208 , parens(ppr expr)
209 , ptext (sLit "goto")
210 , ppr t <> semi
211 , ptext (sLit "else goto")
212 , ppr f <> semi
213 ]
214
215 CmmSwitch expr maybe_ids ->
216 hang (hcat [ ptext (sLit "switch [0 .. ")
217 , int (length maybe_ids - 1)
218 , ptext (sLit "] ")
219 , if isTrivialCmmExpr expr
220 then ppr expr
221 else parens (ppr expr)
222 , ptext (sLit " {")
223 ])
224 4 (vcat ( map caseify pairs )) $$ rbrace
225 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
226 snds a b = (snd a) == (snd b)
227 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
228 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
229 caseify as = let (is,ids) = unzip as
230 in hsep [ ptext (sLit "case")
231 , hcat (punctuate comma (map int is))
232 , ptext (sLit ": goto")
233 , ppr (head [ id | Just id <- ids]) <> semi ]
234
235 CmmCall tgt k regs out res updfr_off ->
236 hcat [ ptext (sLit "call"), space
237 , pprFun tgt, parens (interpp'SP regs), space
238 , returns <+>
239 ptext (sLit "args: ") <> ppr out <> comma <+>
240 ptext (sLit "res: ") <> ppr res <> comma <+>
241 ptext (sLit "upd: ") <> ppr updfr_off
242 , semi ]
243 where pprFun f@(CmmLit _) = ppr f
244 pprFun f = parens (ppr f)
245
246 returns
247 | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma
248 | otherwise = empty
249
250 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
251 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
252 [ ptext (sLit "foreign call"), space
253 , ppr t, ptext (sLit "(...)"), space
254 , ptext (sLit "returns to") <+> ppr s
255 <+> ptext (sLit "args:") <+> parens (ppr as)
256 <+> ptext (sLit "ress:") <+> parens (ppr rs)
257 , ptext (sLit "ret_args:") <+> ppr a
258 , ptext (sLit "ret_off:") <+> ppr u
259 , semi ]
260
261 pp_debug :: SDoc
262 pp_debug =
263 if not debugIsOn then empty
264 else case node of
265 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
266 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
267 CmmAssign {} -> text " // CmmAssign"
268 CmmStore {} -> text " // CmmStore"
269 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
270 CmmBranch {} -> text " // CmmBranch"
271 CmmCondBranch {} -> text " // CmmCondBranch"
272 CmmSwitch {} -> text " // CmmSwitch"
273 CmmCall {} -> text " // CmmCall"
274 CmmForeignCall {} -> text " // CmmForeignCall"
275
276 commafy :: [SDoc] -> SDoc
277 commafy xs = hsep $ punctuate comma xs