add a comment
[ghc.git] / compiler / cmm / PprCmmExpr.hs
1 ----------------------------------------------------------------------------
2 --
3 -- Pretty-printing of common Cmm types
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 --
10 -- This is where we walk over Cmm emitting an external representation,
11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
12 -- is the "External Core" for the Cmm layer.
13 --
14 -- As such, this should be a well-defined syntax: we want it to look nice.
15 -- Thus, we try wherever possible to use syntax defined in [1],
16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
18 -- than C--'s bits8 .. bits64.
19 --
20 -- We try to ensure that all information available in the abstract
21 -- syntax is reproduced, or reproducible, in the concrete syntax.
22 -- Data that is not in printed out can be reconstructed according to
23 -- conventions used in the pretty printer. There are at least two such
24 -- cases:
25 -- 1) if a value has wordRep type, the type is not appended in the
26 -- output.
27 -- 2) MachOps that operate over wordRep type are printed in a
28 -- C-style, rather than as their internal MachRep name.
29 --
30 -- These conventions produce much more readable Cmm output.
31 --
32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
33 --
34
35 {-# OPTIONS_GHC -fno-warn-orphans #-}
36 module PprCmmExpr
37 ( pprExpr, pprLit
38 )
39 where
40
41 import CmmExpr
42
43 import Outputable
44 import FastString
45
46 import Data.Maybe
47 import Numeric ( fromRat )
48
49 -----------------------------------------------------------------------------
50
51 instance Outputable CmmExpr where
52 ppr e = pprExpr e
53
54 instance Outputable CmmReg where
55 ppr e = pprReg e
56
57 instance Outputable CmmLit where
58 ppr l = pprLit l
59
60 instance Outputable LocalReg where
61 ppr e = pprLocalReg e
62
63 instance Outputable Area where
64 ppr e = pprArea e
65
66 instance Outputable GlobalReg where
67 ppr e = pprGlobalReg e
68
69 -- --------------------------------------------------------------------------
70 -- Expressions
71 --
72
73 pprExpr :: CmmExpr -> SDoc
74 pprExpr e
75 = sdocWithDynFlags $ \dflags ->
76 case e of
77 CmmRegOff reg i ->
78 pprExpr (CmmMachOp (MO_Add rep)
79 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
80 where rep = typeWidth (cmmRegType dflags reg)
81 CmmLit lit -> pprLit lit
82 _other -> pprExpr1 e
83
84 -- Here's the precedence table from CmmParse.y:
85 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
86 -- %left '|'
87 -- %left '^'
88 -- %left '&'
89 -- %left '>>' '<<'
90 -- %left '-' '+'
91 -- %left '/' '*' '%'
92 -- %right '~'
93
94 -- We just cope with the common operators for now, the rest will get
95 -- a default conservative behaviour.
96
97 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
98 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
99 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
100 = pprExpr7 x <+> doc <+> pprExpr7 y
101 pprExpr1 e = pprExpr7 e
102
103 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
104
105 infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
106 infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
107 infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
108 infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
109 infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
110 infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
111 infixMachOp1 (MO_U_Gt _) = Just (char '>')
112 infixMachOp1 (MO_U_Lt _) = Just (char '<')
113 infixMachOp1 _ = Nothing
114
115 -- %left '-' '+'
116 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
117 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
118 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
119 = pprExpr7 x <+> doc <+> pprExpr8 y
120 pprExpr7 e = pprExpr8 e
121
122 infixMachOp7 (MO_Add _) = Just (char '+')
123 infixMachOp7 (MO_Sub _) = Just (char '-')
124 infixMachOp7 _ = Nothing
125
126 -- %left '/' '*' '%'
127 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
128 = pprExpr8 x <+> doc <+> pprExpr9 y
129 pprExpr8 e = pprExpr9 e
130
131 infixMachOp8 (MO_U_Quot _) = Just (char '/')
132 infixMachOp8 (MO_Mul _) = Just (char '*')
133 infixMachOp8 (MO_U_Rem _) = Just (char '%')
134 infixMachOp8 _ = Nothing
135
136 pprExpr9 :: CmmExpr -> SDoc
137 pprExpr9 e =
138 case e of
139 CmmLit lit -> pprLit1 lit
140 CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
141 CmmReg reg -> ppr reg
142 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
143 CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
144 CmmMachOp mop args -> genMachOp mop args
145
146 genMachOp :: MachOp -> [CmmExpr] -> SDoc
147 genMachOp mop args
148 | Just doc <- infixMachOp mop = case args of
149 -- dyadic
150 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
151
152 -- unary
153 [x] -> doc <> pprExpr9 x
154
155 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
156 (pprMachOp mop <+>
157 parens (hcat $ punctuate comma (map pprExpr args)))
158 empty
159
160 | isJust (infixMachOp1 mop)
161 || isJust (infixMachOp7 mop)
162 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
163
164 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
165 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
166 (show mop))
167 -- replace spaces in (show mop) with underscores,
168
169 --
170 -- Unsigned ops on the word size of the machine get nice symbols.
171 -- All else get dumped in their ugly format.
172 --
173 infixMachOp :: MachOp -> Maybe SDoc
174 infixMachOp mop
175 = case mop of
176 MO_And _ -> Just $ char '&'
177 MO_Or _ -> Just $ char '|'
178 MO_Xor _ -> Just $ char '^'
179 MO_Not _ -> Just $ char '~'
180 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
181 _ -> Nothing
182
183 -- --------------------------------------------------------------------------
184 -- Literals.
185 -- To minimise line noise we adopt the convention that if the literal
186 -- has the natural machine word size, we do not append the type
187 --
188 pprLit :: CmmLit -> SDoc
189 pprLit lit = sdocWithDynFlags $ \dflags ->
190 case lit of
191 CmmInt i rep ->
192 hcat [ (if i < 0 then parens else id)(integer i)
193 , ppUnless (rep == wordWidth dflags) $
194 space <> dcolon <+> ppr rep ]
195
196 CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
197 CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>'
198 CmmLabel clbl -> ppr clbl
199 CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
200 CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'
201 <> ppr clbl2 <> ppr_offset i
202 CmmBlock id -> ppr id
203 CmmHighStackMark -> text "<highSp>"
204
205 pprLit1 :: CmmLit -> SDoc
206 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
207 pprLit1 lit = pprLit lit
208
209 ppr_offset :: Int -> SDoc
210 ppr_offset i
211 | i==0 = empty
212 | i>=0 = char '+' <> int i
213 | otherwise = char '-' <> int (-i)
214
215 -- --------------------------------------------------------------------------
216 -- Registers, whether local (temps) or global
217 --
218 pprReg :: CmmReg -> SDoc
219 pprReg r
220 = case r of
221 CmmLocal local -> pprLocalReg local
222 CmmGlobal global -> pprGlobalReg global
223
224 --
225 -- We only print the type of the local reg if it isn't wordRep
226 --
227 pprLocalReg :: LocalReg -> SDoc
228 pprLocalReg (LocalReg uniq rep)
229 -- = ppr rep <> char '_' <> ppr uniq
230 -- Temp Jan08
231 = char '_' <> ppr uniq <>
232 (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
233 then dcolon <> ptr <> ppr rep
234 else dcolon <> ptr <> ppr rep)
235 where
236 ptr = empty
237 --if isGcPtrType rep
238 -- then doubleQuotes (text "ptr")
239 -- else empty
240
241 -- Stack areas
242 pprArea :: Area -> SDoc
243 pprArea Old = text "old"
244 pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
245
246 -- needs to be kept in syn with CmmExpr.hs.GlobalReg
247 --
248 pprGlobalReg :: GlobalReg -> SDoc
249 pprGlobalReg gr
250 = case gr of
251 VanillaReg n _ -> char 'R' <> int n
252 -- Temp Jan08
253 -- VanillaReg n VNonGcPtr -> char 'R' <> int n
254 -- VanillaReg n VGcPtr -> char 'P' <> int n
255 FloatReg n -> char 'F' <> int n
256 DoubleReg n -> char 'D' <> int n
257 LongReg n -> char 'L' <> int n
258 XmmReg n -> ptext (sLit "XMM") <> int n
259 YmmReg n -> ptext (sLit "YMM") <> int n
260 ZmmReg n -> ptext (sLit "ZMM") <> int n
261 Sp -> ptext (sLit "Sp")
262 SpLim -> ptext (sLit "SpLim")
263 Hp -> ptext (sLit "Hp")
264 HpLim -> ptext (sLit "HpLim")
265 CCCS -> ptext (sLit "CCCS")
266 CurrentTSO -> ptext (sLit "CurrentTSO")
267 CurrentNursery -> ptext (sLit "CurrentNursery")
268 HpAlloc -> ptext (sLit "HpAlloc")
269 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
270 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
271 GCFun -> ptext (sLit "stg_gc_fun")
272 BaseReg -> ptext (sLit "BaseReg")
273 PicBaseReg -> ptext (sLit "PicBaseReg")
274
275 -----------------------------------------------------------------------------
276
277 commafy :: [SDoc] -> SDoc
278 commafy xs = fsep $ punctuate comma xs