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 '%' <> ppr_op <> parens (commafy (map pprExpr args))
 343         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 344                                  (show mop))
 345                 -- replace spaces in (show mop) with underscores,
 346
 347 --
 348 -- Unsigned ops on the word size of the machine get nice symbols.
 349 -- All else get dumped in their ugly format.
 350 --
 351 infixMachOp :: MachOp -> Maybe SDoc
 352 infixMachOp mop
 353         = case mop of
 354             MO_And    _ -> Just $ char '&'
 355             MO_Or     _ -> Just $ char '|'
 356             MO_Xor    _ -> Just $ char '^'
 357             MO_Not    _ -> Just $ char '~'
 358             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 359             _ -> Nothing
 360
 361 -- --------------------------------------------------------------------------
 362 -- Literals.
 363 --  To minimise line noise we adopt the convention that if the literal
 364 --  has the natural machine word size, we do not append the type
 365 --
 366 pprLit :: CmmLit -> SDoc
 367 pprLit lit = case lit of
 368     CmmInt i rep ->
 369         hcat [ (if i < 0 then parens else id)(integer i)
 370              , (if rep == wordRep
 371                     then empty
 372                     else space <> dcolon <+> ppr rep) ]
 373
 374     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 375     CmmLabel clbl      -> pprCLabel clbl
 376     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 377     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 378                                   <> pprCLabel clbl2 <> ppr_offset i
 379
 380 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
 381 pprLit1 lit                      = pprLit lit
 382
 383 ppr_offset :: Int -> SDoc
 384 ppr_offset i
 385     | i==0      = empty
 386     | i>=0      = char '+' <> int i
 387     | otherwise = char '-' <> int (-i)
 388
 389 -- --------------------------------------------------------------------------
 390 -- Static data.
 391 --      Strings are printed as C strings, and we print them as I8[],
 392 --      following C--
 393 --
 394 pprStatic :: CmmStatic -> SDoc
 395 pprStatic s = case s of
 396     CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
 397     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 398     CmmAlign i         -> nest 4 $ text "align" <+> int i
 399     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 400     CmmString s'       -> nest 4 $ text "I8[]" <+>
 401                            doubleQuotes (text (map (chr.fromIntegral) s'))
 402
 403 -- --------------------------------------------------------------------------
 404 -- Registers, whether local (temps) or global
 405 --
 406 pprReg :: CmmReg -> SDoc
 407 pprReg r
 408     = case r of
 409         CmmLocal  local  -> pprLocalReg local
 410         CmmGlobal global -> pprGlobalReg global
 411
 412 --
 413 -- We only print the type of the local reg if it isn't wordRep
 414 --
 415 pprLocalReg :: LocalReg -> SDoc
 416 pprLocalReg (LocalReg uniq rep)
 417     = hcat [ char '_', ppr uniq,
 418             (if rep == wordRep
 419                 then empty else dcolon <> ppr rep) ]
 420
 421 -- needs to be kept in syn with Cmm.hs.GlobalReg
 422 --
 423 pprGlobalReg :: GlobalReg -> SDoc
 424 pprGlobalReg gr
 425     = case gr of
 426         VanillaReg n   -> char 'R' <> int n
 427         FloatReg   n   -> char 'F' <> int n
 428         DoubleReg  n   -> char 'D' <> int n
 429         LongReg    n   -> char 'L' <> int n
 430         Sp             -> ptext SLIT("Sp")
 431         SpLim          -> ptext SLIT("SpLim")
 432         Hp             -> ptext SLIT("Hp")
 433         HpLim          -> ptext SLIT("HpLim")
 434         CurrentTSO     -> ptext SLIT("CurrentTSO")
 435         CurrentNursery -> ptext SLIT("CurrentNursery")
 436         HpAlloc        -> ptext SLIT("HpAlloc")
 437         GCEnter1       -> ptext SLIT("stg_gc_enter_1")
 438         GCFun          -> ptext SLIT("stg_gc_fun")
 439         BaseReg        -> ptext SLIT("BaseReg")
 440         PicBaseReg     -> ptext SLIT("PicBaseReg")
 441
 442 -- --------------------------------------------------------------------------
 443 -- data sections
 444 --
 445 pprSection :: Section -> SDoc
 446 pprSection s = case s of
 447     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
 448     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
 449     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
 450     RelocatableReadOnlyData
 451                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
 452     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
 453     OtherSection s'   -> section <+> doubleQuotes (text s')
 454  where
 455     section = ptext SLIT("section")
 456
 457 -- --------------------------------------------------------------------------
 458 -- Basic block ids
 459 --
 460 pprBlockId :: BlockId -> SDoc
 461 pprBlockId b = ppr $ getUnique b
 462
 463 -----------------------------------------------------------------------------
 464
 465 commafy :: [SDoc] -> SDoc
 466 commafy xs = hsep $ punctuate comma xs
 467