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