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