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