Merge in new code generator branch.
[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 CmmExpr
44 import CmmUtils (isTrivialCmmExpr)
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 => Block CmmNode e x -> IndexedCO e SDoc SDoc
111 pprBlock block = foldBlockNodesB3 ( ($$) . ppr
112 , ($$) . (nest 4) . ppr
113 , ($$) . (nest 4) . ppr
114 )
115 block
116 empty
117
118 pprGraph :: Graph CmmNode e x -> SDoc
119 pprGraph GNil = empty
120 pprGraph (GUnit block) = ppr block
121 pprGraph (GMany entry body exit)
122 = text "{"
123 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
124 $$ text "}"
125 where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
126 pprMaybeO NothingO = empty
127 pprMaybeO (JustO block) = ppr block
128
129 pprCmmGraph :: CmmGraph -> SDoc
130 pprCmmGraph g
131 = text "{" <> text "offset"
132 $$ nest 2 (vcat $ map ppr blocks)
133 $$ text "}"
134 where blocks = postorderDfs g
135
136 ---------------------------------------------
137 -- Outputting CmmNode and types which it contains
138
139 pprConvention :: Convention -> SDoc
140 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
141 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
142 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
143 pprConvention Slow = text "<slow-convention>"
144 pprConvention GC = text "<gc-convention>"
145 pprConvention PrimOpCall = text "<primop-call-convention>"
146 pprConvention PrimOpReturn = text "<primop-ret-convention>"
147 pprConvention (Foreign c) = ppr c
148 pprConvention (Private {}) = text "<private-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 (CmmLabel (mkForeignLabel
166 (mkFastString (show op))
167 Nothing ForeignLabelInThisPackage IsFunction))
168 pprNode :: CmmNode e x -> SDoc
169 pprNode node = pp_node <+> pp_debug
170 where
171 pp_node :: SDoc
172 pp_node = case node of
173 -- label:
174 CmmEntry id -> ppr id <> colon
175
176 -- // text
177 CmmComment s -> text "//" <+> ftext s
178
179 -- reg = expr;
180 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
181
182 -- rep[lv] = expr;
183 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
184 where
185 rep = ppr ( cmmExprType expr )
186
187 -- call "ccall" foo(x, y)[r1, r2];
188 -- ToDo ppr volatile
189 CmmUnsafeForeignCall target results args ->
190 hsep [ ppUnless (null results) $
191 parens (commafy $ map ppr results) <+> equals,
192 ptext $ sLit "call",
193 ppr target <> parens (commafy $ map ppr args) <> semi]
194
195 -- goto label;
196 CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
197
198 -- if (expr) goto t; else goto f;
199 CmmCondBranch expr t f ->
200 hsep [ ptext (sLit "if")
201 , parens(ppr expr)
202 , ptext (sLit "goto")
203 , ppr t <> semi
204 , ptext (sLit "else goto")
205 , ppr f <> semi
206 ]
207
208 CmmSwitch expr maybe_ids ->
209 hang (hcat [ ptext (sLit "switch [0 .. ")
210 , int (length maybe_ids - 1)
211 , ptext (sLit "] ")
212 , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr)
213 , ptext (sLit " {")
214 ])
215 4 (vcat ( map caseify pairs )) $$ rbrace
216 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
217 snds a b = (snd a) == (snd b)
218 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
219 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
220 caseify as = let (is,ids) = unzip as
221 in hsep [ ptext (sLit "case")
222 , hcat (punctuate comma (map int is))
223 , ptext (sLit ": goto")
224 , ppr (head [ id | Just id <- ids]) <> semi ]
225
226 CmmCall tgt k out res updfr_off ->
227 hcat [ ptext (sLit "call"), space
228 , pprFun tgt, ptext (sLit "(...)"), space
229 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
230 <+> parens (ppr res)
231 , ptext (sLit " with update frame") <+> ppr updfr_off
232 , semi ]
233 where pprFun f@(CmmLit _) = ppr f
234 pprFun f = parens (ppr f)
235
236 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
237 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
238 [ ptext (sLit "foreign call"), space
239 , ppr t, ptext (sLit "(...)"), space
240 , ptext (sLit "returns to") <+> ppr s
241 <+> ptext (sLit "args:") <+> parens (ppr as)
242 <+> ptext (sLit "ress:") <+> parens (ppr rs)
243 , ptext (sLit " with update frame") <+> ppr u
244 , semi ]
245
246 pp_debug :: SDoc
247 pp_debug =
248 if not debugIsOn then empty
249 else case node of
250 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
251 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
252 CmmAssign {} -> text " // CmmAssign"
253 CmmStore {} -> text " // CmmStore"
254 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
255 CmmBranch {} -> text " // CmmBranch"
256 CmmCondBranch {} -> text " // CmmCondBranch"
257 CmmSwitch {} -> text " // CmmSwitch"
258 CmmCall {} -> text " // CmmCall"
259 CmmForeignCall {} -> text " // CmmForeignCall"
260
261 commafy :: [SDoc] -> SDoc
262 commafy xs = hsep $ punctuate comma xs