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