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     CmmSwitch arg ids        -> genSwitch arg ids
 171
 172 -- --------------------------------------------------------------------------
 173 -- goto local label. [1], section 6.6
 174 --
 175 --     goto lbl;
 176 --
 177 genBranch :: BlockId -> SDoc
 178 genBranch ident =
 179     ptext SLIT("goto") <+> pprBlockId ident <> semi
 180
 181 -- --------------------------------------------------------------------------
 182 -- Conditional. [1], section 6.4
 183 --
 184 --     if (expr) { goto lbl; }
 185 --
 186 genCondBranch :: CmmExpr -> BlockId -> SDoc
 187 genCondBranch expr ident =
 188     hsep [ ptext SLIT("if")
 189          , parens(ppr expr)
 190          , ptext SLIT("goto")
 191          , pprBlockId ident <> semi ]
 192
 193 -- --------------------------------------------------------------------------
 194 -- A tail call. [1], Section 6.9
 195 --
 196 --     jump foo(a, b, c);
 197 --
 198 genJump :: CmmExpr -> [LocalReg] -> SDoc
 199 genJump expr actuals =
 200
 201     hcat [ ptext SLIT("jump")
 202          , space
 203          , if isTrivialCmmExpr expr
 204                 then pprExpr expr
 205                 else case expr of
 206                     CmmLoad (CmmReg _) _ -> pprExpr expr
 207                     _ -> parens (pprExpr expr)
 208          , pprActuals actuals
 209          , semi ]
 210
 211   where
 212     pprActuals [] = empty
 213     pprActuals as = parens ( commafy $ map pprLocalReg as )
 214
 215 -- --------------------------------------------------------------------------
 216 -- Tabled jump to local label
 217 --
 218 -- The syntax is from [1], section 6.5
 219 --
 220 --      switch [0 .. n] (expr) { case ... ; }
 221 --
 222 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 223 genSwitch expr maybe_ids
 224
 225     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 226
 227       in hang (hcat [ ptext SLIT("switch [0 .. ")
 228                     , int (length maybe_ids - 1)
 229                     , ptext SLIT("] ")
 230                     , if isTrivialCmmExpr expr
 231                         then pprExpr expr
 232                         else parens (pprExpr expr)
 233                     , ptext SLIT(" {")
 234                     ])
 235             4 (vcat ( map caseify pairs )) $$ rbrace
 236
 237     where
 238       snds a b = (snd a) == (snd b)
 239
 240       caseify :: [(Int,Maybe BlockId)] -> SDoc
 241       caseify ixs@((i,Nothing):_)
 242         = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 243                 <> ptext SLIT(" */")
 244       caseify as
 245         = let (is,ids) = unzip as
 246           in hsep [ ptext SLIT("case")
 247                   , hcat (punctuate comma (map int is))
 248                   , ptext SLIT(": goto")
 249                   , pprBlockId (head [ id | Just id <- ids]) <> semi ]
 250
 251 -- --------------------------------------------------------------------------
 252 -- Expressions
 253 --
 254
 255 pprExpr :: CmmExpr -> SDoc
 256 pprExpr e
 257     = case e of
 258         CmmRegOff reg i ->
 259                 pprExpr (CmmMachOp (MO_Add rep)
 260                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 261                 where rep = cmmRegRep reg
 262         CmmLit lit -> pprLit lit
 263         _other     -> pprExpr1 e
 264
 265 -- Here's the precedence table from CmmParse.y:
 266 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 267 -- %left '|'
 268 -- %left '^'
 269 -- %left '&'
 270 -- %left '>>' '<<'
 271 -- %left '-' '+'
 272 -- %left '/' '*' '%'
 273 -- %right '~'
 274
 275 -- We just cope with the common operators for now, the rest will get
 276 -- a default conservative behaviour.
 277
 278 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 279 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 280    = pprExpr7 x <+> doc <+> pprExpr7 y
 281 pprExpr1 e = pprExpr7 e
 282
 283 infixMachOp1 (MO_Eq     _) = Just (ptext SLIT("=="))
 284 infixMachOp1 (MO_Ne     _) = Just (ptext SLIT("!="))
 285 infixMachOp1 (MO_Shl    _) = Just (ptext SLIT("<<"))
 286 infixMachOp1 (MO_U_Shr  _) = Just (ptext SLIT(">>"))
 287 infixMachOp1 (MO_U_Ge   _) = Just (ptext SLIT(">="))
 288 infixMachOp1 (MO_U_Le   _) = Just (ptext SLIT("<="))
 289 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 290 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 291 infixMachOp1 _             = Nothing
 292
 293 -- %left '-' '+'
 294 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 295    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 296 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 297    = pprExpr7 x <+> doc <+> pprExpr8 y
 298 pprExpr7 e = pprExpr8 e
 299
 300 infixMachOp7 (MO_Add _)  = Just (char '+')
 301 infixMachOp7 (MO_Sub _)  = Just (char '-')
 302 infixMachOp7 _           = Nothing
 303
 304 -- %left '/' '*' '%'
 305 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 306    = pprExpr8 x <+> doc <+> pprExpr9 y
 307 pprExpr8 e = pprExpr9 e
 308
 309 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 310 infixMachOp8 (MO_Mul _)    = Just (char '*')
 311 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 312 infixMachOp8 _             = Nothing
 313
 314 pprExpr9 :: CmmExpr -> SDoc
 315 pprExpr9 e =
 316    case e of
 317         CmmLit    lit       -> pprLit1 lit
 318         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 319         CmmReg    reg       -> ppr reg
 320         CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
 321         CmmMachOp mop args  -> genMachOp mop args
 322
 323 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 324 genMachOp mop args
 325    | Just doc <- infixMachOp mop = case args of
 326         -- dyadic
 327         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 328
 329         -- unary
 330         [x]   -> doc <> pprExpr9 x
 331
 332         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 333                           (pprMachOp mop <+>
 334                             parens (hcat $ punctuate comma (map pprExpr args)))
 335                           empty
 336
 337    | isJust (infixMachOp1 mop)
 338    || isJust (infixMachOp7 mop)
 339    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 340
 341    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 342         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 343                                  (show mop))
 344                 -- replace spaces in (show mop) with underscores,
 345
 346 --
 347 -- Unsigned ops on the word size of the machine get nice symbols.
 348 -- All else get dumped in their ugly format.
 349 --
 350 infixMachOp :: MachOp -> Maybe SDoc
 351 infixMachOp mop
 352         = case mop of
 353             MO_And    _ -> Just $ char '&'
 354             MO_Or     _ -> Just $ char '|'
 355             MO_Xor    _ -> Just $ char '^'
 356             MO_Not    _ -> Just $ char '~'
 357             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 358             _ -> Nothing
 359
 360 -- --------------------------------------------------------------------------
 361 -- Literals.
 362 --  To minimise line noise we adopt the convention that if the literal
 363 --  has the natural machine word size, we do not append the type
 364 --
 365 pprLit :: CmmLit -> SDoc
 366 pprLit lit = case lit of
 367     CmmInt i rep ->
 368         hcat [ (if i < 0 then parens else id)(integer i)
 369              , (if rep == wordRep
 370                     then empty
 371                     else space <> dcolon <+> ppr rep) ]
 372
 373     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 374     CmmLabel clbl      -> pprCLabel clbl
 375     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 376     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 377                                   <> pprCLabel clbl2 <> ppr_offset i
 378
 379 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
 380 pprLit1 lit                      = pprLit lit
 381
 382 ppr_offset :: Int -> SDoc
 383 ppr_offset i
 384     | i==0      = empty
 385     | i>=0      = char '+' <> int i
 386     | otherwise = char '-' <> int (-i)
 387
 388 -- --------------------------------------------------------------------------
 389 -- Static data.
 390 --      Strings are printed as C strings, and we print them as I8[],
 391 --      following C--
 392 --
 393 pprStatic :: CmmStatic -> SDoc
 394 pprStatic s = case s of
 395     CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
 396     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 397     CmmAlign i         -> nest 4 $ text "align" <+> int i
 398     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 399     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 400
 401 -- --------------------------------------------------------------------------
 402 -- Registers, whether local (temps) or global
 403 --
 404 pprReg :: CmmReg -> SDoc
 405 pprReg r
 406     = case r of
 407         CmmLocal  local  -> pprLocalReg local
 408         CmmGlobal global -> pprGlobalReg global
 409
 410 --
 411 -- We only print the type of the local reg if it isn't wordRep
 412 --
 413 pprLocalReg :: LocalReg -> SDoc
 414 pprLocalReg (LocalReg uniq rep)
 415     = hcat [ char '_', ppr uniq,
 416             (if rep == wordRep
 417                 then empty else dcolon <> ppr rep) ]
 418
 419 -- needs to be kept in syn with Cmm.hs.GlobalReg
 420 --
 421 pprGlobalReg :: GlobalReg -> SDoc
 422 pprGlobalReg gr
 423     = case gr of
 424         VanillaReg n   -> char 'R' <> int n
 425         FloatReg   n   -> char 'F' <> int n
 426         DoubleReg  n   -> char 'D' <> int n
 427         LongReg    n   -> char 'L' <> int n
 428         Sp             -> ptext SLIT("Sp")
 429         SpLim          -> ptext SLIT("SpLim")
 430         Hp             -> ptext SLIT("Hp")
 431         HpLim          -> ptext SLIT("HpLim")
 432         CurrentTSO     -> ptext SLIT("CurrentTSO")
 433         CurrentNursery -> ptext SLIT("CurrentNursery")
 434         HpAlloc        -> ptext SLIT("HpAlloc")
 435         GCEnter1       -> ptext SLIT("stg_gc_enter_1")
 436         GCFun          -> ptext SLIT("stg_gc_fun")
 437         BaseReg        -> ptext SLIT("BaseReg")
 438         PicBaseReg     -> ptext SLIT("PicBaseReg")
 439
 440 -- --------------------------------------------------------------------------
 441 -- data sections
 442 --
 443 pprSection :: Section -> SDoc
 444 pprSection s = case s of
 445     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
 446     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
 447     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
 448     RelocatableReadOnlyData
 449                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
 450     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
 451     OtherSection s'   -> section <+> doubleQuotes (text s')
 452  where
 453     section = ptext SLIT("section")
 454
 455 -- --------------------------------------------------------------------------
 456 -- Basic block ids
 457 --
 458 pprBlockId :: BlockId -> SDoc
 459 pprBlockId b = ppr $ getUnique b
 460
 461 -----------------------------------------------------------------------------
 462
 463 commafy :: [SDoc] -> SDoc
 464 commafy xs = hsep $ punctuate comma xs
 465