ghc/compiler/cmm/CLabel.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Object-file symbols (called CLabel for histerical raisins).
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CLabel (
  10         CLabel, -- abstract type
  11
  12         mkClosureLabel,
  13         mkSRTLabel,
  14         mkSRTDescLabel,
  15         mkInfoTableLabel,
  16         mkEntryLabel,
  17         mkSlowEntryLabel,
  18         mkConEntryLabel,
  19         mkStaticConEntryLabel,
  20         mkRednCountsLabel,
  21         mkConInfoTableLabel,
  22         mkStaticInfoTableLabel,
  23         mkApEntryLabel,
  24         mkApInfoTableLabel,
  25
  26         mkReturnPtLabel,
  27         mkReturnInfoLabel,
  28         mkAltLabel,
  29         mkDefaultLabel,
  30         mkBitmapLabel,
  31         mkStringLitLabel,
  32
  33         mkClosureTblLabel,
  34
  35         mkAsmTempLabel,
  36
  37         mkModuleInitLabel,
  38         mkPlainModuleInitLabel,
  39
  40         mkErrorStdEntryLabel,
  41         mkSplitMarkerLabel,
  42         mkUpdInfoLabel,
  43         mkSeqInfoLabel,
  44         mkIndStaticInfoLabel,
  45         mkMainCapabilityLabel,
  46         mkMAP_FROZEN_infoLabel,
  47         mkEMPTY_MVAR_infoLabel,
  48
  49         mkTopTickyCtrLabel,
  50         mkCAFBlackHoleInfoTableLabel,
  51         mkSECAFBlackHoleInfoTableLabel,
  52         mkRtsPrimOpLabel,
  53         mkRtsSlowTickyCtrLabel,
  54
  55         moduleRegdLabel,
  56
  57         mkSelectorInfoLabel,
  58         mkSelectorEntryLabel,
  59
  60         mkRtsInfoLabel,
  61         mkRtsEntryLabel,
  62         mkRtsRetInfoLabel,
  63         mkRtsRetLabel,
  64         mkRtsCodeLabel,
  65         mkRtsDataLabel,
  66
  67         mkRtsInfoLabelFS,
  68         mkRtsEntryLabelFS,
  69         mkRtsRetInfoLabelFS,
  70         mkRtsRetLabelFS,
  71         mkRtsCodeLabelFS,
  72         mkRtsDataLabelFS,
  73
  74         mkForeignLabel,
  75
  76         mkCCLabel, mkCCSLabel,
  77
  78         infoLblToEntryLbl, entryLblToInfoLbl,
  79         needsCDecl, isAsmTemp, externallyVisibleCLabel,
  80         CLabelType(..), labelType, labelDynamic, labelCouldBeDynamic,
  81
  82         pprCLabel
  83     ) where
  84
  85
  86 #include "HsVersions.h"
  87 #include "../includes/ghcconfig.h"
  88
  89 import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
  90 import DataCon          ( ConTag )
  91 import Module           ( moduleName, moduleNameFS,
  92                           Module, isHomeModule )
  93 import Name             ( Name, isDllName, isExternalName )
  94 import Unique           ( pprUnique, Unique )
  95 import PrimOp           ( PrimOp )
  96 import Config           ( cLeadingUnderscore )
  97 import CostCentre       ( CostCentre, CostCentreStack )
  98 import Outputable
  99 import FastString
 100
 101
 102 -- -----------------------------------------------------------------------------
 103 -- The CLabel type
 104
 105 {-
 106 CLabel is an abstract type that supports the following operations:
 107
 108   - Pretty printing
 109
 110   - In a C file, does it need to be declared before use?  (i.e. is it
 111     guaranteed to be already in scope in the places we need to refer to it?)
 112
 113   - If it needs to be declared, what type (code or data) should it be
 114     declared to have?
 115
 116   - Is it visible outside this object file or not?
 117
 118   - Is it "dynamic" (see details below)
 119
 120   - Eq and Ord, so that we can make sets of CLabels (currently only
 121     used in outputting C as far as I can tell, to avoid generating
 122     more than one declaration for any given label).
 123
 124   - Converting an info table label into an entry label.
 125 -}
 126
 127 data CLabel
 128   = IdLabel                     -- A family of labels related to the
 129         Name                    -- definition of a particular Id or Con
 130         IdLabelInfo
 131
 132   | CaseLabel                   -- A family of labels related to a particular
 133                                 -- case expression.
 134         {-# UNPACK #-} !Unique  -- Unique says which case expression
 135         CaseLabelInfo
 136
 137   | AsmTempLabel
 138         {-# UNPACK #-} !Unique
 139
 140   | StringLitLabel
 141         {-# UNPACK #-} !Unique
 142
 143   | ModuleInitLabel
 144         Module                  -- the module name
 145         String                  -- its "way"
 146         -- at some point we might want some kind of version number in
 147         -- the module init label, to guard against compiling modules in
 148         -- the wrong order.  We can't use the interface file version however,
 149         -- because we don't always recompile modules which depend on a module
 150         -- whose version has changed.
 151
 152   | PlainModuleInitLabel Module  -- without the vesrion & way info
 153
 154   | ModuleRegdLabel
 155
 156   | RtsLabel RtsLabelInfo
 157
 158   | ForeignLabel FastString     -- a 'C' (or otherwise foreign) label
 159         (Maybe Int)             -- possible '@n' suffix for stdcall functions
 160                 -- When generating C, the '@n' suffix is omitted, but when
 161                 -- generating assembler we must add it to the label.
 162         Bool                    -- True <=> is dynamic
 163
 164   | CC_Label  CostCentre
 165   | CCS_Label CostCentreStack
 166
 167   deriving (Eq, Ord)
 168
 169
 170 data IdLabelInfo
 171   = Closure             -- Label for closure
 172   | SRT                 -- Static reference table
 173   | SRTDesc             -- Static reference table descriptor
 174   | InfoTbl             -- Info tables for closures; always read-only
 175   | Entry               -- entry point
 176   | Slow                -- slow entry point
 177
 178   | RednCounts          -- Label of place to keep Ticky-ticky  info for
 179                         -- this Id
 180
 181   | Bitmap              -- A bitmap (function or case return)
 182
 183   | ConEntry            -- constructor entry point
 184   | ConInfoTbl          -- corresponding info table
 185   | StaticConEntry      -- static constructor entry point
 186   | StaticInfoTbl       -- corresponding info table
 187
 188   | ClosureTable        -- table of closures for Enum tycons
 189
 190   deriving (Eq, Ord)
 191
 192
 193 data CaseLabelInfo
 194   = CaseReturnPt
 195   | CaseReturnInfo
 196   | CaseAlt ConTag
 197   | CaseDefault
 198   deriving (Eq, Ord)
 199
 200
 201 data RtsLabelInfo
 202   = RtsShouldNeverHappenCode
 203
 204   | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}  -- Selector thunks
 205   | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
 206
 207   | RtsApInfoTbl Bool{-updatable-} Int{-arity-}         -- AP thunks
 208   | RtsApEntry   Bool{-updatable-} Int{-arity-}
 209
 210   | RtsPrimOp PrimOp
 211
 212   | RtsInfo       LitString     -- misc rts info tables
 213   | RtsEntry      LitString     -- misc rts entry points
 214   | RtsRetInfo    LitString     -- misc rts ret info tables
 215   | RtsRet        LitString     -- misc rts return points
 216   | RtsData       LitString     -- misc rts data bits, eg CHARLIKE_closure
 217   | RtsCode       LitString     -- misc rts code
 218
 219   | RtsInfoFS     FastString    -- misc rts info tables
 220   | RtsEntryFS    FastString    -- misc rts entry points
 221   | RtsRetInfoFS  FastString    -- misc rts ret info tables
 222   | RtsRetFS      FastString    -- misc rts return points
 223   | RtsDataFS     FastString    -- misc rts data bits, eg CHARLIKE_closure
 224   | RtsCodeFS     FastString    -- misc rts code
 225
 226   | RtsSlowTickyCtr String
 227
 228   deriving (Eq, Ord)
 229         -- NOTE: Eq on LitString compares the pointer only, so this isn't
 230         -- a real equality.
 231
 232 -- -----------------------------------------------------------------------------
 233 -- Constructing CLabels
 234
 235 mkClosureLabel          id      = IdLabel id  Closure
 236 mkSRTLabel              id      = IdLabel id  SRT
 237 mkSRTDescLabel          id      = IdLabel id  SRTDesc
 238 mkInfoTableLabel        id      = IdLabel id  InfoTbl
 239 mkEntryLabel            id      = IdLabel id  Entry
 240 mkSlowEntryLabel        id      = IdLabel id  Slow
 241 mkBitmapLabel           id      = IdLabel id  Bitmap
 242 mkRednCountsLabel       id      = IdLabel id  RednCounts
 243
 244 mkConInfoTableLabel     con     = IdLabel con ConInfoTbl
 245 mkConEntryLabel         con     = IdLabel con ConEntry
 246 mkStaticInfoTableLabel  con     = IdLabel con StaticInfoTbl
 247 mkStaticConEntryLabel   con     = IdLabel con StaticConEntry
 248
 249 mkClosureTblLabel       id      = IdLabel id ClosureTable
 250
 251 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 252 mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
 253 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 254 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 255
 256 mkStringLitLabel                = StringLitLabel
 257 mkAsmTempLabel                  = AsmTempLabel
 258
 259 mkModuleInitLabel               = ModuleInitLabel
 260 mkPlainModuleInitLabel          = PlainModuleInitLabel
 261
 262         -- Some fixed runtime system labels
 263
 264 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 265 mkSplitMarkerLabel              = RtsLabel (RtsCode SLIT("__stg_split_marker"))
 266 mkUpdInfoLabel                  = RtsLabel (RtsInfo SLIT("stg_upd_frame"))
 267 mkSeqInfoLabel                  = RtsLabel (RtsInfo SLIT("stg_seq_frame"))
 268 mkIndStaticInfoLabel            = RtsLabel (RtsInfo SLIT("stg_IND_STATIC"))
 269 mkMainCapabilityLabel           = RtsLabel (RtsData SLIT("MainCapability"))
 270 mkMAP_FROZEN_infoLabel          = RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN"))
 271 mkEMPTY_MVAR_infoLabel          = RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR"))
 272
 273 mkTopTickyCtrLabel              = RtsLabel (RtsData SLIT("top_ct"))
 274 mkCAFBlackHoleInfoTableLabel    = RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE"))
 275 mkSECAFBlackHoleInfoTableLabel  = if opt_DoTickyProfiling then
 276                                     RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE"))
 277                                   else  -- RTS won't have info table unless -ticky is on
 278                                     panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 279 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 280
 281 moduleRegdLabel                 = ModuleRegdLabel
 282
 283 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTbl upd off)
 284 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry   upd off)
 285
 286 mkApInfoTableLabel  upd off     = RtsLabel (RtsApInfoTbl upd off)
 287 mkApEntryLabel upd off          = RtsLabel (RtsApEntry   upd off)
 288
 289         -- Foreign labels
 290
 291 mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
 292 mkForeignLabel str mb_sz  is_dynamic = ForeignLabel str mb_sz is_dynamic
 293
 294         -- Cost centres etc.
 295
 296 mkCCLabel       cc              = CC_Label cc
 297 mkCCSLabel      ccs             = CCS_Label ccs
 298
 299 mkRtsInfoLabel      str = RtsLabel (RtsInfo      str)
 300 mkRtsEntryLabel     str = RtsLabel (RtsEntry     str)
 301 mkRtsRetInfoLabel   str = RtsLabel (RtsRetInfo   str)
 302 mkRtsRetLabel       str = RtsLabel (RtsRet       str)
 303 mkRtsCodeLabel      str = RtsLabel (RtsCode      str)
 304 mkRtsDataLabel      str = RtsLabel (RtsData      str)
 305
 306 mkRtsInfoLabelFS    str = RtsLabel (RtsInfoFS    str)
 307 mkRtsEntryLabelFS   str = RtsLabel (RtsEntryFS   str)
 308 mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
 309 mkRtsRetLabelFS     str = RtsLabel (RtsRetFS     str)
 310 mkRtsCodeLabelFS    str = RtsLabel (RtsCodeFS    str)
 311 mkRtsDataLabelFS    str = RtsLabel (RtsDataFS    str)
 312
 313 mkRtsSlowTickyCtrLabel :: String -> CLabel
 314 mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
 315
 316 -- -----------------------------------------------------------------------------
 317 -- Converting info labels to entry labels.
 318
 319 infoLblToEntryLbl :: CLabel -> CLabel
 320 infoLblToEntryLbl (IdLabel n InfoTbl) = IdLabel n Entry
 321 infoLblToEntryLbl (IdLabel n ConInfoTbl) = IdLabel n ConEntry
 322 infoLblToEntryLbl (IdLabel n StaticInfoTbl) = IdLabel n StaticConEntry
 323 infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
 324 infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
 325 infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
 326 infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
 327 infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
 328 infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
 329
 330 entryLblToInfoLbl :: CLabel -> CLabel
 331 entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTbl
 332 entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTbl
 333 entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTbl
 334 entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
 335 entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
 336 entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
 337 entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
 338 entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
 339 entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
 340
 341 -- -----------------------------------------------------------------------------
 342 -- Does a CLabel need declaring before use or not?
 343
 344 needsCDecl :: CLabel -> Bool
 345   -- False <=> it's pre-declared; don't bother
 346   -- don't bother declaring SRT & Bitmap labels, we always make sure
 347   -- they are defined before use.
 348 needsCDecl (IdLabel _ SRT)              = False
 349 needsCDecl (IdLabel _ SRTDesc)          = False
 350 needsCDecl (IdLabel _ Bitmap)           = False
 351 needsCDecl (IdLabel _ _)                = True
 352 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 353 needsCDecl (CaseLabel _ CaseReturnInfo) = True
 354 needsCDecl (ModuleInitLabel _ _)        = True
 355 needsCDecl (PlainModuleInitLabel _)     = True
 356 needsCDecl ModuleRegdLabel              = False
 357
 358 needsCDecl (CaseLabel _ _)              = False
 359 needsCDecl (StringLitLabel _)           = False
 360 needsCDecl (AsmTempLabel _)             = False
 361 needsCDecl (RtsLabel _)                 = False
 362 needsCDecl (ForeignLabel _ _ _)         = False
 363 needsCDecl (CC_Label _)                 = True
 364 needsCDecl (CCS_Label _)                = True
 365
 366 -- Whether the label is an assembler temporary:
 367
 368 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 369 isAsmTemp (AsmTempLabel _) = True
 370 isAsmTemp _                = False
 371
 372 -- -----------------------------------------------------------------------------
 373 -- Is a CLabel visible outside this object file or not?
 374
 375 -- From the point of view of the code generator, a name is
 376 -- externally visible if it has to be declared as exported
 377 -- in the .o file's symbol table; that is, made non-static.
 378
 379 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 380 externallyVisibleCLabel (CaseLabel _ _)    = False
 381 externallyVisibleCLabel (StringLitLabel _) = False
 382 externallyVisibleCLabel (AsmTempLabel _)   = False
 383 externallyVisibleCLabel (ModuleInitLabel _ _)= True
 384 externallyVisibleCLabel (PlainModuleInitLabel _)= True
 385 externallyVisibleCLabel ModuleRegdLabel    = False
 386 externallyVisibleCLabel (RtsLabel _)       = True
 387 externallyVisibleCLabel (ForeignLabel _ _ _) = True
 388 externallyVisibleCLabel (IdLabel id _)     = isExternalName id
 389 externallyVisibleCLabel (CC_Label _)       = True
 390 externallyVisibleCLabel (CCS_Label _)      = True
 391
 392
 393 -- -----------------------------------------------------------------------------
 394 -- Finding the "type" of a CLabel
 395
 396 -- For generating correct types in label declarations:
 397
 398 data CLabelType
 399   = CodeLabel
 400   | DataLabel
 401
 402 labelType :: CLabel -> CLabelType
 403 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = DataLabel
 404 labelType (RtsLabel (RtsApInfoTbl _ _))       = DataLabel
 405 labelType (RtsLabel (RtsData _))              = DataLabel
 406 labelType (RtsLabel (RtsCode _))              = CodeLabel
 407 labelType (RtsLabel (RtsInfo _))              = DataLabel
 408 labelType (RtsLabel (RtsEntry _))             = CodeLabel
 409 labelType (RtsLabel (RtsRetInfo _))           = DataLabel
 410 labelType (RtsLabel (RtsRet _))               = CodeLabel
 411 labelType (RtsLabel (RtsDataFS _))            = DataLabel
 412 labelType (RtsLabel (RtsCodeFS _))            = CodeLabel
 413 labelType (RtsLabel (RtsInfoFS _))            = DataLabel
 414 labelType (RtsLabel (RtsEntryFS _))           = CodeLabel
 415 labelType (RtsLabel (RtsRetInfoFS _))         = DataLabel
 416 labelType (RtsLabel (RtsRetFS _))             = CodeLabel
 417 labelType (CaseLabel _ CaseReturnInfo)        = DataLabel
 418 labelType (CaseLabel _ CaseReturnPt)          = CodeLabel
 419 labelType (ModuleInitLabel _ _)               = CodeLabel
 420 labelType (PlainModuleInitLabel _)            = CodeLabel
 421
 422 labelType (IdLabel _ info) =
 423   case info of
 424     InfoTbl       -> DataLabel
 425     Closure       -> DataLabel
 426     Bitmap        -> DataLabel
 427     ConInfoTbl    -> DataLabel
 428     StaticInfoTbl -> DataLabel
 429     ClosureTable  -> DataLabel
 430     _             -> CodeLabel
 431
 432 labelType _        = DataLabel
 433
 434
 435 -- -----------------------------------------------------------------------------
 436 -- Does a CLabel need dynamic linkage?
 437
 438 -- When referring to data in code, we need to know whether
 439 -- that data resides in a DLL or not. [Win32 only.]
 440 -- @labelDynamic@ returns @True@ if the label is located
 441 -- in a DLL, be it a data reference or not.
 442
 443 labelDynamic :: CLabel -> Bool
 444 labelDynamic lbl =
 445   case lbl of
 446    -- The special case for RtsShouldNeverHappenCode is because the associated address is
 447    -- NULL, i.e. not a DLL entry point
 448    RtsLabel RtsShouldNeverHappenCode -> False
 449    RtsLabel _        -> not opt_Static  -- i.e., is the RTS in a DLL or not?
 450    IdLabel n k       -> isDllName n
 451    ForeignLabel _ _ d  -> d
 452    ModuleInitLabel m _  -> (not opt_Static) && (not (isHomeModule m))
 453    PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
 454    _                 -> False
 455
 456 -- Basically the same as above, but this time for Darwin only.
 457 -- The things that GHC does when labelDynamic returns true are not quite right
 458 -- for Darwin. Also, every ForeignLabel might possibly be from a dynamic library,
 459 -- and a 'false positive' doesn't really hurt on Darwin, so this just returns
 460 -- True for every ForeignLabel.
 461 --
 462 -- ToDo: Clean up DLL-related code so we can do away with the distinction
 463 --       between this and labelDynamic above.
 464
 465 labelCouldBeDynamic (ForeignLabel _ _ _) = True
 466 labelCouldBeDynamic lbl = labelDynamic lbl
 467
 468 {-
 469 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 470 right places. It is used to detect when the abstractC statement of an
 471 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 472
 473 We need at least @Eq@ for @CLabels@, because we want to avoid
 474 duplicate declarations in generating C (see @labelSeenTE@ in
 475 @PprAbsC@).
 476 -}
 477
 478 -----------------------------------------------------------------------------
 479 -- Printing out CLabels.
 480
 481 {-
 482 Convention:
 483
 484       <name>_<type>
 485
 486 where <name> is <Module>_<name> for external names and <unique> for
 487 internal names. <type> is one of the following:
 488
 489          info                   Info table
 490          srt                    Static reference table
 491          srtd                   Static reference table descriptor
 492          entry                  Entry code (function, closure)
 493          slow                   Slow entry code (if any)
 494          ret                    Direct return address
 495          vtbl                   Vector table
 496          <n>_alt                Case alternative (tag n)
 497          dflt                   Default case alternative
 498          btm                    Large bitmap vector
 499          closure                Static closure
 500          con_entry              Dynamic Constructor entry code
 501          con_info               Dynamic Constructor info table
 502          static_entry           Static Constructor entry code
 503          static_info            Static Constructor info table
 504          sel_info               Selector info table
 505          sel_entry              Selector entry code
 506          cc                     Cost centre
 507          ccs                    Cost centre stack
 508
 509 Many of these distinctions are only for documentation reasons.  For
 510 example, _ret is only distinguished from _entry to make it easy to
 511 tell whether a code fragment is a return point or a closure/function
 512 entry.
 513 -}
 514
 515 pprCLabel :: CLabel -> SDoc
 516
 517 #if ! OMIT_NATIVE_CODEGEN
 518 pprCLabel (AsmTempLabel u)
 519   =  getPprStyle $ \ sty ->
 520      if asmStyle sty then
 521         ptext asmTempLabelPrefix <> pprUnique u
 522      else
 523         char '_' <> pprUnique u
 524 #endif
 525
 526 pprCLabel lbl =
 527 #if ! OMIT_NATIVE_CODEGEN
 528     getPprStyle $ \ sty ->
 529     if asmStyle sty then
 530         maybe_underscore (pprAsmCLbl lbl)
 531     else
 532 #endif
 533        pprCLbl lbl
 534
 535 maybe_underscore doc
 536   | underscorePrefix = pp_cSEP <> doc
 537   | otherwise        = doc
 538
 539 -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
 540 -- (The C compiler does this itself).
 541 pprAsmCLbl (ForeignLabel fs (Just sz) _)
 542    = ftext fs <> char '@' <> int sz
 543 pprAsmCLbl lbl
 544    = pprCLbl lbl
 545
 546 pprCLbl (StringLitLabel u)
 547   = pprUnique u <> ptext SLIT("_str")
 548
 549 pprCLbl (CaseLabel u CaseReturnPt)
 550   = hcat [pprUnique u, ptext SLIT("_ret")]
 551 pprCLbl (CaseLabel u CaseReturnInfo)
 552   = hcat [pprUnique u, ptext SLIT("_info")]
 553 pprCLbl (CaseLabel u (CaseAlt tag))
 554   = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
 555 pprCLbl (CaseLabel u CaseDefault)
 556   = hcat [pprUnique u, ptext SLIT("_dflt")]
 557
 558 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("0")
 559 -- used to be stg_error_entry but Windows can't have DLL entry points as static
 560 -- initialisers, and besides, this ShouldNeverHappen, right?
 561
 562 pprCLbl (RtsLabel (RtsCode str))   = ptext str
 563 pprCLbl (RtsLabel (RtsData str))   = ptext str
 564 pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
 565 pprCLbl (RtsLabel (RtsDataFS str)) = ftext str
 566
 567 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 568   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 569                 ptext (if upd_reqd
 570                         then SLIT("_upd_info")
 571                         else SLIT("_noupd_info"))
 572         ]
 573
 574 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 575   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 576                 ptext (if upd_reqd
 577                         then SLIT("_upd_entry")
 578                         else SLIT("_noupd_entry"))
 579         ]
 580
 581 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 582   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 583                 ptext (if upd_reqd
 584                         then SLIT("_upd_info")
 585                         else SLIT("_noupd_info"))
 586         ]
 587
 588 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 589   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 590                 ptext (if upd_reqd
 591                         then SLIT("_upd_entry")
 592                         else SLIT("_noupd_entry"))
 593         ]
 594
 595 pprCLbl (RtsLabel (RtsInfo fs))
 596   = ptext fs <> ptext SLIT("_info")
 597
 598 pprCLbl (RtsLabel (RtsEntry fs))
 599   = ptext fs <> ptext SLIT("_entry")
 600
 601 pprCLbl (RtsLabel (RtsRetInfo fs))
 602   = ptext fs <> ptext SLIT("_info")
 603
 604 pprCLbl (RtsLabel (RtsRet fs))
 605   = ptext fs <> ptext SLIT("_ret")
 606
 607 pprCLbl (RtsLabel (RtsInfoFS fs))
 608   = ftext fs <> ptext SLIT("_info")
 609
 610 pprCLbl (RtsLabel (RtsEntryFS fs))
 611   = ftext fs <> ptext SLIT("_entry")
 612
 613 pprCLbl (RtsLabel (RtsRetInfoFS fs))
 614   = ftext fs <> ptext SLIT("_info")
 615
 616 pprCLbl (RtsLabel (RtsRetFS fs))
 617   = ftext fs <> ptext SLIT("_ret")
 618
 619 pprCLbl (RtsLabel (RtsPrimOp primop))
 620   = ppr primop <> ptext SLIT("_fast")
 621
 622 pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
 623   = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")
 624
 625 pprCLbl ModuleRegdLabel
 626   = ptext SLIT("_module_registered")
 627
 628 pprCLbl (ForeignLabel str _ _)
 629   = ftext str
 630
 631 pprCLbl (IdLabel id  flavor) = ppr id <> ppIdFlavor flavor
 632
 633 pprCLbl (CC_Label cc)           = ppr cc
 634 pprCLbl (CCS_Label ccs)         = ppr ccs
 635
 636 pprCLbl (ModuleInitLabel mod way)
 637    = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
 638         <> char '_' <> text way
 639 pprCLbl (PlainModuleInitLabel mod)
 640    = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
 641
 642 ppIdFlavor :: IdLabelInfo -> SDoc
 643 ppIdFlavor x = pp_cSEP <>
 644                (case x of
 645                        Closure          -> ptext SLIT("closure")
 646                        SRT              -> ptext SLIT("srt")
 647                        SRTDesc          -> ptext SLIT("srtd")
 648                        InfoTbl          -> ptext SLIT("info")
 649                        Entry            -> ptext SLIT("entry")
 650                        Slow             -> ptext SLIT("slow")
 651                        RednCounts       -> ptext SLIT("ct")
 652                        Bitmap           -> ptext SLIT("btm")
 653                        ConEntry         -> ptext SLIT("con_entry")
 654                        ConInfoTbl       -> ptext SLIT("con_info")
 655                        StaticConEntry   -> ptext SLIT("static_entry")
 656                        StaticInfoTbl    -> ptext SLIT("static_info")
 657                        ClosureTable     -> ptext SLIT("closure_tbl")
 658                       )
 659
 660
 661 pp_cSEP = char '_'
 662
 663 -- -----------------------------------------------------------------------------
 664 -- Machine-dependent knowledge about labels.
 665
 666 underscorePrefix :: Bool   -- leading underscore on assembler labels?
 667 underscorePrefix = (cLeadingUnderscore == "YES")
 668
 669 asmTempLabelPrefix :: LitString  -- for formatting labels
 670 asmTempLabelPrefix =
 671 #if alpha_TARGET_OS
 672      {- The alpha assembler likes temporary labels to look like $L123
 673         instead of L123.  (Don't toss the L, because then Lf28
 674         turns into $f28.)
 675      -}
 676      SLIT("$")
 677 #elif darwin_TARGET_OS
 678      SLIT("L")
 679 #else
 680      SLIT(".L")
 681 #endif