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