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