Implement unboxed sum primitive type
[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
45 import Data.Maybe
46 import Numeric ( fromRat )
47
48 -----------------------------------------------------------------------------
49
50 instance Outputable CmmExpr where
51 ppr e = pprExpr e
52
53 instance Outputable CmmReg where
54 ppr e = pprReg e
55
56 instance Outputable CmmArg where
57 ppr a = pprArg a
58
59 instance Outputable CmmLit where
60 ppr l = pprLit l
61
62 instance Outputable LocalReg where
63 ppr e = pprLocalReg e
64
65 instance Outputable Area where
66 ppr e = pprArea e
67
68 instance Outputable GlobalReg where
69 ppr e = pprGlobalReg e
70
71 -- --------------------------------------------------------------------------
72 -- Expressions
73 --
74
75 pprExpr :: CmmExpr -> SDoc
76 pprExpr e
77 = sdocWithDynFlags $ \dflags ->
78 case e of
79 CmmRegOff reg i ->
80 pprExpr (CmmMachOp (MO_Add rep)
81 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
82 where rep = typeWidth (cmmRegType dflags reg)
83 CmmLit lit -> pprLit lit
84 _other -> pprExpr1 e
85
86 -- Here's the precedence table from CmmParse.y:
87 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
88 -- %left '|'
89 -- %left '^'
90 -- %left '&'
91 -- %left '>>' '<<'
92 -- %left '-' '+'
93 -- %left '/' '*' '%'
94 -- %right '~'
95
96 -- We just cope with the common operators for now, the rest will get
97 -- a default conservative behaviour.
98
99 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
100 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
101 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
102 = pprExpr7 x <+> doc <+> pprExpr7 y
103 pprExpr1 e = pprExpr7 e
104
105 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
106
107 infixMachOp1 (MO_Eq _) = Just (text "==")
108 infixMachOp1 (MO_Ne _) = Just (text "!=")
109 infixMachOp1 (MO_Shl _) = Just (text "<<")
110 infixMachOp1 (MO_U_Shr _) = Just (text ">>")
111 infixMachOp1 (MO_U_Ge _) = Just (text ">=")
112 infixMachOp1 (MO_U_Le _) = Just (text "<=")
113 infixMachOp1 (MO_U_Gt _) = Just (char '>')
114 infixMachOp1 (MO_U_Lt _) = Just (char '<')
115 infixMachOp1 _ = Nothing
116
117 -- %left '-' '+'
118 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
119 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
120 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
121 = pprExpr7 x <+> doc <+> pprExpr8 y
122 pprExpr7 e = pprExpr8 e
123
124 infixMachOp7 (MO_Add _) = Just (char '+')
125 infixMachOp7 (MO_Sub _) = Just (char '-')
126 infixMachOp7 _ = Nothing
127
128 -- %left '/' '*' '%'
129 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
130 = pprExpr8 x <+> doc <+> pprExpr9 y
131 pprExpr8 e = pprExpr9 e
132
133 infixMachOp8 (MO_U_Quot _) = Just (char '/')
134 infixMachOp8 (MO_Mul _) = Just (char '*')
135 infixMachOp8 (MO_U_Rem _) = Just (char '%')
136 infixMachOp8 _ = Nothing
137
138 pprExpr9 :: CmmExpr -> SDoc
139 pprExpr9 e =
140 case e of
141 CmmLit lit -> pprLit1 lit
142 CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
143 CmmReg reg -> ppr reg
144 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
145 CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
146 CmmMachOp mop args -> genMachOp mop args
147
148 genMachOp :: MachOp -> [CmmExpr] -> SDoc
149 genMachOp mop args
150 | Just doc <- infixMachOp mop = case args of
151 -- dyadic
152 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
153
154 -- unary
155 [x] -> doc <> pprExpr9 x
156
157 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
158 (pprMachOp mop <+>
159 parens (hcat $ punctuate comma (map pprExpr args)))
160 empty
161
162 | isJust (infixMachOp1 mop)
163 || isJust (infixMachOp7 mop)
164 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
165
166 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
167 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
168 (show mop))
169 -- replace spaces in (show mop) with underscores,
170
171 --
172 -- Unsigned ops on the word size of the machine get nice symbols.
173 -- All else get dumped in their ugly format.
174 --
175 infixMachOp :: MachOp -> Maybe SDoc
176 infixMachOp mop
177 = case mop of
178 MO_And _ -> Just $ char '&'
179 MO_Or _ -> Just $ char '|'
180 MO_Xor _ -> Just $ char '^'
181 MO_Not _ -> Just $ char '~'
182 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
183 _ -> Nothing
184
185 -- --------------------------------------------------------------------------
186 -- Literals.
187 -- To minimise line noise we adopt the convention that if the literal
188 -- has the natural machine word size, we do not append the type
189 --
190 pprLit :: CmmLit -> SDoc
191 pprLit lit = sdocWithDynFlags $ \dflags ->
192 case lit of
193 CmmInt i rep ->
194 hcat [ (if i < 0 then parens else id)(integer i)
195 , ppUnless (rep == wordWidth dflags) $
196 space <> dcolon <+> ppr rep ]
197
198 CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
199 CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>'
200 CmmLabel clbl -> ppr clbl
201 CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
202 CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'
203 <> ppr clbl2 <> ppr_offset i
204 CmmBlock id -> ppr id
205 CmmHighStackMark -> text "<highSp>"
206
207 pprLit1 :: CmmLit -> SDoc
208 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
209 pprLit1 lit = pprLit lit
210
211 ppr_offset :: Int -> SDoc
212 ppr_offset i
213 | i==0 = empty
214 | i>=0 = char '+' <> int i
215 | otherwise = char '-' <> int (-i)
216
217 -- --------------------------------------------------------------------------
218 -- Registers, whether local (temps) or global
219 --
220 pprReg :: CmmReg -> SDoc
221 pprReg r
222 = case r of
223 CmmLocal local -> pprLocalReg local
224 CmmGlobal global -> pprGlobalReg global
225
226 --
227 -- We only print the type of the local reg if it isn't wordRep
228 --
229 pprLocalReg :: LocalReg -> SDoc
230 pprLocalReg (LocalReg uniq rep)
231 -- = ppr rep <> char '_' <> ppr uniq
232 -- Temp Jan08
233 = char '_' <> ppr uniq <>
234 (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
235 then dcolon <> ptr <> ppr rep
236 else dcolon <> ptr <> ppr rep)
237 where
238 ptr = empty
239 --if isGcPtrType rep
240 -- then doubleQuotes (text "ptr")
241 -- else empty
242
243 -- Stack areas
244 pprArea :: Area -> SDoc
245 pprArea Old = text "old"
246 pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
247
248 -- needs to be kept in syn with CmmExpr.hs.GlobalReg
249 --
250 pprGlobalReg :: GlobalReg -> SDoc
251 pprGlobalReg gr
252 = case gr of
253 VanillaReg n _ -> char 'R' <> int n
254 -- Temp Jan08
255 -- VanillaReg n VNonGcPtr -> char 'R' <> int n
256 -- VanillaReg n VGcPtr -> char 'P' <> int n
257 FloatReg n -> char 'F' <> int n
258 DoubleReg n -> char 'D' <> int n
259 LongReg n -> char 'L' <> int n
260 XmmReg n -> text "XMM" <> int n
261 YmmReg n -> text "YMM" <> int n
262 ZmmReg n -> text "ZMM" <> int n
263 Sp -> text "Sp"
264 SpLim -> text "SpLim"
265 Hp -> text "Hp"
266 HpLim -> text "HpLim"
267 MachSp -> text "MachSp"
268 UnwindReturnReg-> text "UnwindReturnReg"
269 CCCS -> text "CCCS"
270 CurrentTSO -> text "CurrentTSO"
271 CurrentNursery -> text "CurrentNursery"
272 HpAlloc -> text "HpAlloc"
273 EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
274 GCEnter1 -> text "stg_gc_enter_1"
275 GCFun -> text "stg_gc_fun"
276 BaseReg -> text "BaseReg"
277 PicBaseReg -> text "PicBaseReg"
278
279 -----------------------------------------------------------------------------
280
281 pprArg :: CmmArg -> SDoc
282 pprArg (CmmExprArg e) = ppr e
283 pprArg (CmmRubbishArg ty) = text "Rubbish" <+> dcolon <+> ppr ty
284
285 -----------------------------------------------------------------------------
286
287 commafy :: [SDoc] -> SDoc
288 commafy xs = fsep $ punctuate comma xs