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       pprSection, pprStatic, pprLit
  38     )
  39 where
  40
  41 import BlockId
  42 import Cmm
  43 import CmmUtils
  44 import CLabel
  45 import BasicTypes
  46
  47
  48 import ForeignCall
  49 import Outputable
  50 import FastString
  51
  52 import Data.List
  53 import System.IO
  54 import Data.Maybe
  55
  56 -- Temp Jan08
  57 import SMRep
  58 import ClosureInfo
  59 #include "../includes/rts/storage/FunTypes.h"
  60
  61
  62 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
  63 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  64         where
  65           separator = space $$ ptext (sLit "-------------------") $$ space
  66
  67 writeCmms :: Handle -> [Cmm] -> IO ()
  68 writeCmms handle cmms = printForC handle (pprCmms cmms)
  69
  70 -----------------------------------------------------------------------------
  71
  72 instance (Outputable d, Outputable info, Outputable g)
  73     => Outputable (GenCmm d info g) where
  74     ppr c = pprCmm c
  75
  76 instance (Outputable d, Outputable info, Outputable i)
  77         => Outputable (GenCmmTop d info i) where
  78     ppr t = pprTop t
  79
  80 instance (Outputable instr) => Outputable (ListGraph instr) where
  81     ppr (ListGraph blocks) = vcat (map ppr blocks)
  82
  83 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
  84     ppr b = pprBBlock b
  85
  86 instance Outputable CmmStmt where
  87     ppr s = pprStmt s
  88
  89 instance Outputable CmmExpr where
  90     ppr e = pprExpr e
  91
  92 instance Outputable CmmReg where
  93     ppr e = pprReg e
  94
  95 instance Outputable CmmLit where
  96     ppr l = pprLit l
  97
  98 instance Outputable LocalReg where
  99     ppr e = pprLocalReg e
 100
 101 instance Outputable Area where
 102     ppr e = pprArea e
 103
 104 instance Outputable GlobalReg where
 105     ppr e = pprGlobalReg e
 106
 107 instance Outputable CmmStatic where
 108     ppr e = pprStatic e
 109
 110 instance Outputable CmmInfo where
 111     ppr e = pprInfo e
 112
 113
 114
 115 -----------------------------------------------------------------------------
 116
 117 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
 118 pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
 119
 120 -- --------------------------------------------------------------------------
 121 -- Top level `procedure' blocks.
 122 --
 123 pprTop  :: (Outputable d, Outputable info, Outputable i)
 124         => GenCmmTop d info i -> SDoc
 125
 126 pprTop (CmmProc info lbl params graph )
 127
 128   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
 129          , nest 8 $ lbrace <+> ppr info $$ rbrace
 130          , nest 4 $ ppr graph
 131          , rbrace ]
 132
 133 -- --------------------------------------------------------------------------
 134 -- We follow [1], 4.5
 135 --
 136 --      section "data" { ... }
 137 --
 138 pprTop (CmmData section ds) =
 139     (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
 140     $$ rbrace
 141
 142 -- --------------------------------------------------------------------------
 143 instance Outputable CmmSafety where
 144   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
 145   ppr (CmmSafe srt) = ppr srt
 146
 147 -- --------------------------------------------------------------------------
 148 -- Info tables. The current pretty printer needs refinement
 149 -- but will work for now.
 150 --
 151 -- For ideas on how to refine it, they used to be printed in the
 152 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 153 -- and were labelled with the procedure name ++ "_info".
 154 pprInfo :: CmmInfo -> SDoc
 155 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
 156     vcat [{-ptext (sLit "gc_target: ") <>
 157                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
 158           ptext (sLit "update_frame: ") <>
 159                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
 160 pprInfo (CmmInfo _gc_target update_frame
 161          (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
 162     vcat [{-ptext (sLit "gc_target: ") <>
 163                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
 164           ptext (sLit "has static closure: ") <> ppr stat_clos <+>
 165           ptext (sLit "update_frame: ") <>
 166                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
 167           ptext (sLit "type: ") <> pprLit closure_type,
 168           ptext (sLit "desc: ") <> pprLit closure_desc,
 169           ptext (sLit "tag: ") <> integer (toInteger tag),
 170           pprTypeInfo info]
 171
 172 pprTypeInfo :: ClosureTypeInfo -> SDoc
 173 pprTypeInfo (ConstrInfo layout constr descr) =
 174     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 175           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 176           ptext (sLit "constructor: ") <> integer (toInteger constr),
 177           pprLit descr]
 178 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
 179     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 180           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 181           ptext (sLit "srt: ") <> ppr srt,
 182 -- Temp Jan08
 183           ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
 184
 185           ptext (sLit "arity: ") <> integer (toInteger arity),
 186           --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
 187           ptext (sLit "slow: ") <> pprLit slow_entry
 188          ]
 189 pprTypeInfo (ThunkInfo layout srt) =
 190     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 191           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 192           ptext (sLit "srt: ") <> ppr srt]
 193 pprTypeInfo (ThunkSelectorInfo offset srt) =
 194     vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
 195           ptext (sLit "srt: ") <> ppr srt]
 196 pprTypeInfo (ContInfo stack srt) =
 197     vcat [ptext (sLit "stack: ") <> ppr stack,
 198           ptext (sLit "srt: ") <> ppr srt]
 199
 200 -- Temp Jan08
 201 argDescrType :: ArgDescr -> StgHalfWord
 202 -- The "argument type" RTS field type
 203 argDescrType (ArgSpec n) = n
 204 argDescrType (ArgGen liveness)
 205   | isBigLiveness liveness = ARG_GEN_BIG
 206   | otherwise              = ARG_GEN
 207
 208 -- Temp Jan08
 209 isBigLiveness :: Liveness -> Bool
 210 isBigLiveness (BigLiveness _)   = True
 211 isBigLiveness (SmallLiveness _) = False
 212
 213
 214 pprUpdateFrame :: UpdateFrame -> SDoc
 215 pprUpdateFrame (UpdateFrame expr args) =
 216     hcat [ ptext (sLit "jump")
 217          , space
 218          , if isTrivialCmmExpr expr
 219                 then pprExpr expr
 220                 else case expr of
 221                     CmmLoad (CmmReg _) _ -> pprExpr expr
 222                     _ -> parens (pprExpr expr)
 223          , space
 224          , parens  ( commafy $ map ppr args ) ]
 225
 226
 227 -- --------------------------------------------------------------------------
 228 -- Basic blocks look like assembly blocks.
 229 --      lbl: stmt ; stmt ; ..
 230 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 231 pprBBlock (BasicBlock ident stmts) =
 232     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
 233
 234 -- --------------------------------------------------------------------------
 235 -- Statements. C-- usually, exceptions to this should be obvious.
 236 --
 237 pprStmt :: CmmStmt -> SDoc
 238 pprStmt stmt = case stmt of
 239
 240     -- ;
 241     CmmNop -> semi
 242
 243     --  // text
 244     CmmComment s -> text "//" <+> ftext s
 245
 246     -- reg = expr;
 247     CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 248
 249     -- rep[lv] = expr;
 250     CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 251         where
 252           rep = ppr ( cmmExprType expr )
 253
 254     -- call "ccall" foo(x, y)[r1, r2];
 255     -- ToDo ppr volatile
 256     CmmCall (CmmCallee fn cconv) results args safety ret ->
 257         sep  [ pp_lhs <+> pp_conv
 258              , nest 2 (pprExpr9 fn <>
 259                        parens (commafy (map ppr_ar args)))
 260                <> brackets (ppr safety)
 261              , case ret of CmmMayReturn -> empty
 262                            CmmNeverReturns -> ptext $ sLit (" never returns")
 263              ] <> semi
 264         where
 265           pp_lhs | null results = empty
 266                  | otherwise    = commafy (map ppr_ar results) <+> equals
 267                 -- Don't print the hints on a native C-- call
 268
 269           ppr_ar :: Outputable a => CmmHinted a -> SDoc
 270           ppr_ar (CmmHinted ar k) = case cconv of
 271                             CmmCallConv -> ppr ar
 272                             _           -> ppr (ar,k)
 273           pp_conv = case cconv of
 274                       CmmCallConv -> empty
 275                       _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
 276
 277     -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
 278     CmmCall (CmmPrim op) results args safety ret ->
 279         pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
 280                         results args safety ret)
 281         where
 282           -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
 283           --       use one to get the label printed.
 284           lbl = CmmLabel (mkForeignLabel
 285                                 (mkFastString (show op))
 286                                 Nothing ForeignLabelInThisPackage IsFunction)
 287
 288     CmmBranch ident          -> genBranch ident
 289     CmmCondBranch expr ident -> genCondBranch expr ident
 290     CmmJump expr params      -> genJump expr params
 291     CmmReturn params         -> genReturn params
 292     CmmSwitch arg ids        -> genSwitch arg ids
 293
 294 instance Outputable ForeignHint where
 295   ppr NoHint     = empty
 296   ppr SignedHint = quotes(text "signed")
 297 --  ppr AddrHint   = quotes(text "address")
 298 -- Temp Jan08
 299   ppr AddrHint   = (text "PtrHint")
 300
 301 -- Just look like a tuple, since it was a tuple before
 302 -- ... is that a good idea? --Isaac Dupree
 303 instance (Outputable a) => Outputable (CmmHinted a) where
 304   ppr (CmmHinted a k) = ppr (a, k)
 305
 306 -- --------------------------------------------------------------------------
 307 -- goto local label. [1], section 6.6
 308 --
 309 --     goto lbl;
 310 --
 311 genBranch :: BlockId -> SDoc
 312 genBranch ident =
 313     ptext (sLit "goto") <+> ppr ident <> semi
 314
 315 -- --------------------------------------------------------------------------
 316 -- Conditional. [1], section 6.4
 317 --
 318 --     if (expr) { goto lbl; }
 319 --
 320 genCondBranch :: CmmExpr -> BlockId -> SDoc
 321 genCondBranch expr ident =
 322     hsep [ ptext (sLit "if")
 323          , parens(ppr expr)
 324          , ptext (sLit "goto")
 325          , ppr ident <> semi ]
 326
 327 -- --------------------------------------------------------------------------
 328 -- A tail call. [1], Section 6.9
 329 --
 330 --     jump foo(a, b, c);
 331 --
 332 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
 333 genJump expr args =
 334     hcat [ ptext (sLit "jump")
 335          , space
 336          , if isTrivialCmmExpr expr
 337                 then pprExpr expr
 338                 else case expr of
 339                     CmmLoad (CmmReg _) _ -> pprExpr expr
 340                     _ -> parens (pprExpr expr)
 341          , space
 342          , parens  ( commafy $ map ppr args )
 343          , semi ]
 344
 345
 346 -- --------------------------------------------------------------------------
 347 -- Return from a function. [1], Section 6.8.2 of version 1.128
 348 --
 349 --     return (a, b, c);
 350 --
 351 genReturn :: [CmmHinted CmmExpr] -> SDoc
 352 genReturn args =
 353     hcat [ ptext (sLit "return")
 354          , space
 355          , parens  ( commafy $ map ppr args )
 356          , semi ]
 357
 358 -- --------------------------------------------------------------------------
 359 -- Tabled jump to local label
 360 --
 361 -- The syntax is from [1], section 6.5
 362 --
 363 --      switch [0 .. n] (expr) { case ... ; }
 364 --
 365 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 366 genSwitch expr maybe_ids
 367
 368     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 369
 370       in hang (hcat [ ptext (sLit "switch [0 .. ")
 371                     , int (length maybe_ids - 1)
 372                     , ptext (sLit "] ")
 373                     , if isTrivialCmmExpr expr
 374                         then pprExpr expr
 375                         else parens (pprExpr expr)
 376                     , ptext (sLit " {")
 377                     ])
 378             4 (vcat ( map caseify pairs )) $$ rbrace
 379
 380     where
 381       snds a b = (snd a) == (snd b)
 382
 383       caseify :: [(Int,Maybe BlockId)] -> SDoc
 384       caseify ixs@((_,Nothing):_)
 385         = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 386                 <> ptext (sLit " */")
 387       caseify as
 388         = let (is,ids) = unzip as
 389           in hsep [ ptext (sLit "case")
 390                   , hcat (punctuate comma (map int is))
 391                   , ptext (sLit ": goto")
 392                   , ppr (head [ id | Just id <- ids]) <> semi ]
 393
 394 -- --------------------------------------------------------------------------
 395 -- Expressions
 396 --
 397
 398 pprExpr :: CmmExpr -> SDoc
 399 pprExpr e
 400     = case e of
 401         CmmRegOff reg i ->
 402                 pprExpr (CmmMachOp (MO_Add rep)
 403                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 404                 where rep = typeWidth (cmmRegType reg)
 405         CmmLit lit -> pprLit lit
 406         _other     -> pprExpr1 e
 407
 408 -- Here's the precedence table from CmmParse.y:
 409 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 410 -- %left '|'
 411 -- %left '^'
 412 -- %left '&'
 413 -- %left '>>' '<<'
 414 -- %left '-' '+'
 415 -- %left '/' '*' '%'
 416 -- %right '~'
 417
 418 -- We just cope with the common operators for now, the rest will get
 419 -- a default conservative behaviour.
 420
 421 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 422 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
 423 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 424    = pprExpr7 x <+> doc <+> pprExpr7 y
 425 pprExpr1 e = pprExpr7 e
 426
 427 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
 428
 429 infixMachOp1 (MO_Eq     _) = Just (ptext (sLit "=="))
 430 infixMachOp1 (MO_Ne     _) = Just (ptext (sLit "!="))
 431 infixMachOp1 (MO_Shl    _) = Just (ptext (sLit "<<"))
 432 infixMachOp1 (MO_U_Shr  _) = Just (ptext (sLit ">>"))
 433 infixMachOp1 (MO_U_Ge   _) = Just (ptext (sLit ">="))
 434 infixMachOp1 (MO_U_Le   _) = Just (ptext (sLit "<="))
 435 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 436 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 437 infixMachOp1 _             = Nothing
 438
 439 -- %left '-' '+'
 440 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 441    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 442 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 443    = pprExpr7 x <+> doc <+> pprExpr8 y
 444 pprExpr7 e = pprExpr8 e
 445
 446 infixMachOp7 (MO_Add _)  = Just (char '+')
 447 infixMachOp7 (MO_Sub _)  = Just (char '-')
 448 infixMachOp7 _           = Nothing
 449
 450 -- %left '/' '*' '%'
 451 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 452    = pprExpr8 x <+> doc <+> pprExpr9 y
 453 pprExpr8 e = pprExpr9 e
 454
 455 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 456 infixMachOp8 (MO_Mul _)    = Just (char '*')
 457 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 458 infixMachOp8 _             = Nothing
 459
 460 pprExpr9 :: CmmExpr -> SDoc
 461 pprExpr9 e =
 462    case e of
 463         CmmLit    lit       -> pprLit1 lit
 464         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 465         CmmReg    reg       -> ppr reg
 466         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
 467         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
 468         CmmMachOp mop args  -> genMachOp mop args
 469
 470 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 471 genMachOp mop args
 472    | Just doc <- infixMachOp mop = case args of
 473         -- dyadic
 474         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 475
 476         -- unary
 477         [x]   -> doc <> pprExpr9 x
 478
 479         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 480                           (pprMachOp mop <+>
 481                             parens (hcat $ punctuate comma (map pprExpr args)))
 482                           empty
 483
 484    | isJust (infixMachOp1 mop)
 485    || isJust (infixMachOp7 mop)
 486    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 487
 488    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 489         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 490                                  (show mop))
 491                 -- replace spaces in (show mop) with underscores,
 492
 493 --
 494 -- Unsigned ops on the word size of the machine get nice symbols.
 495 -- All else get dumped in their ugly format.
 496 --
 497 infixMachOp :: MachOp -> Maybe SDoc
 498 infixMachOp mop
 499         = case mop of
 500             MO_And    _ -> Just $ char '&'
 501             MO_Or     _ -> Just $ char '|'
 502             MO_Xor    _ -> Just $ char '^'
 503             MO_Not    _ -> Just $ char '~'
 504             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 505             _ -> Nothing
 506
 507 -- --------------------------------------------------------------------------
 508 -- Literals.
 509 --  To minimise line noise we adopt the convention that if the literal
 510 --  has the natural machine word size, we do not append the type
 511 --
 512 pprLit :: CmmLit -> SDoc
 513 pprLit lit = case lit of
 514     CmmInt i rep ->
 515         hcat [ (if i < 0 then parens else id)(integer i)
 516              , ppUnless (rep == wordWidth) $
 517                space <> dcolon <+> ppr rep ]
 518
 519     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 520     CmmLabel clbl      -> pprCLabel clbl
 521     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 522     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 523                                   <> pprCLabel clbl2 <> ppr_offset i
 524     CmmBlock id        -> ppr id
 525     CmmHighStackMark -> text "<highSp>"
 526
 527 pprLit1 :: CmmLit -> SDoc
 528 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
 529 pprLit1 lit                  = pprLit lit
 530
 531 ppr_offset :: Int -> SDoc
 532 ppr_offset i
 533     | i==0      = empty
 534     | i>=0      = char '+' <> int i
 535     | otherwise = char '-' <> int (-i)
 536
 537 -- --------------------------------------------------------------------------
 538 -- Static data.
 539 --      Strings are printed as C strings, and we print them as I8[],
 540 --      following C--
 541 --
 542 pprStatic :: CmmStatic -> SDoc
 543 pprStatic s = case s of
 544     CmmStaticLit lit   -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
 545     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 546     CmmAlign i         -> nest 4 $ text "align" <+> int i
 547     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 548     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 549
 550 -- --------------------------------------------------------------------------
 551 -- Registers, whether local (temps) or global
 552 --
 553 pprReg :: CmmReg -> SDoc
 554 pprReg r
 555     = case r of
 556         CmmLocal  local  -> pprLocalReg  local
 557         CmmGlobal global -> pprGlobalReg global
 558
 559 --
 560 -- We only print the type of the local reg if it isn't wordRep
 561 --
 562 pprLocalReg :: LocalReg -> SDoc
 563 pprLocalReg (LocalReg uniq rep)
 564 --   = ppr rep <> char '_' <> ppr uniq
 565 -- Temp Jan08
 566    = char '_' <> ppr uniq <>
 567        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
 568                     then dcolon <> ptr <> ppr rep
 569                     else dcolon <> ptr <> ppr rep)
 570    where
 571      ptr = empty
 572          --if isGcPtrType rep
 573          --      then doubleQuotes (text "ptr")
 574          --      else empty
 575
 576 -- Stack areas
 577 pprArea :: Area -> SDoc
 578 pprArea (RegSlot r)   = hcat [ text "slot<", ppr r, text ">" ]
 579 pprArea (CallArea id) = pprAreaId id
 580
 581 pprAreaId :: AreaId -> SDoc
 582 pprAreaId Old        = text "old"
 583 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
 584
 585 -- needs to be kept in syn with Cmm.hs.GlobalReg
 586 --
 587 pprGlobalReg :: GlobalReg -> SDoc
 588 pprGlobalReg gr
 589     = case gr of
 590         VanillaReg n _ -> char 'R' <> int n
 591 -- Temp Jan08
 592 --        VanillaReg n VNonGcPtr -> char 'R' <> int n
 593 --        VanillaReg n VGcPtr    -> char 'P' <> int n
 594         FloatReg   n   -> char 'F' <> int n
 595         DoubleReg  n   -> char 'D' <> int n
 596         LongReg    n   -> char 'L' <> int n
 597         Sp             -> ptext (sLit "Sp")
 598         SpLim          -> ptext (sLit "SpLim")
 599         Hp             -> ptext (sLit "Hp")
 600         HpLim          -> ptext (sLit "HpLim")
 601         CurrentTSO     -> ptext (sLit "CurrentTSO")
 602         CurrentNursery -> ptext (sLit "CurrentNursery")
 603         HpAlloc        -> ptext (sLit "HpAlloc")
 604         EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 605         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 606         GCFun          -> ptext (sLit "stg_gc_fun")
 607         BaseReg        -> ptext (sLit "BaseReg")
 608         PicBaseReg     -> ptext (sLit "PicBaseReg")
 609
 610 -- --------------------------------------------------------------------------
 611 -- data sections
 612 --
 613 pprSection :: Section -> SDoc
 614 pprSection s = case s of
 615     Text              -> section <+> doubleQuotes (ptext (sLit "text"))
 616     Data              -> section <+> doubleQuotes (ptext (sLit "data"))
 617     ReadOnlyData      -> section <+> doubleQuotes (ptext (sLit "readonly"))
 618     ReadOnlyData16    -> section <+> doubleQuotes (ptext (sLit "readonly16"))
 619     RelocatableReadOnlyData
 620                       -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
 621     UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
 622     OtherSection s'   -> section <+> doubleQuotes (text s')
 623  where
 624     section = ptext (sLit "section")
 625
 626 -----------------------------------------------------------------------------
 627
 628 commafy :: [SDoc] -> SDoc
 629 commafy xs = fsep $ punctuate comma xs