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