compiler/cmm/PprCmm.hs

   1 ----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing of Cmm as (a superset of) C--
   4 --
   5 -- (c) The University of Glasgow 2004
   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     ( isTrivialCmmExpr )
  43 import MachOp       ( MachOp(..), pprMachOp, MachRep(..), wordRep )
  44 import CLabel       ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
  45
  46 import ForeignCall  ( CCallConv(..) )
  47 import Unique       ( getUnique )
  48 import Outputable
  49 import FastString   ( mkFastString )
  50
  51 import Data.List    ( intersperse, groupBy )
  52 import IO           ( Handle )
  53 import Maybe        ( isJust )
  54 import Data.Char    ( chr )
  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