generalize instance Outputable GenCmm to H98 (#1405)
[ghc.git] / compiler / cmm / PprCmm.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 ----------------------------------------------------------------------------
9 --
10 -- Pretty-printing of Cmm as (a superset of) C--
11 --
12 -- (c) The University of Glasgow 2004-2006
13 --
14 -----------------------------------------------------------------------------
15
16 --
17 -- This is where we walk over Cmm emitting an external representation,
18 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
19 -- is the "External Core" for the Cmm layer.
20 --
21 -- As such, this should be a well-defined syntax: we want it to look nice.
22 -- Thus, we try wherever possible to use syntax defined in [1],
23 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
24 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
25 -- than C--'s bits8 .. bits64.
26 --
27 -- We try to ensure that all information available in the abstract
28 -- syntax is reproduced, or reproducible, in the concrete syntax.
29 -- Data that is not in printed out can be reconstructed according to
30 -- conventions used in the pretty printer. There are at least two such
31 -- cases:
32 -- 1) if a value has wordRep type, the type is not appended in the
33 -- output.
34 -- 2) MachOps that operate over wordRep type are printed in a
35 -- C-style, rather than as their internal MachRep name.
36 --
37 -- These conventions produce much more readable Cmm output.
38 --
39 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
40 --
41
42 module PprCmm
43 ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit
44 )
45 where
46
47 #include "HsVersions.h"
48
49 import Cmm
50 import CmmExpr
51 import CmmUtils
52 import MachOp
53 import CLabel
54
55 import ForeignCall
56 import Unique
57 import Outputable
58 import FastString
59
60 import Data.List
61 import System.IO
62 import Data.Maybe
63
64 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
65 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
66 where
67 separator = space $$ ptext SLIT("-------------------") $$ space
68
69 writeCmms :: Handle -> [Cmm] -> IO ()
70 writeCmms handle cmms = printForC handle (pprCmms cmms)
71
72 -----------------------------------------------------------------------------
73
74 instance (Outputable d, Outputable info, Outputable g)
75 => Outputable (GenCmm d info g) where
76 ppr c = pprCmm c
77
78 instance (Outputable d, Outputable info, Outputable i)
79 => Outputable (GenCmmTop d info i) where
80 ppr t = pprTop t
81
82 instance (Outputable instr) => Outputable (ListGraph instr) where
83 ppr (ListGraph blocks) = vcat (map ppr blocks)
84
85 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
86 ppr b = pprBBlock b
87
88 instance Outputable CmmStmt where
89 ppr s = pprStmt s
90
91 instance Outputable CmmExpr where
92 ppr e = pprExpr e
93
94 instance Outputable CmmReg where
95 ppr e = pprReg e
96
97 instance Outputable LocalReg where
98 ppr e = pprLocalReg e
99
100 instance Outputable GlobalReg where
101 ppr e = pprGlobalReg e
102
103 instance Outputable CmmStatic where
104 ppr e = pprStatic e
105
106 instance Outputable CmmInfo where
107 ppr e = pprInfo e
108
109
110
111 -----------------------------------------------------------------------------
112
113 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
114 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
115
116 -- --------------------------------------------------------------------------
117 -- Top level `procedure' blocks.
118 --
119 pprTop :: (Outputable d, Outputable info, Outputable i)
120 => GenCmmTop d info i -> SDoc
121
122 pprTop (CmmProc info lbl params graph )
123
124 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
125 , nest 8 $ lbrace <+> ppr info $$ rbrace
126 , nest 4 $ ppr graph
127 , rbrace ]
128
129 -- --------------------------------------------------------------------------
130 -- We follow [1], 4.5
131 --
132 -- section "data" { ... }
133 --
134 pprTop (CmmData section ds) =
135 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
136 $$ rbrace
137
138 -- --------------------------------------------------------------------------
139 instance Outputable CmmSafety where
140 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
141 ppr (CmmSafe srt) = ppr srt
142
143 -- --------------------------------------------------------------------------
144 -- Info tables. The current pretty printer needs refinement
145 -- but will work for now.
146 --
147 -- For ideas on how to refine it, they used to be printed in the
148 -- style of C--'s 'stackdata' declaration, just inside the proc body,
149 -- and were labelled with the procedure name ++ "_info".
150 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
151 vcat [{-ptext SLIT("gc_target: ") <>
152 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
153 ptext SLIT("update_frame: ") <>
154 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
155 pprInfo (CmmInfo gc_target update_frame
156 (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
157 vcat [{-ptext SLIT("gc_target: ") <>
158 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
159 ptext SLIT("update_frame: ") <>
160 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
161 ptext SLIT("type: ") <> pprLit closure_type,
162 ptext SLIT("desc: ") <> pprLit closure_desc,
163 ptext SLIT("tag: ") <> integer (toInteger tag),
164 pprTypeInfo info]
165
166 pprTypeInfo (ConstrInfo layout constr descr) =
167 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
168 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
169 ptext SLIT("constructor: ") <> integer (toInteger constr),
170 pprLit descr]
171 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
172 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
173 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
174 ptext SLIT("srt: ") <> ppr srt,
175 ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
176 ptext SLIT("arity: ") <> integer (toInteger arity),
177 --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
178 ptext SLIT("slow: ") <> pprLit slow_entry
179 ]
180 pprTypeInfo (ThunkInfo layout srt) =
181 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
182 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
183 ptext SLIT("srt: ") <> ppr srt]
184 pprTypeInfo (ThunkSelectorInfo offset srt) =
185 vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
186 ptext SLIT("srt: ") <> ppr srt]
187 pprTypeInfo (ContInfo stack srt) =
188 vcat [ptext SLIT("stack: ") <> ppr stack,
189 ptext SLIT("srt: ") <> ppr srt]
190
191 pprUpdateFrame :: UpdateFrame -> SDoc
192 pprUpdateFrame (UpdateFrame expr args) =
193 hcat [ ptext SLIT("jump")
194 , space
195 , if isTrivialCmmExpr expr
196 then pprExpr expr
197 else case expr of
198 CmmLoad (CmmReg _) _ -> pprExpr expr
199 _ -> parens (pprExpr expr)
200 , space
201 , parens ( commafy $ map ppr args ) ]
202
203
204 -- --------------------------------------------------------------------------
205 -- Basic blocks look like assembly blocks.
206 -- lbl: stmt ; stmt ; ..
207 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
208 pprBBlock (BasicBlock ident stmts) =
209 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
210
211 -- --------------------------------------------------------------------------
212 -- Statements. C-- usually, exceptions to this should be obvious.
213 --
214 pprStmt :: CmmStmt -> SDoc
215 pprStmt stmt = case stmt of
216
217 -- ;
218 CmmNop -> semi
219
220 -- // text
221 CmmComment s -> text "//" <+> ftext s
222
223 -- reg = expr;
224 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
225
226 -- rep[lv] = expr;
227 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
228 where
229 rep = ppr ( cmmExprRep expr )
230
231 -- call "ccall" foo(x, y)[r1, r2];
232 -- ToDo ppr volatile
233 CmmCall (CmmCallee fn cconv) results args safety ret ->
234 hcat [ if null results
235 then empty
236 else parens (commafy $ map ppr results) <>
237 ptext SLIT(" = "),
238 ptext SLIT("foreign"), space,
239 doubleQuotes(ppr cconv), space,
240 target fn, parens ( commafy $ map ppr args ),
241 brackets (ppr safety),
242 case ret of CmmMayReturn -> empty
243 CmmNeverReturns -> ptext SLIT(" never returns"),
244 semi ]
245 where
246 target (CmmLit lit) = pprLit lit
247 target fn' = parens (ppr fn')
248
249 CmmCall (CmmPrim op) results args safety ret ->
250 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
251 results args safety ret)
252 where
253 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
254
255 CmmBranch ident -> genBranch ident
256 CmmCondBranch expr ident -> genCondBranch expr ident
257 CmmJump expr params -> genJump expr params
258 CmmReturn params -> genReturn params
259 CmmSwitch arg ids -> genSwitch arg ids
260
261 -- --------------------------------------------------------------------------
262 -- goto local label. [1], section 6.6
263 --
264 -- goto lbl;
265 --
266 genBranch :: BlockId -> SDoc
267 genBranch ident =
268 ptext SLIT("goto") <+> pprBlockId ident <> semi
269
270 -- --------------------------------------------------------------------------
271 -- Conditional. [1], section 6.4
272 --
273 -- if (expr) { goto lbl; }
274 --
275 genCondBranch :: CmmExpr -> BlockId -> SDoc
276 genCondBranch expr ident =
277 hsep [ ptext SLIT("if")
278 , parens(ppr expr)
279 , ptext SLIT("goto")
280 , pprBlockId ident <> semi ]
281
282 -- --------------------------------------------------------------------------
283 -- A tail call. [1], Section 6.9
284 --
285 -- jump foo(a, b, c);
286 --
287 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
288 genJump expr args =
289
290 hcat [ ptext SLIT("jump")
291 , space
292 , if isTrivialCmmExpr expr
293 then pprExpr expr
294 else case expr of
295 CmmLoad (CmmReg _) _ -> pprExpr expr
296 _ -> parens (pprExpr expr)
297 , space
298 , parens ( commafy $ map pprHinted args )
299 , semi ]
300
301 pprHinted :: Outputable a => (a, MachHint) -> SDoc
302 pprHinted (a, NoHint) = ppr a
303 pprHinted (a, PtrHint) = quotes(text "address") <+> ppr a
304 pprHinted (a, SignedHint) = quotes(text "signed") <+> ppr a
305 pprHinted (a, FloatHint) = quotes(text "float") <+> ppr a
306
307 -- --------------------------------------------------------------------------
308 -- Return from a function. [1], Section 6.8.2 of version 1.128
309 --
310 -- return (a, b, c);
311 --
312 genReturn :: [(CmmExpr, MachHint)] -> SDoc
313 genReturn args =
314
315 hcat [ ptext SLIT("return")
316 , space
317 , parens ( commafy $ map ppr args )
318 , semi ]
319
320 -- --------------------------------------------------------------------------
321 -- Tabled jump to local label
322 --
323 -- The syntax is from [1], section 6.5
324 --
325 -- switch [0 .. n] (expr) { case ... ; }
326 --
327 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
328 genSwitch expr maybe_ids
329
330 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
331
332 in hang (hcat [ ptext SLIT("switch [0 .. ")
333 , int (length maybe_ids - 1)
334 , ptext SLIT("] ")
335 , if isTrivialCmmExpr expr
336 then pprExpr expr
337 else parens (pprExpr expr)
338 , ptext SLIT(" {")
339 ])
340 4 (vcat ( map caseify pairs )) $$ rbrace
341
342 where
343 snds a b = (snd a) == (snd b)
344
345 caseify :: [(Int,Maybe BlockId)] -> SDoc
346 caseify ixs@((i,Nothing):_)
347 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
348 <> ptext SLIT(" */")
349 caseify as
350 = let (is,ids) = unzip as
351 in hsep [ ptext SLIT("case")
352 , hcat (punctuate comma (map int is))
353 , ptext SLIT(": goto")
354 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
355
356 -- --------------------------------------------------------------------------
357 -- Expressions
358 --
359
360 pprExpr :: CmmExpr -> SDoc
361 pprExpr e
362 = case e of
363 CmmRegOff reg i ->
364 pprExpr (CmmMachOp (MO_Add rep)
365 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
366 where rep = cmmRegRep reg
367 CmmLit lit -> pprLit lit
368 _other -> pprExpr1 e
369
370 -- Here's the precedence table from CmmParse.y:
371 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
372 -- %left '|'
373 -- %left '^'
374 -- %left '&'
375 -- %left '>>' '<<'
376 -- %left '-' '+'
377 -- %left '/' '*' '%'
378 -- %right '~'
379
380 -- We just cope with the common operators for now, the rest will get
381 -- a default conservative behaviour.
382
383 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
384 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
385 = pprExpr7 x <+> doc <+> pprExpr7 y
386 pprExpr1 e = pprExpr7 e
387
388 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
389 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
390 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
391 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
392 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
393 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
394 infixMachOp1 (MO_U_Gt _) = Just (char '>')
395 infixMachOp1 (MO_U_Lt _) = Just (char '<')
396 infixMachOp1 _ = Nothing
397
398 -- %left '-' '+'
399 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
400 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
401 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
402 = pprExpr7 x <+> doc <+> pprExpr8 y
403 pprExpr7 e = pprExpr8 e
404
405 infixMachOp7 (MO_Add _) = Just (char '+')
406 infixMachOp7 (MO_Sub _) = Just (char '-')
407 infixMachOp7 _ = Nothing
408
409 -- %left '/' '*' '%'
410 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
411 = pprExpr8 x <+> doc <+> pprExpr9 y
412 pprExpr8 e = pprExpr9 e
413
414 infixMachOp8 (MO_U_Quot _) = Just (char '/')
415 infixMachOp8 (MO_Mul _) = Just (char '*')
416 infixMachOp8 (MO_U_Rem _) = Just (char '%')
417 infixMachOp8 _ = Nothing
418
419 pprExpr9 :: CmmExpr -> SDoc
420 pprExpr9 e =
421 case e of
422 CmmLit lit -> pprLit1 lit
423 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
424 CmmReg reg -> ppr reg
425 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
426 CmmMachOp mop args -> genMachOp mop args
427
428 genMachOp :: MachOp -> [CmmExpr] -> SDoc
429 genMachOp mop args
430 | Just doc <- infixMachOp mop = case args of
431 -- dyadic
432 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
433
434 -- unary
435 [x] -> doc <> pprExpr9 x
436
437 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
438 (pprMachOp mop <+>
439 parens (hcat $ punctuate comma (map pprExpr args)))
440 empty
441
442 | isJust (infixMachOp1 mop)
443 || isJust (infixMachOp7 mop)
444 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
445
446 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
447 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
448 (show mop))
449 -- replace spaces in (show mop) with underscores,
450
451 --
452 -- Unsigned ops on the word size of the machine get nice symbols.
453 -- All else get dumped in their ugly format.
454 --
455 infixMachOp :: MachOp -> Maybe SDoc
456 infixMachOp mop
457 = case mop of
458 MO_And _ -> Just $ char '&'
459 MO_Or _ -> Just $ char '|'
460 MO_Xor _ -> Just $ char '^'
461 MO_Not _ -> Just $ char '~'
462 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
463 _ -> Nothing
464
465 -- --------------------------------------------------------------------------
466 -- Literals.
467 -- To minimise line noise we adopt the convention that if the literal
468 -- has the natural machine word size, we do not append the type
469 --
470 pprLit :: CmmLit -> SDoc
471 pprLit lit = case lit of
472 CmmInt i rep ->
473 hcat [ (if i < 0 then parens else id)(integer i)
474 , (if rep == wordRep
475 then empty
476 else space <> dcolon <+> ppr rep) ]
477
478 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
479 CmmLabel clbl -> pprCLabel clbl
480 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
481 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
482 <> pprCLabel clbl2 <> ppr_offset i
483
484 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
485 pprLit1 lit = pprLit lit
486
487 ppr_offset :: Int -> SDoc
488 ppr_offset i
489 | i==0 = empty
490 | i>=0 = char '+' <> int i
491 | otherwise = char '-' <> int (-i)
492
493 -- --------------------------------------------------------------------------
494 -- Static data.
495 -- Strings are printed as C strings, and we print them as I8[],
496 -- following C--
497 --
498 pprStatic :: CmmStatic -> SDoc
499 pprStatic s = case s of
500 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
501 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
502 CmmAlign i -> nest 4 $ text "align" <+> int i
503 CmmDataLabel clbl -> pprCLabel clbl <> colon
504 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
505
506 -- --------------------------------------------------------------------------
507 -- Registers, whether local (temps) or global
508 --
509 pprReg :: CmmReg -> SDoc
510 pprReg r
511 = case r of
512 CmmLocal local -> pprLocalReg local
513 CmmGlobal global -> pprGlobalReg global
514
515 --
516 -- We only print the type of the local reg if it isn't wordRep
517 --
518 pprLocalReg :: LocalReg -> SDoc
519 pprLocalReg (LocalReg uniq rep follow)
520 = hcat [ char '_', ppr uniq, ty ] where
521 ty = if rep == wordRep && follow == GCKindNonPtr
522 then empty
523 else dcolon <> ptr <> ppr rep
524 ptr = if follow == GCKindNonPtr
525 then empty
526 else doubleQuotes (text "ptr")
527
528 -- needs to be kept in syn with Cmm.hs.GlobalReg
529 --
530 pprGlobalReg :: GlobalReg -> SDoc
531 pprGlobalReg gr
532 = case gr of
533 VanillaReg n -> char 'R' <> int n
534 FloatReg n -> char 'F' <> int n
535 DoubleReg n -> char 'D' <> int n
536 LongReg n -> char 'L' <> int n
537 Sp -> ptext SLIT("Sp")
538 SpLim -> ptext SLIT("SpLim")
539 Hp -> ptext SLIT("Hp")
540 HpLim -> ptext SLIT("HpLim")
541 CurrentTSO -> ptext SLIT("CurrentTSO")
542 CurrentNursery -> ptext SLIT("CurrentNursery")
543 HpAlloc -> ptext SLIT("HpAlloc")
544 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
545 GCFun -> ptext SLIT("stg_gc_fun")
546 BaseReg -> ptext SLIT("BaseReg")
547 PicBaseReg -> ptext SLIT("PicBaseReg")
548
549 -- --------------------------------------------------------------------------
550 -- data sections
551 --
552 pprSection :: Section -> SDoc
553 pprSection s = case s of
554 Text -> section <+> doubleQuotes (ptext SLIT("text"))
555 Data -> section <+> doubleQuotes (ptext SLIT("data"))
556 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
557 ReadOnlyData16 -> section <+> doubleQuotes (ptext SLIT("readonly16"))
558 RelocatableReadOnlyData
559 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
560 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
561 OtherSection s' -> section <+> doubleQuotes (text s')
562 where
563 section = ptext SLIT("section")
564
565 -- --------------------------------------------------------------------------
566 -- Basic block ids
567 --
568 pprBlockId :: BlockId -> SDoc
569 pprBlockId b = ppr $ getUnique b
570
571 -----------------------------------------------------------------------------
572
573 commafy :: [SDoc] -> SDoc
574 commafy xs = hsep $ punctuate comma xs