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
|
----------------------------------------------------------------------------
--
-- Pretty-printing of old-style Cmm as (a superset of) C--
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
--
-- This is where we walk over Cmm 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 #-}
module OldPprCmm (
pprStmt,
module PprCmmDecl,
module PprCmmExpr
) where
import BlockId
import CLabel
import CmmUtils
import OldCmm
import PprCmmDecl
import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
import FastString
import Data.List
-----------------------------------------------------------------------------
instance Outputable instr => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance Outputable instr => Outputable (GenBasicBlock instr) where
ppr = pprBBlock
instance Outputable CmmStmt where
ppr s = pprStmt s
-- --------------------------------------------------------------------------
instance Outputable CmmSafety where
ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
ppr (CmmSafe srt) = ppr srt
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
--
pprStmt :: CmmStmt -> SDoc
pprStmt stmt = case stmt of
-- ;
CmmNop -> semi
-- // 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
CmmCall (CmmCallee fn cconv) results args ret ->
sep [ pp_lhs <+> pp_conv
, nest 2 (pprExpr9 fn <>
parens (commafy (map ppr_ar args)))
, case ret of CmmMayReturn -> empty
CmmNeverReturns -> ptext $ sLit (" never returns")
] <> semi
where
pp_lhs | null results = empty
| otherwise = commafy (map ppr_ar results) <+> equals
-- Don't print the hints on a native C-- call
ppr_ar (CmmHinted ar k) = case cconv of
CmmCallConv -> ppr ar
_ -> ppr (ar,k)
pp_conv = case cconv of
CmmCallConv -> empty
_ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
CmmCall (CmmPrim op _) results args ret ->
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret)
where
-- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
-- use one to get the label printed.
lbl = CmmLabel (mkForeignLabel
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction)
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch expr ident
CmmJump expr live -> genJump expr live
CmmReturn -> genReturn
CmmSwitch arg ids -> genSwitch arg ids
-- Just look like a tuple, since it was a tuple before
-- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k)
-- --------------------------------------------------------------------------
-- goto local label. [1], section 6.6
--
-- goto lbl;
--
genBranch :: BlockId -> SDoc
genBranch ident =
ptext (sLit "goto") <+> ppr ident <> semi
-- --------------------------------------------------------------------------
-- Conditional. [1], section 6.4
--
-- if (expr) { goto lbl; }
--
genCondBranch :: CmmExpr -> BlockId -> SDoc
genCondBranch expr ident =
hsep [ ptext (sLit "if")
, parens (ppr expr)
, ptext (sLit "goto")
, ppr ident <> semi ]
-- --------------------------------------------------------------------------
-- A tail call. [1], Section 6.9
--
-- jump foo(a, b, c);
--
genJump :: CmmExpr -> Maybe [GlobalReg] -> SDoc
genJump expr live =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
then pprExpr expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
, semi <+> ptext (sLit "// ")
, maybe empty ppr live]
-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
--
-- return (a, b, c);
--
genReturn :: SDoc
genReturn = hcat [ ptext (sLit "return") , semi ]
-- --------------------------------------------------------------------------
-- Tabled jump to local label
--
-- The syntax is from [1], section 6.5
--
-- switch [0 .. n] (expr) { case ... ; }
--
genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
genSwitch expr maybe_ids
= let pairs = groupBy snds (zip [0 .. ] maybe_ids )
in hang (hcat [ ptext (sLit "switch [0 .. ")
, int (length maybe_ids - 1)
, ptext (sLit "] ")
, if isTrivialCmmExpr expr
then pprExpr expr
else parens (pprExpr expr)
, ptext (sLit " {")
])
4 (vcat ( map caseify pairs )) $$ rbrace
where
snds a b = (snd a) == (snd b)
caseify :: [(Int,Maybe BlockId)] -> SDoc
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 ]
-----------------------------------------------------------------------------
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs
|
