ghc/compiler/absCSyn/CLabel.lhs

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