Moved global register saving from the backend to codeGen
[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 --
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 module PprCmm (
36 writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
37 ) where
38
39 #include "HsVersions.h"
40
41 import Cmm
42 import CmmUtils
43 import MachOp
44 import CLabel
45
46 import ForeignCall
47 import Unique
48 import Outputable
49 import FastString
50
51 import Data.List
52 import System.IO
53 import Data.Maybe
54
55 pprCmms :: [Cmm] -> SDoc
56 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
57 where
58 separator = space $$ ptext SLIT("-------------------") $$ space
59
60 writeCmms :: Handle -> [Cmm] -> IO ()
61 writeCmms handle cmms = printForC handle (pprCmms cmms)
62
63 -----------------------------------------------------------------------------
64
65 instance Outputable Cmm where
66 ppr c = pprCmm c
67
68 instance Outputable CmmTop where
69 ppr t = pprTop t
70
71 instance Outputable CmmBasicBlock where
72 ppr b = pprBBlock b
73
74 instance Outputable CmmStmt where
75 ppr s = pprStmt s
76
77 instance Outputable CmmExpr where
78 ppr e = pprExpr e
79
80 instance Outputable CmmReg where
81 ppr e = pprReg e
82
83 instance Outputable LocalReg where
84 ppr e = pprLocalReg e
85
86 instance Outputable GlobalReg where
87 ppr e = pprGlobalReg e
88
89 -----------------------------------------------------------------------------
90
91 pprCmm :: Cmm -> SDoc
92 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
93
94 -- --------------------------------------------------------------------------
95 -- Top level `procedure' blocks. The info tables, if not null, are
96 -- printed in the style of C--'s 'stackdata' declaration, just inside
97 -- the proc body, and are labelled with the procedure name ++ "_info".
98 --
99 pprTop :: CmmTop -> SDoc
100 pprTop (CmmProc info lbl params blocks )
101
102 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
103 , nest 8 $ pprInfo info lbl
104 , nest 4 $ vcat (map ppr blocks)
105 , rbrace ]
106
107 where
108 pprInfo [] _ = empty
109 pprInfo i label =
110 (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
111 4 $ vcat (map pprStatic i))
112 $$ rbrace
113
114 -- --------------------------------------------------------------------------
115 -- We follow [1], 4.5
116 --
117 -- section "data" { ... }
118 --
119 pprTop (CmmData section ds) =
120 (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
121 $$ rbrace
122
123
124 -- --------------------------------------------------------------------------
125 -- Basic blocks look like assembly blocks.
126 -- lbl: stmt ; stmt ; ..
127 pprBBlock :: CmmBasicBlock -> SDoc
128 pprBBlock (BasicBlock ident stmts) =
129 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
130
131 -- --------------------------------------------------------------------------
132 -- Statements. C-- usually, exceptions to this should be obvious.
133 --
134 pprStmt :: CmmStmt -> SDoc
135 pprStmt stmt = case stmt of
136
137 -- ;
138 CmmNop -> semi
139
140 -- // text
141 CmmComment s -> text "//" <+> ftext s
142
143 -- reg = expr;
144 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
145
146 -- rep[lv] = expr;
147 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
148 where
149 rep = ppr ( cmmExprRep expr )
150
151 -- call "ccall" foo(x, y)[r1, r2];
152 -- ToDo ppr volatile
153 CmmCall (CmmForeignCall fn cconv) results args ->
154 hcat [ ptext SLIT("call"), space,
155 doubleQuotes(ppr cconv), space,
156 target fn, parens ( commafy $ map ppr args ),
157 (if null results
158 then empty
159 else brackets( commafy $ map ppr results)), semi ]
160 where
161 target (CmmLit lit) = pprLit lit
162 target fn' = parens (ppr fn')
163
164 CmmCall (CmmPrim op) results args ->
165 pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
166 results args)
167 where
168 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
169
170 CmmBranch ident -> genBranch ident
171 CmmCondBranch expr ident -> genCondBranch expr ident
172 CmmJump expr params -> genJump expr params
173 CmmReturn params -> genReturn params
174 CmmSwitch arg ids -> genSwitch arg ids
175
176 -- --------------------------------------------------------------------------
177 -- goto local label. [1], section 6.6
178 --
179 -- goto lbl;
180 --
181 genBranch :: BlockId -> SDoc
182 genBranch ident =
183 ptext SLIT("goto") <+> pprBlockId ident <> semi
184
185 -- --------------------------------------------------------------------------
186 -- Conditional. [1], section 6.4
187 --
188 -- if (expr) { goto lbl; }
189 --
190 genCondBranch :: CmmExpr -> BlockId -> SDoc
191 genCondBranch expr ident =
192 hsep [ ptext SLIT("if")
193 , parens(ppr expr)
194 , ptext SLIT("goto")
195 , pprBlockId ident <> semi ]
196
197 -- --------------------------------------------------------------------------
198 -- A tail call. [1], Section 6.9
199 --
200 -- jump foo(a, b, c);
201 --
202 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
203 genJump expr args =
204
205 hcat [ ptext SLIT("jump")
206 , space
207 , if isTrivialCmmExpr expr
208 then pprExpr expr
209 else case expr of
210 CmmLoad (CmmReg _) _ -> pprExpr expr
211 _ -> parens (pprExpr expr)
212 , space
213 , parens ( commafy $ map ppr args )
214 , semi ]
215
216 -- --------------------------------------------------------------------------
217 -- Return from a function. [1], Section 6.8.2 of version 1.128
218 --
219 -- return (a, b, c);
220 --
221 genReturn :: [(CmmExpr, MachHint)] -> SDoc
222 genReturn args =
223
224 hcat [ ptext SLIT("return")
225 , space
226 , parens ( commafy $ map ppr args )
227 , semi ]
228
229 -- --------------------------------------------------------------------------
230 -- Tabled jump to local label
231 --
232 -- The syntax is from [1], section 6.5
233 --
234 -- switch [0 .. n] (expr) { case ... ; }
235 --
236 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
237 genSwitch expr maybe_ids
238
239 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
240
241 in hang (hcat [ ptext SLIT("switch [0 .. ")
242 , int (length maybe_ids - 1)
243 , ptext SLIT("] ")
244 , if isTrivialCmmExpr expr
245 then pprExpr expr
246 else parens (pprExpr expr)
247 , ptext SLIT(" {")
248 ])
249 4 (vcat ( map caseify pairs )) $$ rbrace
250
251 where
252 snds a b = (snd a) == (snd b)
253
254 caseify :: [(Int,Maybe BlockId)] -> SDoc
255 caseify ixs@((i,Nothing):_)
256 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
257 <> ptext SLIT(" */")
258 caseify as
259 = let (is,ids) = unzip as
260 in hsep [ ptext SLIT("case")
261 , hcat (punctuate comma (map int is))
262 , ptext SLIT(": goto")
263 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
264
265 -- --------------------------------------------------------------------------
266 -- Expressions
267 --
268
269 pprExpr :: CmmExpr -> SDoc
270 pprExpr e
271 = case e of
272 CmmRegOff reg i ->
273 pprExpr (CmmMachOp (MO_Add rep)
274 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
275 where rep = cmmRegRep reg
276 CmmLit lit -> pprLit lit
277 _other -> pprExpr1 e
278
279 -- Here's the precedence table from CmmParse.y:
280 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
281 -- %left '|'
282 -- %left '^'
283 -- %left '&'
284 -- %left '>>' '<<'
285 -- %left '-' '+'
286 -- %left '/' '*' '%'
287 -- %right '~'
288
289 -- We just cope with the common operators for now, the rest will get
290 -- a default conservative behaviour.
291
292 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
293 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
294 = pprExpr7 x <+> doc <+> pprExpr7 y
295 pprExpr1 e = pprExpr7 e
296
297 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
298 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
299 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
300 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
301 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
302 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
303 infixMachOp1 (MO_U_Gt _) = Just (char '>')
304 infixMachOp1 (MO_U_Lt _) = Just (char '<')
305 infixMachOp1 _ = Nothing
306
307 -- %left '-' '+'
308 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
309 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
310 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
311 = pprExpr7 x <+> doc <+> pprExpr8 y
312 pprExpr7 e = pprExpr8 e
313
314 infixMachOp7 (MO_Add _) = Just (char '+')
315 infixMachOp7 (MO_Sub _) = Just (char '-')
316 infixMachOp7 _ = Nothing
317
318 -- %left '/' '*' '%'
319 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
320 = pprExpr8 x <+> doc <+> pprExpr9 y
321 pprExpr8 e = pprExpr9 e
322
323 infixMachOp8 (MO_U_Quot _) = Just (char '/')
324 infixMachOp8 (MO_Mul _) = Just (char '*')
325 infixMachOp8 (MO_U_Rem _) = Just (char '%')
326 infixMachOp8 _ = Nothing
327
328 pprExpr9 :: CmmExpr -> SDoc
329 pprExpr9 e =
330 case e of
331 CmmLit lit -> pprLit1 lit
332 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
333 CmmReg reg -> ppr reg
334 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
335 CmmMachOp mop args -> genMachOp mop args
336
337 genMachOp :: MachOp -> [CmmExpr] -> SDoc
338 genMachOp mop args
339 | Just doc <- infixMachOp mop = case args of
340 -- dyadic
341 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
342
343 -- unary
344 [x] -> doc <> pprExpr9 x
345
346 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
347 (pprMachOp mop <+>
348 parens (hcat $ punctuate comma (map pprExpr args)))
349 empty
350
351 | isJust (infixMachOp1 mop)
352 || isJust (infixMachOp7 mop)
353 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
354
355 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
356 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
357 (show mop))
358 -- replace spaces in (show mop) with underscores,
359
360 --
361 -- Unsigned ops on the word size of the machine get nice symbols.
362 -- All else get dumped in their ugly format.
363 --
364 infixMachOp :: MachOp -> Maybe SDoc
365 infixMachOp mop
366 = case mop of
367 MO_And _ -> Just $ char '&'
368 MO_Or _ -> Just $ char '|'
369 MO_Xor _ -> Just $ char '^'
370 MO_Not _ -> Just $ char '~'
371 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
372 _ -> Nothing
373
374 -- --------------------------------------------------------------------------
375 -- Literals.
376 -- To minimise line noise we adopt the convention that if the literal
377 -- has the natural machine word size, we do not append the type
378 --
379 pprLit :: CmmLit -> SDoc
380 pprLit lit = case lit of
381 CmmInt i rep ->
382 hcat [ (if i < 0 then parens else id)(integer i)
383 , (if rep == wordRep
384 then empty
385 else space <> dcolon <+> ppr rep) ]
386
387 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
388 CmmLabel clbl -> pprCLabel clbl
389 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
390 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
391 <> pprCLabel clbl2 <> ppr_offset i
392
393 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
394 pprLit1 lit = pprLit lit
395
396 ppr_offset :: Int -> SDoc
397 ppr_offset i
398 | i==0 = empty
399 | i>=0 = char '+' <> int i
400 | otherwise = char '-' <> int (-i)
401
402 -- --------------------------------------------------------------------------
403 -- Static data.
404 -- Strings are printed as C strings, and we print them as I8[],
405 -- following C--
406 --
407 pprStatic :: CmmStatic -> SDoc
408 pprStatic s = case s of
409 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
410 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
411 CmmAlign i -> nest 4 $ text "align" <+> int i
412 CmmDataLabel clbl -> pprCLabel clbl <> colon
413 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
414
415 -- --------------------------------------------------------------------------
416 -- Registers, whether local (temps) or global
417 --
418 pprReg :: CmmReg -> SDoc
419 pprReg r
420 = case r of
421 CmmLocal local -> pprLocalReg local
422 CmmGlobal global -> pprGlobalReg global
423
424 --
425 -- We only print the type of the local reg if it isn't wordRep
426 --
427 pprLocalReg :: LocalReg -> SDoc
428 pprLocalReg (LocalReg uniq rep)
429 = hcat [ char '_', ppr uniq,
430 (if rep == wordRep
431 then empty else dcolon <> ppr rep) ]
432
433 -- needs to be kept in syn with Cmm.hs.GlobalReg
434 --
435 pprGlobalReg :: GlobalReg -> SDoc
436 pprGlobalReg gr
437 = case gr of
438 VanillaReg n -> char 'R' <> int n
439 FloatReg n -> char 'F' <> int n
440 DoubleReg n -> char 'D' <> int n
441 LongReg n -> char 'L' <> int n
442 Sp -> ptext SLIT("Sp")
443 SpLim -> ptext SLIT("SpLim")
444 Hp -> ptext SLIT("Hp")
445 HpLim -> ptext SLIT("HpLim")
446 CurrentTSO -> ptext SLIT("CurrentTSO")
447 CurrentNursery -> ptext SLIT("CurrentNursery")
448 HpAlloc -> ptext SLIT("HpAlloc")
449 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
450 GCFun -> ptext SLIT("stg_gc_fun")
451 BaseReg -> ptext SLIT("BaseReg")
452 PicBaseReg -> ptext SLIT("PicBaseReg")
453
454 -- --------------------------------------------------------------------------
455 -- data sections
456 --
457 pprSection :: Section -> SDoc
458 pprSection s = case s of
459 Text -> section <+> doubleQuotes (ptext SLIT("text"))
460 Data -> section <+> doubleQuotes (ptext SLIT("data"))
461 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
462 RelocatableReadOnlyData
463 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
464 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
465 OtherSection s' -> section <+> doubleQuotes (text s')
466 where
467 section = ptext SLIT("section")
468
469 -- --------------------------------------------------------------------------
470 -- Basic block ids
471 --
472 pprBlockId :: BlockId -> SDoc
473 pprBlockId b = ppr $ getUnique b
474
475 -----------------------------------------------------------------------------
476
477 commafy :: [SDoc] -> SDoc
478 commafy xs = hsep $ punctuate comma xs
479