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