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 (text "") $ 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           ppr_ar (CmmHinted ar k) = case cconv of
 269                             CmmCallConv -> ppr ar
 270                             _           -> ppr (ar,k)
 271           pp_conv = case cconv of
 272                       CmmCallConv -> empty
 273                       _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
 274
 275     CmmCall (CmmPrim op) results args safety ret ->
 276         pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
 277                         results args safety ret)
 278         where
 279           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)
 280
 281     CmmBranch ident          -> genBranch ident
 282     CmmCondBranch expr ident -> genCondBranch expr ident
 283     CmmJump expr params      -> genJump expr params
 284     CmmReturn params         -> genReturn params
 285     CmmSwitch arg ids        -> genSwitch arg ids
 286
 287 instance Outputable ForeignHint where
 288   ppr NoHint     = empty
 289   ppr SignedHint = quotes(text "signed")
 290 --  ppr AddrHint   = quotes(text "address")
 291 -- Temp Jan08
 292   ppr AddrHint   = (text "PtrHint")
 293
 294 -- Just look like a tuple, since it was a tuple before
 295 -- ... is that a good idea? --Isaac Dupree
 296 instance (Outputable a) => Outputable (CmmHinted a) where
 297   ppr (CmmHinted a k) = ppr (a, k)
 298
 299 -- --------------------------------------------------------------------------
 300 -- goto local label. [1], section 6.6
 301 --
 302 --     goto lbl;
 303 --
 304 genBranch :: BlockId -> SDoc
 305 genBranch ident =
 306     ptext (sLit "goto") <+> ppr ident <> semi
 307
 308 -- --------------------------------------------------------------------------
 309 -- Conditional. [1], section 6.4
 310 --
 311 --     if (expr) { goto lbl; }
 312 --
 313 genCondBranch :: CmmExpr -> BlockId -> SDoc
 314 genCondBranch expr ident =
 315     hsep [ ptext (sLit "if")
 316          , parens(ppr expr)
 317          , ptext (sLit "goto")
 318          , ppr ident <> semi ]
 319
 320 -- --------------------------------------------------------------------------
 321 -- A tail call. [1], Section 6.9
 322 --
 323 --     jump foo(a, b, c);
 324 --
 325 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
 326 genJump expr args =
 327     hcat [ ptext (sLit "jump")
 328          , space
 329          , if isTrivialCmmExpr expr
 330                 then pprExpr expr
 331                 else case expr of
 332                     CmmLoad (CmmReg _) _ -> pprExpr expr
 333                     _ -> parens (pprExpr expr)
 334          , space
 335          , parens  ( commafy $ map ppr args )
 336          , semi ]
 337
 338
 339 -- --------------------------------------------------------------------------
 340 -- Return from a function. [1], Section 6.8.2 of version 1.128
 341 --
 342 --     return (a, b, c);
 343 --
 344 genReturn :: [CmmHinted CmmExpr] -> SDoc
 345 genReturn args =
 346     hcat [ ptext (sLit "return")
 347          , space
 348          , parens  ( commafy $ map ppr args )
 349          , semi ]
 350
 351 -- --------------------------------------------------------------------------
 352 -- Tabled jump to local label
 353 --
 354 -- The syntax is from [1], section 6.5
 355 --
 356 --      switch [0 .. n] (expr) { case ... ; }
 357 --
 358 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 359 genSwitch expr maybe_ids
 360
 361     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 362
 363       in hang (hcat [ ptext (sLit "switch [0 .. ")
 364                     , int (length maybe_ids - 1)
 365                     , ptext (sLit "] ")
 366                     , if isTrivialCmmExpr expr
 367                         then pprExpr expr
 368                         else parens (pprExpr expr)
 369                     , ptext (sLit " {")
 370                     ])
 371             4 (vcat ( map caseify pairs )) $$ rbrace
 372
 373     where
 374       snds a b = (snd a) == (snd b)
 375
 376       caseify :: [(Int,Maybe BlockId)] -> SDoc
 377       caseify ixs@((_,Nothing):_)
 378         = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 379                 <> ptext (sLit " */")
 380       caseify as
 381         = let (is,ids) = unzip as
 382           in hsep [ ptext (sLit "case")
 383                   , hcat (punctuate comma (map int is))
 384                   , ptext (sLit ": goto")
 385                   , ppr (head [ id | Just id <- ids]) <> semi ]
 386
 387 -- --------------------------------------------------------------------------
 388 -- Expressions
 389 --
 390
 391 pprExpr :: CmmExpr -> SDoc
 392 pprExpr e
 393     = case e of
 394         CmmRegOff reg i ->
 395                 pprExpr (CmmMachOp (MO_Add rep)
 396                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 397                 where rep = typeWidth (cmmRegType reg)
 398         CmmLit lit -> pprLit lit
 399         _other     -> pprExpr1 e
 400
 401 -- Here's the precedence table from CmmParse.y:
 402 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 403 -- %left '|'
 404 -- %left '^'
 405 -- %left '&'
 406 -- %left '>>' '<<'
 407 -- %left '-' '+'
 408 -- %left '/' '*' '%'
 409 -- %right '~'
 410
 411 -- We just cope with the common operators for now, the rest will get
 412 -- a default conservative behaviour.
 413
 414 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 415 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
 416 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 417    = pprExpr7 x <+> doc <+> pprExpr7 y
 418 pprExpr1 e = pprExpr7 e
 419
 420 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
 421
 422 infixMachOp1 (MO_Eq     _) = Just (ptext (sLit "=="))
 423 infixMachOp1 (MO_Ne     _) = Just (ptext (sLit "!="))
 424 infixMachOp1 (MO_Shl    _) = Just (ptext (sLit "<<"))
 425 infixMachOp1 (MO_U_Shr  _) = Just (ptext (sLit ">>"))
 426 infixMachOp1 (MO_U_Ge   _) = Just (ptext (sLit ">="))
 427 infixMachOp1 (MO_U_Le   _) = Just (ptext (sLit "<="))
 428 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 429 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 430 infixMachOp1 _             = Nothing
 431
 432 -- %left '-' '+'
 433 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 434    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 435 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 436    = pprExpr7 x <+> doc <+> pprExpr8 y
 437 pprExpr7 e = pprExpr8 e
 438
 439 infixMachOp7 (MO_Add _)  = Just (char '+')
 440 infixMachOp7 (MO_Sub _)  = Just (char '-')
 441 infixMachOp7 _           = Nothing
 442
 443 -- %left '/' '*' '%'
 444 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 445    = pprExpr8 x <+> doc <+> pprExpr9 y
 446 pprExpr8 e = pprExpr9 e
 447
 448 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 449 infixMachOp8 (MO_Mul _)    = Just (char '*')
 450 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 451 infixMachOp8 _             = Nothing
 452
 453 pprExpr9 :: CmmExpr -> SDoc
 454 pprExpr9 e =
 455    case e of
 456         CmmLit    lit       -> pprLit1 lit
 457         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 458         CmmReg    reg       -> ppr reg
 459         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
 460         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
 461         CmmMachOp mop args  -> genMachOp mop args
 462
 463 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 464 genMachOp mop args
 465    | Just doc <- infixMachOp mop = case args of
 466         -- dyadic
 467         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 468
 469         -- unary
 470         [x]   -> doc <> pprExpr9 x
 471
 472         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 473                           (pprMachOp mop <+>
 474                             parens (hcat $ punctuate comma (map pprExpr args)))
 475                           empty
 476
 477    | isJust (infixMachOp1 mop)
 478    || isJust (infixMachOp7 mop)
 479    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 480
 481    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 482         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 483                                  (show mop))
 484                 -- replace spaces in (show mop) with underscores,
 485
 486 --
 487 -- Unsigned ops on the word size of the machine get nice symbols.
 488 -- All else get dumped in their ugly format.
 489 --
 490 infixMachOp :: MachOp -> Maybe SDoc
 491 infixMachOp mop
 492         = case mop of
 493             MO_And    _ -> Just $ char '&'
 494             MO_Or     _ -> Just $ char '|'
 495             MO_Xor    _ -> Just $ char '^'
 496             MO_Not    _ -> Just $ char '~'
 497             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 498             _ -> Nothing
 499
 500 -- --------------------------------------------------------------------------
 501 -- Literals.
 502 --  To minimise line noise we adopt the convention that if the literal
 503 --  has the natural machine word size, we do not append the type
 504 --
 505 pprLit :: CmmLit -> SDoc
 506 pprLit lit = case lit of
 507     CmmInt i rep ->
 508         hcat [ (if i < 0 then parens else id)(integer i)
 509              , (if rep == wordWidth
 510                     then empty
 511                     else space <> dcolon <+> ppr rep) ]
 512
 513     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 514     CmmLabel clbl      -> pprCLabel clbl
 515     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 516     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 517                                   <> pprCLabel clbl2 <> ppr_offset i
 518     CmmBlock id        -> ppr id
 519     CmmHighStackMark -> text "<highSp>"
 520
 521 pprLit1 :: CmmLit -> SDoc
 522 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
 523 pprLit1 lit                  = pprLit lit
 524
 525 ppr_offset :: Int -> SDoc
 526 ppr_offset i
 527     | i==0      = empty
 528     | i>=0      = char '+' <> int i
 529     | otherwise = char '-' <> int (-i)
 530
 531 -- --------------------------------------------------------------------------
 532 -- Static data.
 533 --      Strings are printed as C strings, and we print them as I8[],
 534 --      following C--
 535 --
 536 pprStatic :: CmmStatic -> SDoc
 537 pprStatic s = case s of
 538     CmmStaticLit lit   -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
 539     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 540     CmmAlign i         -> nest 4 $ text "align" <+> int i
 541     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 542     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 543
 544 -- --------------------------------------------------------------------------
 545 -- Registers, whether local (temps) or global
 546 --
 547 pprReg :: CmmReg -> SDoc
 548 pprReg r
 549     = case r of
 550         CmmLocal  local  -> pprLocalReg  local
 551         CmmGlobal global -> pprGlobalReg global
 552
 553 --
 554 -- We only print the type of the local reg if it isn't wordRep
 555 --
 556 pprLocalReg :: LocalReg -> SDoc
 557 pprLocalReg (LocalReg uniq rep)
 558 --   = ppr rep <> char '_' <> ppr uniq
 559 -- Temp Jan08
 560    = char '_' <> ppr uniq <>
 561        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
 562                     then dcolon <> ptr <> ppr rep
 563                     else dcolon <> ptr <> ppr rep)
 564    where
 565      ptr = empty
 566          --if isGcPtrType rep
 567          --      then doubleQuotes (text "ptr")
 568          --      else empty
 569
 570 -- Stack areas
 571 pprArea :: Area -> SDoc
 572 pprArea (RegSlot r)   = hcat [ text "slot<", ppr r, text ">" ]
 573 pprArea (CallArea id) = pprAreaId id
 574
 575 pprAreaId :: AreaId -> SDoc
 576 pprAreaId Old        = text "old"
 577 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
 578
 579 -- needs to be kept in syn with Cmm.hs.GlobalReg
 580 --
 581 pprGlobalReg :: GlobalReg -> SDoc
 582 pprGlobalReg gr
 583     = case gr of
 584         VanillaReg n _ -> char 'R' <> int n
 585 -- Temp Jan08
 586 --        VanillaReg n VNonGcPtr -> char 'R' <> int n
 587 --        VanillaReg n VGcPtr    -> char 'P' <> int n
 588         FloatReg   n   -> char 'F' <> int n
 589         DoubleReg  n   -> char 'D' <> int n
 590         LongReg    n   -> char 'L' <> int n
 591         Sp             -> ptext (sLit "Sp")
 592         SpLim          -> ptext (sLit "SpLim")
 593         Hp             -> ptext (sLit "Hp")
 594         HpLim          -> ptext (sLit "HpLim")
 595         CurrentTSO     -> ptext (sLit "CurrentTSO")
 596         CurrentNursery -> ptext (sLit "CurrentNursery")
 597         HpAlloc        -> ptext (sLit "HpAlloc")
 598         EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 599         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 600         GCFun          -> ptext (sLit "stg_gc_fun")
 601         BaseReg        -> ptext (sLit "BaseReg")
 602         PicBaseReg     -> ptext (sLit "PicBaseReg")
 603
 604 -- --------------------------------------------------------------------------
 605 -- data sections
 606 --
 607 pprSection :: Section -> SDoc
 608 pprSection s = case s of
 609     Text              -> section <+> doubleQuotes (ptext (sLit "text"))
 610     Data              -> section <+> doubleQuotes (ptext (sLit "data"))
 611     ReadOnlyData      -> section <+> doubleQuotes (ptext (sLit "readonly"))
 612     ReadOnlyData16    -> section <+> doubleQuotes (ptext (sLit "readonly16"))
 613     RelocatableReadOnlyData
 614                       -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
 615     UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
 616     OtherSection s'   -> section <+> doubleQuotes (text s')
 617  where
 618     section = ptext (sLit "section")
 619
 620 -----------------------------------------------------------------------------
 621
 622 commafy :: [SDoc] -> SDoc
 623 commafy xs = fsep $ punctuate comma xs