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