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