ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.51 2002/03/14 15:27:15 simonpj Exp $
   5 %
   6 \section[CLabel]{@CLabel@: Information to make C Labels}
   7
   8 \begin{code}
   9 module CLabel (
  10         CLabel, -- abstract type
  11
  12         mkClosureLabel,
  13         mkSRTLabel,
  14         mkInfoTableLabel,
  15         mkStdEntryLabel,
  16         mkFastEntryLabel,
  17         mkConEntryLabel,
  18         mkStaticConEntryLabel,
  19         mkRednCountsLabel,
  20         mkConInfoTableLabel,
  21         mkStaticInfoTableLabel,
  22         mkApEntryLabel,
  23         mkApInfoTableLabel,
  24
  25         mkReturnPtLabel,
  26         mkReturnInfoLabel,
  27         mkVecTblLabel,
  28         mkAltLabel,
  29         mkDefaultLabel,
  30         mkBitmapLabel,
  31
  32         mkClosureTblLabel,
  33
  34         mkAsmTempLabel,
  35
  36         mkModuleInitLabel,
  37
  38         mkErrorStdEntryLabel,
  39
  40         mkStgUpdatePAPLabel,
  41         mkSplitMarkerLabel,
  42         mkUpdInfoLabel,
  43         mkSeqInfoLabel,
  44         mkIndInfoLabel,
  45         mkIndStaticInfoLabel,
  46         mkRtsGCEntryLabel,
  47         mkMainCapabilityLabel,
  48         mkCharlikeClosureLabel,
  49         mkIntlikeClosureLabel,
  50         mkMAP_FROZEN_infoLabel,
  51         mkEMPTY_MVAR_infoLabel,
  52
  53         mkTopTickyCtrLabel,
  54         mkBlackHoleInfoTableLabel,
  55         mkCAFBlackHoleInfoTableLabel,
  56         mkSECAFBlackHoleInfoTableLabel,
  57         mkRtsPrimOpLabel,
  58
  59         moduleRegdLabel,
  60
  61         mkSelectorInfoLabel,
  62         mkSelectorEntryLabel,
  63
  64         mkForeignLabel,
  65
  66         mkCC_Label, mkCCS_Label,
  67
  68         needsCDecl, isAsmTemp, externallyVisibleCLabel,
  69
  70         CLabelType(..), labelType, labelDynamic,
  71
  72         pprCLabel
  73     ) where
  74
  75
  76 #include "HsVersions.h"
  77
  78 #if ! OMIT_NATIVE_CODEGEN
  79 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
  80 #endif
  81
  82 import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
  83 import CStrings         ( pp_cSEP )
  84 import DataCon          ( ConTag )
  85 import Module           ( moduleName, moduleNameFS,
  86                           Module, isHomeModule )
  87 import Name             ( Name, getName, isDllName, isExternalName )
  88 import TyCon            ( TyCon )
  89 import Unique           ( pprUnique, Unique )
  90 import PrimOp           ( PrimOp )
  91 import CostCentre       ( CostCentre, CostCentreStack )
  92 import Outputable
  93 \end{code}
  94
  95 things we want to find out:
  96
  97 * should the labelled things be declared "static" (visible only in this file)?
  98
  99 * should it be declared "const" (read-only text space)?
 100
 101 * does it need declarations at all? (v common Prelude things are pre-declared)
 102
 103 * what type does it have? (for generating accurate enough C declarations
 104   so that the C compiler won't complain).
 105
 106 \begin{code}
 107 data CLabel
 108   = IdLabel                     -- A family of labels related to the
 109         Name                    -- definition of a particular Id
 110         IdLabelInfo
 111
 112   | DataConLabel                -- Ditto data constructors
 113         Name
 114         DataConLabelInfo
 115
 116   | CaseLabel                   -- A family of labels related to a particular case expression
 117         Unique                  -- Unique says which case expression
 118         CaseLabelInfo
 119
 120   | TyConLabel TyCon            -- currently only one kind of TyconLabel,
 121                                 -- a 'Closure Table'.
 122
 123   | AsmTempLabel    Unique
 124
 125   | ModuleInitLabel Module
 126
 127   | RtsLabel        RtsLabelInfo
 128
 129   | ForeignLabel FAST_STRING Bool  -- a 'C' (or otherwise foreign) label
 130                                    -- Bool <=> is dynamic
 131
 132   | CC_Label CostCentre
 133   | CCS_Label CostCentreStack
 134
 135   deriving (Eq, Ord)
 136 \end{code}
 137
 138 \begin{code}
 139 data IdLabelInfo
 140   = Closure             -- Label for (static???) closure
 141
 142   | SRT                 -- Static reference table
 143
 144   | InfoTbl             -- Info table for a closure; always read-only
 145
 146   | EntryStd            -- Thunk, or "slow", code entry point
 147
 148   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 149                         -- Int is the arity of the function (to be
 150                         -- encoded into the name)
 151
 152                         -- Ticky-ticky counting
 153   | RednCounts          -- Label of place to keep reduction-count info for
 154                         -- this Id
 155   deriving (Eq, Ord)
 156
 157 data DataConLabelInfo
 158   = ConEntry            -- the only kind of entry pt for constructors
 159   | ConInfoTbl          -- corresponding info table
 160   | StaticConEntry      -- static constructor entry point
 161   | StaticInfoTbl       -- corresponding info table
 162   deriving (Eq, Ord)
 163
 164 data CaseLabelInfo
 165   = CaseReturnPt
 166   | CaseReturnInfo
 167   | CaseVecTbl
 168   | CaseAlt ConTag
 169   | CaseDefault
 170   | CaseBitmap
 171   deriving (Eq, Ord)
 172
 173 data RtsLabelInfo
 174   = RtsShouldNeverHappenCode
 175
 176   | RtsBlackHoleInfoTbl FAST_STRING  -- black hole with info table name
 177
 178   | RtsUpdInfo                  -- upd_frame_info
 179   | RtsSeqInfo                  -- seq_frame_info
 180   | RtsGCEntryLabel String      -- a heap check fail handler, eg  stg_chk_2
 181   | RtsMainCapability           -- MainCapability
 182   | Rts_Closure String          -- misc rts closures, eg CHARLIKE_closure
 183   | Rts_Info String             -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
 184   | Rts_Code String             -- misc rts code
 185
 186   | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}  -- Selector thunks
 187   | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
 188
 189   | RtsApInfoTbl Bool{-updatable-} Int{-arity-}         -- AP thunks
 190   | RtsApEntry   Bool{-updatable-} Int{-arity-}
 191
 192   | RtsPrimOp PrimOp
 193
 194   | RtsTopTickyCtr
 195
 196   | RtsModuleRegd
 197
 198   deriving (Eq, Ord)
 199
 200 -- Label Type: for generating C declarations.
 201
 202 data CLabelType
 203   = InfoTblType
 204   | ClosureType
 205   | VecTblType
 206   | ClosureTblType
 207   | CodeType
 208   | DataType
 209 \end{code}
 210
 211 \begin{code}
 212 mkClosureLabel          id              = IdLabel id  Closure
 213 mkSRTLabel              id              = IdLabel id  SRT
 214 mkInfoTableLabel        id              = IdLabel id  InfoTbl
 215 mkStdEntryLabel         id              = IdLabel id  EntryStd
 216 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 217                                           IdLabel id  (EntryFast arity)
 218
 219 mkRednCountsLabel       id              = IdLabel id  RednCounts
 220
 221 mkStaticInfoTableLabel  con             = DataConLabel con StaticInfoTbl
 222 mkConInfoTableLabel     con             = DataConLabel con ConInfoTbl
 223 mkConEntryLabel         con             = DataConLabel con ConEntry
 224 mkStaticConEntryLabel   con             = DataConLabel con StaticConEntry
 225
 226
 227 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 228 mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
 229 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 230 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 231 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 232 mkBitmapLabel   uniq            = CaseLabel uniq CaseBitmap
 233
 234 mkClosureTblLabel tycon         = TyConLabel tycon
 235
 236 mkAsmTempLabel                  = AsmTempLabel
 237
 238 mkModuleInitLabel               = ModuleInitLabel
 239
 240         -- Some fixed runtime system labels
 241
 242 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 243 mkStgUpdatePAPLabel             = RtsLabel (Rts_Code "stg_update_PAP")
 244 mkSplitMarkerLabel              = RtsLabel (Rts_Code "__stg_split_marker")
 245 mkUpdInfoLabel                  = RtsLabel RtsUpdInfo
 246 mkSeqInfoLabel                  = RtsLabel RtsSeqInfo
 247 mkIndInfoLabel                  = RtsLabel (Rts_Info "stg_IND_info")
 248 mkIndStaticInfoLabel            = RtsLabel (Rts_Info "stg_IND_STATIC_info")
 249 mkRtsGCEntryLabel str           = RtsLabel (RtsGCEntryLabel str)
 250 mkMainCapabilityLabel           = RtsLabel RtsMainCapability
 251 mkCharlikeClosureLabel          = RtsLabel (Rts_Closure "stg_CHARLIKE_closure")
 252 mkIntlikeClosureLabel           = RtsLabel (Rts_Closure "stg_INTLIKE_closure")
 253 mkMAP_FROZEN_infoLabel          = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
 254 mkEMPTY_MVAR_infoLabel          = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info")
 255
 256 mkTopTickyCtrLabel              = RtsLabel RtsTopTickyCtr
 257 mkBlackHoleInfoTableLabel       = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
 258 mkCAFBlackHoleInfoTableLabel    = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
 259 mkSECAFBlackHoleInfoTableLabel  = if opt_DoTickyProfiling then
 260                                     RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info"))
 261                                   else  -- RTS won't have info table unless -ticky is on
 262                                     panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 263 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 264
 265 moduleRegdLabel                 = RtsLabel RtsModuleRegd
 266
 267 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTbl upd off)
 268 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry   upd off)
 269
 270 mkApInfoTableLabel  upd off     = RtsLabel (RtsApInfoTbl upd off)
 271 mkApEntryLabel upd off          = RtsLabel (RtsApEntry   upd off)
 272
 273         -- Foreign labels
 274
 275 mkForeignLabel :: FAST_STRING -> Bool -> CLabel
 276 mkForeignLabel str is_dynamic   = ForeignLabel str is_dynamic
 277
 278         -- Cost centres etc.
 279
 280 mkCC_Label      cc              = CC_Label cc
 281 mkCCS_Label     ccs             = CCS_Label ccs
 282 \end{code}
 283
 284 \begin{code}
 285 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 286 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 287 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 288 \end{code}
 289
 290 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 291 object.  {\em Also:} No need to spit out labels for things generated
 292 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 293 to them are always backwards.  These are return-point and vector-table
 294 labels.
 295
 296 Declarations for (non-prelude) @Id@-based things are needed because of
 297 mutual recursion.
 298
 299 Declarations for direct return points are needed, because they may be
 300 let-no-escapes, which can be recursive.
 301
 302 \begin{code}
 303 needsCDecl (IdLabel _ _)                = True
 304 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 305 needsCDecl (DataConLabel _ _)           = True
 306 needsCDecl (TyConLabel _)               = True
 307 needsCDecl (ModuleInitLabel _)          = True
 308
 309 needsCDecl (CaseLabel _ _)              = False
 310 needsCDecl (AsmTempLabel _)             = False
 311 needsCDecl (RtsLabel _)                 = False
 312 needsCDecl (ForeignLabel _ _)           = False
 313 needsCDecl (CC_Label _)                 = False
 314 needsCDecl (CCS_Label _)                = False
 315 \end{code}
 316
 317 Whether the label is an assembler temporary:
 318
 319 \begin{code}
 320 isAsmTemp (AsmTempLabel _) = True
 321 isAsmTemp _                = False
 322 \end{code}
 323
 324 C ``static'' or not...
 325 From the point of view of the code generator, a name is
 326 externally visible if it has to be declared as exported
 327 in the .o file's symbol table; that is, made non-static.
 328
 329 \begin{code}
 330 externallyVisibleCLabel (DataConLabel _ _) = True
 331 externallyVisibleCLabel (TyConLabel tc)    = True
 332 externallyVisibleCLabel (CaseLabel _ _)    = False
 333 externallyVisibleCLabel (AsmTempLabel _)   = False
 334 externallyVisibleCLabel (ModuleInitLabel _)= True
 335 externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
 336 externallyVisibleCLabel (RtsLabel _)       = True
 337 externallyVisibleCLabel (ForeignLabel _ _) = True
 338 externallyVisibleCLabel (IdLabel id _)     = isExternalName id
 339 externallyVisibleCLabel (CC_Label _)       = False -- not strictly true
 340 externallyVisibleCLabel (CCS_Label _)      = False -- not strictly true
 341 \end{code}
 342
 343 For generating correct types in label declarations...
 344
 345 \begin{code}
 346 labelType :: CLabel -> CLabelType
 347 labelType (RtsLabel (RtsBlackHoleInfoTbl _))  = InfoTblType
 348 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
 349 labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
 350 labelType (RtsLabel RtsUpdInfo)               = InfoTblType
 351 labelType (RtsLabel (Rts_Info _))             = InfoTblType
 352 labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
 353 labelType (CaseLabel _ CaseReturnPt)          = CodeType
 354 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 355 labelType (TyConLabel _)                      = ClosureTblType
 356 labelType (ModuleInitLabel _ )                = CodeType
 357
 358 labelType (IdLabel _ info) =
 359   case info of
 360     InfoTbl       -> InfoTblType
 361     Closure       -> ClosureType
 362     _             -> CodeType
 363
 364 labelType (DataConLabel _ info) =
 365   case info of
 366      ConInfoTbl    -> InfoTblType
 367      StaticInfoTbl -> InfoTblType
 368      _             -> CodeType
 369
 370 labelType _        = DataType
 371 \end{code}
 372
 373 When referring to data in code, we need to know whether
 374 that data resides in a DLL or not. [Win32 only.]
 375 @labelDynamic@ returns @True@ if the label is located
 376 in a DLL, be it a data reference or not.
 377
 378 \begin{code}
 379 labelDynamic :: CLabel -> Bool
 380 labelDynamic lbl =
 381   case lbl of
 382    -- The special case for RtsShouldNeverHappenCode is because the associated address is
 383    -- NULL, i.e. not a DLL entry point
 384    RtsLabel RtsShouldNeverHappenCode -> False
 385    RtsLabel _        -> not opt_Static  -- i.e., is the RTS in a DLL or not?
 386    IdLabel n k       -> isDllName n
 387    DataConLabel n k  -> isDllName n
 388    TyConLabel tc     -> isDllName (getName tc)
 389    ForeignLabel _ d  -> d
 390    ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
 391    _                 -> False
 392 \end{code}
 393
 394
 395 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 396 right places. It is used to detect when the abstractC statement of an
 397 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 398
 399 We need at least @Eq@ for @CLabels@, because we want to avoid
 400 duplicate declarations in generating C (see @labelSeenTE@ in
 401 @PprAbsC@).
 402
 403 -----------------------------------------------------------------------------
 404 Printing out CLabels.
 405
 406 Convention:
 407
 408       <name>_<type>
 409
 410 where <name> is <Module>_<name> for external names and <unique> for
 411 internal names. <type> is one of the following:
 412
 413          info                   Info table
 414          srt                    Static reference table
 415          entry                  Entry code
 416          ret                    Direct return address
 417          vtbl                   Vector table
 418          <n>_alt                Case alternative (tag n)
 419          dflt                   Default case alternative
 420          btm                    Large bitmap vector
 421          closure                Static closure
 422          con_entry              Dynamic Constructor entry code
 423          con_info               Dynamic Constructor info table
 424          static_entry           Static Constructor entry code
 425          static_info            Static Constructor info table
 426          sel_info               Selector info table
 427          sel_entry              Selector entry code
 428          cc                     Cost centre
 429          ccs                    Cost centre stack
 430
 431 \begin{code}
 432 pprCLabel :: CLabel -> SDoc
 433
 434 #if ! OMIT_NATIVE_CODEGEN
 435 pprCLabel (AsmTempLabel u)
 436   = text (fmtAsmLbl (show u))
 437 #endif
 438
 439 pprCLabel lbl =
 440 #if ! OMIT_NATIVE_CODEGEN
 441     getPprStyle $ \ sty ->
 442     if asmStyle sty && underscorePrefix then
 443        pp_cSEP <> pprCLbl lbl
 444     else
 445 #endif
 446        pprCLbl lbl
 447
 448 pprCLbl (CaseLabel u CaseReturnPt)
 449   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 450 pprCLbl (CaseLabel u CaseReturnInfo)
 451   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 452 pprCLbl (CaseLabel u CaseVecTbl)
 453   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 454 pprCLbl (CaseLabel u (CaseAlt tag))
 455   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 456 pprCLbl (CaseLabel u CaseDefault)
 457   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 458 pprCLbl (CaseLabel u CaseBitmap)
 459   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 460
 461 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
 462 -- used to be stg_error_entry but Windows can't have DLL entry points as static
 463 -- initialisers, and besides, this ShouldNeverHappen, right?
 464
 465 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("stg_upd_frame_info")
 466 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("stg_seq_frame_info")
 467 pprCLbl (RtsLabel RtsMainCapability)     = ptext SLIT("MainCapability")
 468 pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
 469 pprCLbl (RtsLabel (Rts_Closure str))     = text str
 470 pprCLbl (RtsLabel (Rts_Info str))        = text str
 471 pprCLbl (RtsLabel (Rts_Code str))        = text str
 472
 473 pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 474
 475 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 476
 477 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 478   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 479                 ptext (if upd_reqd
 480                         then SLIT("_upd_info")
 481                         else SLIT("_noupd_info"))
 482         ]
 483
 484 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 485   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 486                 ptext (if upd_reqd
 487                         then SLIT("_upd_entry")
 488                         else SLIT("_noupd_entry"))
 489         ]
 490
 491 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 492   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 493                 ptext (if upd_reqd
 494                         then SLIT("_upd_info")
 495                         else SLIT("_noupd_info"))
 496         ]
 497
 498 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 499   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 500                 ptext (if upd_reqd
 501                         then SLIT("_upd_entry")
 502                         else SLIT("_noupd_entry"))
 503         ]
 504
 505 pprCLbl (RtsLabel (RtsPrimOp primop))
 506   = ppr primop <> ptext SLIT("_fast")
 507
 508 pprCLbl (RtsLabel RtsModuleRegd)
 509   = ptext SLIT("module_registered")
 510
 511 pprCLbl (ForeignLabel str _)
 512   = ptext str
 513
 514 pprCLbl (TyConLabel tc)
 515   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 516
 517 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 518 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 519
 520 pprCLbl (CC_Label cc)           = ppr cc
 521 pprCLbl (CCS_Label ccs)         = ppr ccs
 522
 523 pprCLbl (ModuleInitLabel mod)
 524    = ptext SLIT("__stginit_") <> ptext (moduleNameFS (moduleName mod))
 525
 526 ppIdFlavor :: IdLabelInfo -> SDoc
 527
 528 ppIdFlavor x = pp_cSEP <>
 529                (case x of
 530                        Closure          -> ptext SLIT("closure")
 531                        SRT              -> ptext SLIT("srt")
 532                        InfoTbl          -> ptext SLIT("info")
 533                        EntryStd         -> ptext SLIT("entry")
 534                        EntryFast arity  -> --false:ASSERT (arity > 0)
 535                                            (<>) (ptext SLIT("fast")) (int arity)
 536                        RednCounts       -> ptext SLIT("ct")
 537                       )
 538
 539 ppConFlavor x = pp_cSEP <>
 540                 (case x of
 541                        ConEntry         -> ptext SLIT("con_entry")
 542                        ConInfoTbl       -> ptext SLIT("con_info")
 543                        StaticConEntry   -> ptext SLIT("static_entry")
 544                        StaticInfoTbl    -> ptext SLIT("static_info")
 545                 )
 546 \end{code}
 547