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