ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.40 2000/10/16 13:57:43 sewardj 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         mkMainRegTableLabel,
  48         mkCharlikeClosureLabel,
  49         mkIntlikeClosureLabel,
  50         mkMAP_FROZEN_infoLabel,
  51
  52         mkTopTickyCtrLabel,
  53         mkBlackHoleInfoTableLabel,
  54         mkCAFBlackHoleInfoTableLabel,
  55         mkSECAFBlackHoleInfoTableLabel,
  56         mkRtsPrimOpLabel,
  57
  58         moduleRegdLabel,
  59
  60         mkSelectorInfoLabel,
  61         mkSelectorEntryLabel,
  62
  63         mkForeignLabel,
  64
  65         mkCC_Label, mkCCS_Label,
  66
  67         needsCDecl, isAsmTemp, externallyVisibleCLabel,
  68
  69         CLabelType(..), labelType, labelDynamic,
  70
  71         pprCLabel
  72 #if ! OMIT_NATIVE_CODEGEN
  73         , pprCLabel_asm
  74 #endif
  75     ) where
  76
  77
  78 #include "HsVersions.h"
  79
  80 #if ! OMIT_NATIVE_CODEGEN
  81 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
  82 #endif
  83
  84 import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
  85 import CStrings         ( pp_cSEP )
  86 import DataCon          ( ConTag, DataCon )
  87 import Module           ( ModuleName, moduleName, moduleNameFS,
  88                           Module, isModuleInThisPackage )
  89 import Name             ( Name, getName, isDllName, isExternallyVisibleName )
  90 import TyCon            ( TyCon )
  91 import Unique           ( pprUnique, Unique )
  92 import PrimOp           ( PrimOp, pprPrimOp )
  93 import CostCentre       ( CostCentre, CostCentreStack )
  94 import Util
  95 import Outputable
  96 \end{code}
  97
  98 things we want to find out:
  99
 100 * should the labelled things be declared "static" (visible only in this file)?
 101
 102 * should it be declared "const" (read-only text space)?
 103
 104 * does it need declarations at all? (v common Prelude things are pre-declared)
 105
 106 * what type does it have? (for generating accurate enough C declarations
 107   so that the C compiler won't complain).
 108
 109 \begin{code}
 110 data CLabel
 111   = IdLabel                     -- A family of labels related to the
 112         Name                    -- definition of a particular Id
 113         IdLabelInfo
 114
 115   | DataConLabel                -- Ditto data constructors
 116         Name
 117         DataConLabelInfo
 118
 119   | CaseLabel                   -- A family of labels related to a particular case expression
 120         Unique                  -- Unique says which case expression
 121         CaseLabelInfo
 122
 123   | TyConLabel TyCon            -- currently only one kind of TyconLabel,
 124                                 -- a 'Closure Table'.
 125
 126   | AsmTempLabel    Unique
 127
 128   | ModuleInitLabel Module
 129
 130   | RtsLabel        RtsLabelInfo
 131
 132   | ForeignLabel FAST_STRING Bool  -- a 'C' (or otherwise foreign) label
 133                                    -- Bool <=> is dynamic
 134
 135   | CC_Label CostCentre
 136   | CCS_Label CostCentreStack
 137
 138   deriving (Eq, Ord)
 139 \end{code}
 140
 141 \begin{code}
 142 data IdLabelInfo
 143   = Closure             -- Label for (static???) closure
 144
 145   | SRT                 -- Static reference table
 146
 147   | InfoTbl             -- Info table for a closure; always read-only
 148
 149   | EntryStd            -- Thunk, or "slow", code entry point
 150
 151   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 152                         -- Int is the arity of the function (to be
 153                         -- encoded into the name)
 154
 155                         -- Ticky-ticky counting
 156   | RednCounts          -- Label of place to keep reduction-count info for
 157                         -- this Id
 158   deriving (Eq, Ord)
 159
 160 data DataConLabelInfo
 161   = ConEntry            -- the only kind of entry pt for constructors
 162   | ConInfoTbl          -- corresponding info table
 163   | StaticConEntry      -- static constructor entry point
 164   | StaticInfoTbl       -- corresponding info table
 165   deriving (Eq, Ord)
 166
 167 data CaseLabelInfo
 168   = CaseReturnPt
 169   | CaseReturnInfo
 170   | CaseVecTbl
 171   | CaseAlt ConTag
 172   | CaseDefault
 173   | CaseBitmap
 174   deriving (Eq, Ord)
 175
 176 data RtsLabelInfo
 177   = RtsShouldNeverHappenCode
 178
 179   | RtsBlackHoleInfoTbl FAST_STRING  -- black hole with info table name
 180
 181   | RtsUpdInfo                  -- upd_frame_info
 182   | RtsSeqInfo                  -- seq_frame_info
 183   | RtsGCEntryLabel String      -- a heap check fail handler, eg  stg_chk_2
 184   | RtsMainRegTable             -- MainRegTable (??? Capabilities wurble ???)
 185   | Rts_Closure String          -- misc rts closures, eg CHARLIKE_closure
 186   | Rts_Info String             -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
 187   | Rts_Code String             -- misc rts code
 188
 189   | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}  -- Selector thunks
 190   | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
 191
 192   | RtsApInfoTbl Bool{-updatable-} Int{-arity-}         -- AP thunks
 193   | RtsApEntry   Bool{-updatable-} Int{-arity-}
 194
 195   | RtsPrimOp PrimOp
 196
 197   | RtsTopTickyCtr
 198
 199   | RtsModuleRegd
 200
 201   deriving (Eq, Ord)
 202
 203 -- Label Type: for generating C declarations.
 204
 205 data CLabelType
 206   = InfoTblType
 207   | ClosureType
 208   | VecTblType
 209   | ClosureTblType
 210   | CodeType
 211   | DataType
 212 \end{code}
 213
 214 \begin{code}
 215 mkClosureLabel          id              = IdLabel id  Closure
 216 mkSRTLabel              id              = IdLabel id  SRT
 217 mkInfoTableLabel        id              = IdLabel id  InfoTbl
 218 mkStdEntryLabel         id              = IdLabel id  EntryStd
 219 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 220                                           IdLabel id  (EntryFast arity)
 221
 222 mkRednCountsLabel       id              = IdLabel id  RednCounts
 223
 224 mkStaticInfoTableLabel  con             = DataConLabel con StaticInfoTbl
 225 mkConInfoTableLabel     con             = DataConLabel con ConInfoTbl
 226 mkConEntryLabel         con             = DataConLabel con ConEntry
 227 mkStaticConEntryLabel   con             = DataConLabel con StaticConEntry
 228
 229
 230 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 231 mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
 232 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 233 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 234 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 235 mkBitmapLabel   uniq            = CaseLabel uniq CaseBitmap
 236
 237 mkClosureTblLabel tycon         = TyConLabel tycon
 238
 239 mkAsmTempLabel                  = AsmTempLabel
 240
 241 mkModuleInitLabel               = ModuleInitLabel
 242
 243         -- Some fixed runtime system labels
 244
 245 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 246 mkStgUpdatePAPLabel             = RtsLabel (Rts_Code "stg_update_PAP")
 247 mkSplitMarkerLabel              = RtsLabel (Rts_Code "__stg_split_marker")
 248 mkUpdInfoLabel                  = RtsLabel RtsUpdInfo
 249 mkSeqInfoLabel                  = RtsLabel RtsSeqInfo
 250 mkIndInfoLabel                  = RtsLabel (Rts_Info "IND_info")
 251 mkIndStaticInfoLabel            = RtsLabel (Rts_Info "IND_STATIC_info")
 252 mkRtsGCEntryLabel str           = RtsLabel (RtsGCEntryLabel str)
 253 mkMainRegTableLabel             = RtsLabel RtsMainRegTable
 254 mkCharlikeClosureLabel          = RtsLabel (Rts_Closure "CHARLIKE_closure")
 255 mkIntlikeClosureLabel           = RtsLabel (Rts_Closure "INTLIKE_closure")
 256 mkMAP_FROZEN_infoLabel          = RtsLabel (Rts_Info "MUT_ARR_PTRS_FROZEN_info")
 257
 258 mkTopTickyCtrLabel              = RtsLabel RtsTopTickyCtr
 259 mkBlackHoleInfoTableLabel       = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
 260 mkCAFBlackHoleInfoTableLabel    = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
 261 mkSECAFBlackHoleInfoTableLabel  = if opt_DoTickyProfiling then
 262                                     RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
 263                                   else  -- RTS won't have info table unless -ticky is on
 264                                     panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 265 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 266
 267 moduleRegdLabel                 = RtsLabel RtsModuleRegd
 268
 269 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTbl upd off)
 270 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry   upd off)
 271
 272 mkApInfoTableLabel  upd off     = RtsLabel (RtsApInfoTbl upd off)
 273 mkApEntryLabel upd off          = RtsLabel (RtsApEntry   upd off)
 274
 275         -- Foreign labels
 276
 277 mkForeignLabel :: FAST_STRING -> Bool -> CLabel
 278 mkForeignLabel str is_dynamic   = ForeignLabel str is_dynamic
 279
 280         -- Cost centres etc.
 281
 282 mkCC_Label      cc              = CC_Label cc
 283 mkCCS_Label     ccs             = CCS_Label ccs
 284 \end{code}
 285
 286 \begin{code}
 287 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 288 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 289 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 290 \end{code}
 291
 292 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 293 object.  {\em Also:} No need to spit out labels for things generated
 294 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 295 to them are always backwards.  These are return-point and vector-table
 296 labels.
 297
 298 Declarations for (non-prelude) @Id@-based things are needed because of
 299 mutual recursion.
 300
 301 Declarations for direct return points are needed, because they may be
 302 let-no-escapes, which can be recursive.
 303
 304 \begin{code}
 305 needsCDecl (IdLabel _ _)                = True
 306 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 307 needsCDecl (DataConLabel _ _)           = True
 308 needsCDecl (TyConLabel _)               = True
 309 needsCDecl (ModuleInitLabel _)          = True
 310
 311 needsCDecl (CaseLabel _ _)              = False
 312 needsCDecl (AsmTempLabel _)             = False
 313 needsCDecl (RtsLabel _)                 = False
 314 needsCDecl (ForeignLabel _ _)           = False
 315 needsCDecl (CC_Label _)                 = False
 316 needsCDecl (CCS_Label _)                = False
 317 \end{code}
 318
 319 Whether the label is an assembler temporary:
 320
 321 \begin{code}
 322 isAsmTemp (AsmTempLabel _) = True
 323 isAsmTemp _                = False
 324 \end{code}
 325
 326 C ``static'' or not...
 327 From the point of view of the code generator, a name is
 328 externally visible if it has to be declared as exported
 329 in the .o file's symbol table; that is, made non-static.
 330
 331 \begin{code}
 332 externallyVisibleCLabel (DataConLabel _ _) = True
 333 externallyVisibleCLabel (TyConLabel tc)    = True
 334 externallyVisibleCLabel (CaseLabel _ _)    = False
 335 externallyVisibleCLabel (AsmTempLabel _)   = False
 336 externallyVisibleCLabel (ModuleInitLabel _)= True
 337 externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
 338 externallyVisibleCLabel (RtsLabel _)       = True
 339 externallyVisibleCLabel (ForeignLabel _ _) = True
 340 externallyVisibleCLabel (IdLabel id _)     = isExternallyVisibleName id
 341 externallyVisibleCLabel (CC_Label _)       = False -- not strictly true
 342 externallyVisibleCLabel (CCS_Label _)      = False -- not strictly true
 343 \end{code}
 344
 345 For generating correct types in label declarations...
 346
 347 \begin{code}
 348 labelType :: CLabel -> CLabelType
 349 labelType (RtsLabel (RtsBlackHoleInfoTbl _))  = InfoTblType
 350 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
 351 labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
 352 labelType (RtsLabel RtsUpdInfo)               = 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 (isModuleInThisPackage 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 -- specialised for PprAsm: saves lots of arg passing in NCG
 434 #if ! OMIT_NATIVE_CODEGEN
 435 pprCLabel_asm = pprCLabel
 436 #endif
 437
 438 pprCLabel :: CLabel -> SDoc
 439
 440 #if ! OMIT_NATIVE_CODEGEN
 441 pprCLabel (AsmTempLabel u)
 442   = text (fmtAsmLbl (show u))
 443 #endif
 444
 445 pprCLabel lbl =
 446 #if ! OMIT_NATIVE_CODEGEN
 447     getPprStyle $ \ sty ->
 448     if asmStyle sty && underscorePrefix then
 449        pp_cSEP <> pprCLbl lbl
 450     else
 451 #endif
 452        pprCLbl lbl
 453
 454 pprCLbl (CaseLabel u CaseReturnPt)
 455   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 456 pprCLbl (CaseLabel u CaseReturnInfo)
 457   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 458 pprCLbl (CaseLabel u CaseVecTbl)
 459   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 460 pprCLbl (CaseLabel u (CaseAlt tag))
 461   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 462 pprCLbl (CaseLabel u CaseDefault)
 463   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 464 pprCLbl (CaseLabel u CaseBitmap)
 465   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 466
 467 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
 468 -- used to be stg_error_entry but Windows can't have DLL entry points as static
 469 -- initialisers, and besides, this ShouldNeverHappen, right?
 470
 471 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("upd_frame_info")
 472 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("seq_frame_info")
 473 pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
 474 pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
 475 pprCLbl (RtsLabel (Rts_Closure str))     = text str
 476 pprCLbl (RtsLabel (Rts_Info str))        = text str
 477 pprCLbl (RtsLabel (Rts_Code str))        = text str
 478
 479 pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 480
 481 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 482
 483 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 484   = hcat [ptext SLIT("__sel_"), text (show offset),
 485                 ptext (if upd_reqd
 486                         then SLIT("_upd_info")
 487                         else SLIT("_noupd_info"))
 488         ]
 489
 490 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 491   = hcat [ptext SLIT("__sel_"), text (show offset),
 492                 ptext (if upd_reqd
 493                         then SLIT("_upd_entry")
 494                         else SLIT("_noupd_entry"))
 495         ]
 496
 497 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 498   = hcat [ptext SLIT("__ap_"), text (show arity),
 499                 ptext (if upd_reqd
 500                         then SLIT("_upd_info")
 501                         else SLIT("_noupd_info"))
 502         ]
 503
 504 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 505   = hcat [ptext SLIT("__ap_"), text (show arity),
 506                 ptext (if upd_reqd
 507                         then SLIT("_upd_entry")
 508                         else SLIT("_noupd_entry"))
 509         ]
 510
 511 pprCLbl (RtsLabel (RtsPrimOp primop))
 512   = pprPrimOp primop <> ptext SLIT("_fast")
 513
 514 pprCLbl (RtsLabel RtsModuleRegd)
 515   = ptext SLIT("module_registered")
 516
 517 pprCLbl (ForeignLabel str _)
 518   = ptext str
 519
 520 pprCLbl (TyConLabel tc)
 521   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 522
 523 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 524 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 525
 526 pprCLbl (CC_Label cc)           = ppr cc
 527 pprCLbl (CCS_Label ccs)         = ppr ccs
 528
 529 pprCLbl (ModuleInitLabel mod)
 530    = ptext SLIT("__init_") <> ptext (moduleNameFS (moduleName mod))
 531
 532 ppIdFlavor :: IdLabelInfo -> SDoc
 533
 534 ppIdFlavor x = pp_cSEP <>
 535                (case x of
 536                        Closure          -> ptext SLIT("closure")
 537                        SRT              -> ptext SLIT("srt")
 538                        InfoTbl          -> ptext SLIT("info")
 539                        EntryStd         -> ptext SLIT("entry")
 540                        EntryFast arity  -> --false:ASSERT (arity > 0)
 541                                            (<>) (ptext SLIT("fast")) (int arity)
 542                        RednCounts       -> ptext SLIT("ct")
 543                       )
 544
 545 ppConFlavor x = pp_cSEP <>
 546                 (case x of
 547                        ConEntry         -> ptext SLIT("con_entry")
 548                        ConInfoTbl       -> ptext SLIT("con_info")
 549                        StaticConEntry   -> ptext SLIT("static_entry")
 550                        StaticInfoTbl    -> ptext SLIT("static_info")
 551                 )
 552 \end{code}
 553