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