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