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