Snapshot of codegen refactoring to share with simonpj
[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 Platform
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 PlatformOutputable (Block CmmNode C C) where
80 pprPlatform _ = pprBlock
81 instance PlatformOutputable (Block CmmNode C O) where
82 pprPlatform _ = pprBlock
83 instance PlatformOutputable (Block CmmNode O C) where
84 pprPlatform _ = pprBlock
85 instance PlatformOutputable (Block CmmNode O O) where
86 pprPlatform _ = pprBlock
87
88 instance PlatformOutputable (Graph CmmNode e x) where
89 pprPlatform = pprGraph
90
91 instance PlatformOutputable CmmGraph where
92 pprPlatform platform = pprCmmGraph platform
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 = foldBlockNodesB3 ( ($$) . ppr
113 , ($$) . (nest 4) . ppr
114 , ($$) . (nest 4) . ppr
115 )
116 block
117 empty
118
119 pprGraph :: Platform -> Graph CmmNode e x -> SDoc
120 pprGraph _ GNil = empty
121 pprGraph platform (GUnit block) = pprPlatform platform block
122 pprGraph platform (GMany entry body exit)
123 = text "{"
124 $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
125 $$ text "}"
126 where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
127 => MaybeO ex (Block CmmNode e x) -> SDoc
128 pprMaybeO NothingO = empty
129 pprMaybeO (JustO block) = pprPlatform platform block
130
131 pprCmmGraph :: Platform -> CmmGraph -> SDoc
132 pprCmmGraph platform g
133 = text "{" <> text "offset"
134 $$ nest 2 (vcat $ map (pprPlatform platform) 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 pprConvention (Foreign c) = ppr c
150 pprConvention (Private {}) = text "<private-convention>"
151
152 pprForeignConvention :: ForeignConvention -> SDoc
153 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
154
155 pprForeignTarget :: ForeignTarget -> SDoc
156 pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
157 where ppr_fc :: ForeignConvention -> SDoc
158 ppr_fc (ForeignConvention c args res) =
159 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
160 ppr_target :: CmmExpr -> SDoc
161 ppr_target t@(CmmLit _) = ppr t
162 ppr_target fn' = parens (ppr fn')
163
164 pprForeignTarget (PrimTarget op)
165 -- HACK: We're just using a ForeignLabel to get this printed, the label
166 -- might not really be foreign.
167 = ppr (CmmLabel (mkForeignLabel
168 (mkFastString (show op))
169 Nothing ForeignLabelInThisPackage IsFunction))
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 then ppr expr else parens (ppr expr)
215 , ptext (sLit " {")
216 ])
217 4 (vcat ( map caseify pairs )) $$ rbrace
218 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
219 snds a b = (snd a) == (snd b)
220 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
221 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
222 caseify as = let (is,ids) = unzip as
223 in hsep [ ptext (sLit "case")
224 , hcat (punctuate comma (map int is))
225 , ptext (sLit ": goto")
226 , ppr (head [ id | Just id <- ids]) <> semi ]
227
228 CmmCall tgt k out res updfr_off ->
229 hcat [ ptext (sLit "call"), space
230 , pprFun tgt, ptext (sLit "(...)"), space
231 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
232 <+> parens (ppr res)
233 , ptext (sLit " with update frame") <+> ppr updfr_off
234 , semi ]
235 where pprFun f@(CmmLit _) = ppr f
236 pprFun f = parens (ppr f)
237
238 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
239 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
240 [ ptext (sLit "foreign call"), space
241 , ppr t, ptext (sLit "(...)"), space
242 , ptext (sLit "returns to") <+> ppr s
243 <+> ptext (sLit "args:") <+> parens (ppr as)
244 <+> ptext (sLit "ress:") <+> parens (ppr rs)
245 , ptext (sLit " with update frame") <+> ppr u
246 , semi ]
247
248 pp_debug :: SDoc
249 pp_debug =
250 if not debugIsOn then empty
251 else case node of
252 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
253 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
254 CmmAssign {} -> text " // CmmAssign"
255 CmmStore {} -> text " // CmmStore"
256 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
257 CmmBranch {} -> text " // CmmBranch"
258 CmmCondBranch {} -> text " // CmmCondBranch"
259 CmmSwitch {} -> text " // CmmSwitch"
260 CmmCall {} -> text " // CmmCall"
261 CmmForeignCall {} -> text " // CmmForeignCall"
262
263 commafy :: [SDoc] -> SDoc
264 commafy xs = hsep $ punctuate comma xs