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 import Data.Char
  55
  56 pprCmms :: [Cmm] -> SDoc
  57 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  58         where
  59           separator = space $$ ptext SLIT("-------------------") $$ space
  60
  61 writeCmms :: Handle -> [Cmm] -> IO ()
  62 writeCmms handle cmms = printForC handle (pprCmms cmms)
  63
  64 -----------------------------------------------------------------------------
  65
  66 instance Outputable Cmm where
  67     ppr c = pprCmm c
  68
  69 instance Outputable CmmTop where
  70     ppr t = pprTop t
  71
  72 instance Outputable CmmBasicBlock where
  73     ppr b = pprBBlock b
  74
  75 instance Outputable CmmStmt where
  76     ppr s = pprStmt s
  77
  78 instance Outputable CmmExpr where
  79     ppr e = pprExpr e
  80
  81 instance Outputable CmmReg where
  82     ppr e = pprReg e
  83
  84 instance Outputable GlobalReg where
  85     ppr e = pprGlobalReg e
  86
  87 -----------------------------------------------------------------------------
  88
  89 pprCmm :: Cmm -> SDoc
  90 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
  91
  92 -- --------------------------------------------------------------------------
  93 -- Top level `procedure' blocks. The info tables, if not null, are
  94 -- printed in the style of C--'s 'stackdata' declaration, just inside
  95 -- the proc body, and are labelled with the procedure name ++ "_info".
  96 --
  97 pprTop :: CmmTop -> SDoc
  98 pprTop (CmmProc info lbl params blocks )
  99
 100   = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
 101          , nest 8 $ pprInfo info lbl
 102          , nest 4 $ vcat (map ppr blocks)
 103          , rbrace ]
 104
 105   where
 106     pprInfo [] _  = empty
 107     pprInfo i label =
 108         (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
 109             4 $ vcat (map pprStatic i))
 110         $$ rbrace
 111
 112 -- --------------------------------------------------------------------------
 113 -- We follow [1], 4.5
 114 --
 115 --      section "data" { ... }
 116 --
 117 pprTop (CmmData section ds) =
 118     (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
 119     $$ rbrace
 120
 121
 122 -- --------------------------------------------------------------------------
 123 -- Basic blocks look like assembly blocks.
 124 --      lbl: stmt ; stmt ; ..
 125 pprBBlock :: CmmBasicBlock -> SDoc
 126 pprBBlock (BasicBlock ident stmts) =
 127     hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
 128
 129 -- --------------------------------------------------------------------------
 130 -- Statements. C-- usually, exceptions to this should be obvious.
 131 --
 132 pprStmt :: CmmStmt -> SDoc
 133 pprStmt stmt = case stmt of
 134
 135     -- ;
 136     CmmNop -> semi
 137
 138     --  // text
 139     CmmComment s -> text "//" <+> ftext s
 140
 141     -- reg = expr;
 142     CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 143
 144     -- rep[lv] = expr;
 145     CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 146         where
 147           rep = ppr ( cmmExprRep expr )
 148
 149     -- call "ccall" foo(x, y)[r1, r2];
 150     -- ToDo ppr volatile
 151     CmmCall (CmmForeignCall fn cconv) results args _volatile ->
 152         hcat [ ptext SLIT("call"), space,
 153                doubleQuotes(ppr cconv), space,
 154                target fn, parens  ( commafy $ map ppr args ),
 155                (if null results
 156                     then empty
 157                     else brackets( commafy $ map ppr results)), semi ]
 158         where
 159             target (CmmLit lit) = pprLit lit
 160             target fn'          = parens (ppr fn')
 161
 162     CmmCall (CmmPrim op) results args volatile ->
 163         pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
 164                         results args volatile)
 165         where
 166           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 167
 168     CmmBranch ident          -> genBranch ident
 169     CmmCondBranch expr ident -> genCondBranch expr ident
 170     CmmJump expr params      -> genJump expr params
 171     CmmSwitch arg ids        -> genSwitch arg ids
 172
 173 -- --------------------------------------------------------------------------
 174 -- goto local label. [1], section 6.6
 175 --
 176 --     goto lbl;
 177 --
 178 genBranch :: BlockId -> SDoc
 179 genBranch ident =
 180     ptext SLIT("goto") <+> pprBlockId ident <> semi
 181
 182 -- --------------------------------------------------------------------------
 183 -- Conditional. [1], section 6.4
 184 --
 185 --     if (expr) { goto lbl; }
 186 --
 187 genCondBranch :: CmmExpr -> BlockId -> SDoc
 188 genCondBranch expr ident =
 189     hsep [ ptext SLIT("if")
 190          , parens(ppr expr)
 191          , ptext SLIT("goto")
 192          , pprBlockId ident <> semi ]
 193
 194 -- --------------------------------------------------------------------------
 195 -- A tail call. [1], Section 6.9
 196 --
 197 --     jump foo(a, b, c);
 198 --
 199 genJump :: CmmExpr -> [LocalReg] -> SDoc
 200 genJump expr actuals =
 201
 202     hcat [ ptext SLIT("jump")
 203          , space
 204          , if isTrivialCmmExpr expr
 205                 then pprExpr expr
 206                 else case expr of
 207                     CmmLoad (CmmReg _) _ -> pprExpr expr
 208                     _ -> parens (pprExpr expr)
 209          , pprActuals actuals
 210          , semi ]
 211
 212   where
 213     pprActuals [] = empty
 214     pprActuals as = parens ( commafy $ map pprLocalReg as )
 215
 216 -- --------------------------------------------------------------------------
 217 -- Tabled jump to local label
 218 --
 219 -- The syntax is from [1], section 6.5
 220 --
 221 --      switch [0 .. n] (expr) { case ... ; }
 222 --
 223 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 224 genSwitch expr maybe_ids
 225
 226     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 227
 228       in hang (hcat [ ptext SLIT("switch [0 .. ")
 229                     , int (length maybe_ids - 1)
 230                     , ptext SLIT("] ")
 231                     , if isTrivialCmmExpr expr
 232                         then pprExpr expr
 233                         else parens (pprExpr expr)
 234                     , ptext SLIT(" {")
 235                     ])
 236             4 (vcat ( map caseify pairs )) $$ rbrace
 237
 238     where
 239       snds a b = (snd a) == (snd b)
 240
 241       caseify :: [(Int,Maybe BlockId)] -> SDoc
 242       caseify ixs@((i,Nothing):_)
 243         = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 244                 <> ptext SLIT(" */")
 245       caseify as
 246         = let (is,ids) = unzip as
 247           in hsep [ ptext SLIT("case")
 248                   , hcat (punctuate comma (map int is))
 249                   , ptext SLIT(": goto")
 250                   , pprBlockId (head [ id | Just id <- ids]) <> semi ]
 251
 252 -- --------------------------------------------------------------------------
 253 -- Expressions
 254 --
 255
 256 pprExpr :: CmmExpr -> SDoc
 257 pprExpr e
 258     = case e of
 259         CmmRegOff reg i ->
 260                 pprExpr (CmmMachOp (MO_Add rep)
 261                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 262                 where rep = cmmRegRep reg
 263         CmmLit lit -> pprLit lit
 264         _other     -> pprExpr1 e
 265
 266 -- Here's the precedence table from CmmParse.y:
 267 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 268 -- %left '|'
 269 -- %left '^'
 270 -- %left '&'
 271 -- %left '>>' '<<'
 272 -- %left '-' '+'
 273 -- %left '/' '*' '%'
 274 -- %right '~'
 275
 276 -- We just cope with the common operators for now, the rest will get
 277 -- a default conservative behaviour.
 278
 279 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 280 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 281    = pprExpr7 x <+> doc <+> pprExpr7 y
 282 pprExpr1 e = pprExpr7 e
 283
 284 infixMachOp1 (MO_Eq     _) = Just (ptext SLIT("=="))
 285 infixMachOp1 (MO_Ne     _) = Just (ptext SLIT("!="))
 286 infixMachOp1 (MO_Shl    _) = Just (ptext SLIT("<<"))
 287 infixMachOp1 (MO_U_Shr  _) = Just (ptext SLIT(">>"))
 288 infixMachOp1 (MO_U_Ge   _) = Just (ptext SLIT(">="))
 289 infixMachOp1 (MO_U_Le   _) = Just (ptext SLIT("<="))
 290 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 291 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 292 infixMachOp1 _             = Nothing
 293
 294 -- %left '-' '+'
 295 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 296    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 297 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 298    = pprExpr7 x <+> doc <+> pprExpr8 y
 299 pprExpr7 e = pprExpr8 e
 300
 301 infixMachOp7 (MO_Add _)  = Just (char '+')
 302 infixMachOp7 (MO_Sub _)  = Just (char '-')
 303 infixMachOp7 _           = Nothing
 304
 305 -- %left '/' '*' '%'
 306 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 307    = pprExpr8 x <+> doc <+> pprExpr9 y
 308 pprExpr8 e = pprExpr9 e
 309
 310 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 311 infixMachOp8 (MO_Mul _)    = Just (char '*')
 312 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 313 infixMachOp8 _             = Nothing
 314
 315 pprExpr9 :: CmmExpr -> SDoc
 316 pprExpr9 e =
 317    case e of
 318         CmmLit    lit       -> pprLit1 lit
 319         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 320         CmmReg    reg       -> ppr reg
 321         CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
 322         CmmMachOp mop args  -> genMachOp mop args
 323
 324 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 325 genMachOp mop args
 326    | Just doc <- infixMachOp mop = case args of
 327         -- dyadic
 328         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 329
 330         -- unary
 331         [x]   -> doc <> pprExpr9 x
 332
 333         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 334                           (pprMachOp mop <+>
 335                             parens (hcat $ punctuate comma (map pprExpr args)))
 336                           empty
 337
 338    | isJust (infixMachOp1 mop)
 339    || isJust (infixMachOp7 mop)
 340    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 341
 342    | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
 343
 344 --
 345 -- Unsigned ops on the word size of the machine get nice symbols.
 346 -- All else get dumped in their ugly format.
 347 --
 348 infixMachOp :: MachOp -> Maybe SDoc
 349 infixMachOp mop
 350         = case mop of
 351             MO_And    _ -> Just $ char '&'
 352             MO_Or     _ -> Just $ char '|'
 353             MO_Xor    _ -> Just $ char '^'
 354             MO_Not    _ -> Just $ char '~'
 355             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 356             _ -> Nothing
 357
 358 -- --------------------------------------------------------------------------
 359 -- Literals.
 360 --  To minimise line noise we adopt the convention that if the literal
 361 --  has the natural machine word size, we do not append the type
 362 --
 363 pprLit :: CmmLit -> SDoc
 364 pprLit lit = case lit of
 365     CmmInt i rep ->
 366         hcat [ (if i < 0 then parens else id)(integer i)
 367              , (if rep == wordRep
 368                     then empty
 369                     else space <> dcolon <+> ppr rep) ]
 370
 371     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 372     CmmLabel clbl      -> pprCLabel clbl
 373     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 374     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 375                                   <> pprCLabel clbl2 <> ppr_offset i
 376
 377 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
 378 pprLit1 lit                      = pprLit lit
 379
 380 ppr_offset :: Int -> SDoc
 381 ppr_offset i
 382     | i==0      = empty
 383     | i>=0      = char '+' <> int i
 384     | otherwise = char '-' <> int (-i)
 385
 386 -- --------------------------------------------------------------------------
 387 -- Static data.
 388 --      Strings are printed as C strings, and we print them as I8[],
 389 --      following C--
 390 --
 391 pprStatic :: CmmStatic -> SDoc
 392 pprStatic s = case s of
 393     CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
 394     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 395     CmmAlign i         -> nest 4 $ text "align" <+> int i
 396     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 397     CmmString s'       -> nest 4 $ text "I8[]" <+>
 398                            doubleQuotes (text (map (chr.fromIntegral) s'))
 399
 400 -- --------------------------------------------------------------------------
 401 -- Registers, whether local (temps) or global
 402 --
 403 pprReg :: CmmReg -> SDoc
 404 pprReg r
 405     = case r of
 406         CmmLocal  local  -> pprLocalReg local
 407         CmmGlobal global -> pprGlobalReg global
 408
 409 --
 410 -- We only print the type of the local reg if it isn't wordRep
 411 --
 412 pprLocalReg :: LocalReg -> SDoc
 413 pprLocalReg (LocalReg uniq rep)
 414     = hcat [ char '_', ppr uniq,
 415             (if rep == wordRep
 416                 then empty else dcolon <> ppr rep) ]
 417
 418 -- needs to be kept in syn with Cmm.hs.GlobalReg
 419 --
 420 pprGlobalReg :: GlobalReg -> SDoc
 421 pprGlobalReg gr
 422     = case gr of
 423         VanillaReg n   -> char 'R' <> int n
 424         FloatReg   n   -> char 'F' <> int n
 425         DoubleReg  n   -> char 'D' <> int n
 426         LongReg    n   -> char 'L' <> int n
 427         Sp             -> ptext SLIT("Sp")
 428         SpLim          -> ptext SLIT("SpLim")
 429         Hp             -> ptext SLIT("Hp")
 430         HpLim          -> ptext SLIT("HpLim")
 431         CurrentTSO     -> ptext SLIT("CurrentTSO")
 432         CurrentNursery -> ptext SLIT("CurrentNursery")
 433         HpAlloc        -> ptext SLIT("HpAlloc")
 434         GCEnter1       -> ptext SLIT("stg_gc_enter_1")
 435         GCFun          -> ptext SLIT("stg_gc_fun")
 436         BaseReg        -> ptext SLIT("BaseReg")
 437         PicBaseReg     -> ptext SLIT("PicBaseReg")
 438
 439 -- --------------------------------------------------------------------------
 440 -- data sections
 441 --
 442 pprSection :: Section -> SDoc
 443 pprSection s = case s of
 444     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
 445     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
 446     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
 447     RelocatableReadOnlyData
 448                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
 449     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
 450     OtherSection s'   -> section <+> doubleQuotes (text s')
 451  where
 452     section = ptext SLIT("section")
 453
 454 -- --------------------------------------------------------------------------
 455 -- Basic block ids
 456 --
 457 pprBlockId :: BlockId -> SDoc
 458 pprBlockId b = ppr $ getUnique b
 459
 460 -----------------------------------------------------------------------------
 461
 462 commafy :: [SDoc] -> SDoc
 463 commafy xs = hsep $ punctuate comma xs
 464