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