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