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