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 op [x,y]) | Just doc <- infixMachOp7 op
 296    = pprExpr7 x <+> doc <+> pprExpr8 y
 297 pprExpr7 e = pprExpr8 e
 298
 299 infixMachOp7 (MO_Add _)  = Just (char '+')
 300 infixMachOp7 (MO_Sub _)  = Just (char '-')
 301 infixMachOp7 _           = Nothing
 302
 303 -- %left '/' '*' '%'
 304 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 305    = pprExpr8 x <+> doc <+> pprExpr9 y
 306 pprExpr8 e = pprExpr9 e
 307
 308 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 309 infixMachOp8 (MO_Mul _)    = Just (char '*')
 310 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 311 infixMachOp8 _             = Nothing
 312
 313 pprExpr9 :: CmmExpr -> SDoc
 314 pprExpr9 e =
 315    case e of
 316         CmmLit    lit       -> pprLit1 lit
 317         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 318         CmmReg    reg       -> ppr reg
 319         CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
 320         CmmMachOp mop args  -> genMachOp mop args
 321
 322 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 323 genMachOp mop args
 324    | Just doc <- infixMachOp mop = case args of
 325         -- dyadic
 326         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 327
 328         -- unary
 329         [x]   -> doc <> pprExpr9 x
 330
 331         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 332                           (pprMachOp mop <+>
 333                             parens (hcat $ punctuate comma (map pprExpr args)))
 334                           empty
 335
 336    | isJust (infixMachOp1 mop)
 337    || isJust (infixMachOp7 mop)
 338    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 339
 340    | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
 341
 342 --
 343 -- Unsigned ops on the word size of the machine get nice symbols.
 344 -- All else get dumped in their ugly format.
 345 --
 346 infixMachOp :: MachOp -> Maybe SDoc
 347 infixMachOp mop
 348         = case mop of
 349             MO_And    _ -> Just $ char '&'
 350             MO_Or     _ -> Just $ char '|'
 351             MO_Xor    _ -> Just $ char '^'
 352             MO_Not    _ -> Just $ char '~'
 353             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 354             _ -> Nothing
 355
 356 -- --------------------------------------------------------------------------
 357 -- Literals.
 358 --  To minimise line noise we adopt the convention that if the literal
 359 --  has the natural machine word size, we do not append the type
 360 --
 361 pprLit :: CmmLit -> SDoc
 362 pprLit lit = case lit of
 363     CmmInt i rep ->
 364         hcat [ (if i < 0 then parens else id)(integer i)
 365              , (if rep == wordRep
 366                     then empty
 367                     else space <> dcolon <+> ppr rep) ]
 368
 369     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 370     CmmLabel clbl      -> pprCLabel clbl
 371     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 372     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 373                                   <> pprCLabel clbl2 <> ppr_offset i
 374
 375 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
 376 pprLit1 lit                      = pprLit lit
 377
 378 ppr_offset :: Int -> SDoc
 379 ppr_offset i
 380     | i==0      = empty
 381     | i>=0      = char '+' <> int i
 382     | otherwise = char '-' <> int (-i)
 383
 384 -- --------------------------------------------------------------------------
 385 -- Static data.
 386 --      Strings are printed as C strings, and we print them as I8[],
 387 --      following C--
 388 --
 389 pprStatic :: CmmStatic -> SDoc
 390 pprStatic s = case s of
 391     CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
 392     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 393     CmmAlign i         -> nest 4 $ text "align" <+> int i
 394     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 395     CmmString s'       -> nest 4 $ text "I8[]" <+>
 396                            doubleQuotes (text (map (chr.fromIntegral) s'))
 397
 398 -- --------------------------------------------------------------------------
 399 -- Registers, whether local (temps) or global
 400 --
 401 pprReg :: CmmReg -> SDoc
 402 pprReg r
 403     = case r of
 404         CmmLocal  local  -> pprLocalReg local
 405         CmmGlobal global -> pprGlobalReg global
 406
 407 --
 408 -- We only print the type of the local reg if it isn't wordRep
 409 --
 410 pprLocalReg :: LocalReg -> SDoc
 411 pprLocalReg (LocalReg uniq rep)
 412     = hcat [ char '_', ppr uniq,
 413             (if rep == wordRep
 414                 then empty else dcolon <> ppr rep) ]
 415
 416 -- needs to be kept in syn with Cmm.hs.GlobalReg
 417 --
 418 pprGlobalReg :: GlobalReg -> SDoc
 419 pprGlobalReg gr
 420     = case gr of
 421         VanillaReg n   -> char 'R' <> int n
 422         FloatReg   n   -> char 'F' <> int n
 423         DoubleReg  n   -> char 'D' <> int n
 424         LongReg    n   -> char 'L' <> int n
 425         Sp             -> ptext SLIT("Sp")
 426         SpLim          -> ptext SLIT("SpLim")
 427         Hp             -> ptext SLIT("Hp")
 428         HpLim          -> ptext SLIT("HpLim")
 429         CurrentTSO     -> ptext SLIT("CurrentTSO")
 430         CurrentNursery -> ptext SLIT("CurrentNursery")
 431         HpAlloc        -> ptext SLIT("HpAlloc")
 432         GCEnter1       -> ptext SLIT("stg_gc_enter_1")
 433         GCFun          -> ptext SLIT("stg_gc_fun")
 434         BaseReg        -> ptext SLIT("BaseReg")
 435         PicBaseReg     -> ptext SLIT("PicBaseReg")
 436
 437 -- --------------------------------------------------------------------------
 438 -- data sections
 439 --
 440 pprSection :: Section -> SDoc
 441 pprSection s = case s of
 442     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
 443     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
 444     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
 445     RelocatableReadOnlyData
 446                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
 447     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
 448     OtherSection s'   -> section <+> doubleQuotes (text s')
 449  where
 450     section = ptext SLIT("section")
 451
 452 -- --------------------------------------------------------------------------
 453 -- Basic block ids
 454 --
 455 pprBlockId :: BlockId -> SDoc
 456 pprBlockId b = ppr $ getUnique b
 457
 458 -----------------------------------------------------------------------------
 459
 460 commafy :: [SDoc] -> SDoc
 461 commafy xs = hsep $ punctuate comma xs
 462