ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.48 2001/11/08 12:56:01 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         mkMainRegTableLabel,
  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, isExternallyVisibleName )
  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   | RtsMainRegTable             -- MainRegTable (??? Capabilities wurble ???)
 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 mkMainRegTableLabel             = RtsLabel RtsMainRegTable
 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 _)     = isExternallyVisibleName 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 (CaseLabel _ CaseReturnInfo)        = InfoTblType
 352 labelType (CaseLabel _ CaseReturnPt)          = CodeType
 353 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 354 labelType (TyConLabel _)                      = ClosureTblType
 355 labelType (ModuleInitLabel _ )                = CodeType
 356
 357 labelType (IdLabel _ info) =
 358   case info of
 359     InfoTbl       -> InfoTblType
 360     Closure       -> ClosureType
 361     _             -> CodeType
 362
 363 labelType (DataConLabel _ info) =
 364   case info of
 365      ConInfoTbl    -> InfoTblType
 366      StaticInfoTbl -> InfoTblType
 367      _             -> CodeType
 368
 369 labelType _        = DataType
 370 \end{code}
 371
 372 When referring to data in code, we need to know whether
 373 that data resides in a DLL or not. [Win32 only.]
 374 @labelDynamic@ returns @True@ if the label is located
 375 in a DLL, be it a data reference or not.
 376
 377 \begin{code}
 378 labelDynamic :: CLabel -> Bool
 379 labelDynamic lbl =
 380   case lbl of
 381    -- The special case for RtsShouldNeverHappenCode is because the associated address is
 382    -- NULL, i.e. not a DLL entry point
 383    RtsLabel RtsShouldNeverHappenCode -> False
 384    RtsLabel _        -> not opt_Static  -- i.e., is the RTS in a DLL or not?
 385    IdLabel n k       -> isDllName n
 386    DataConLabel n k  -> isDllName n
 387    TyConLabel tc     -> isDllName (getName tc)
 388    ForeignLabel _ d  -> d
 389    ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
 390    _                 -> False
 391 \end{code}
 392
 393
 394 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 395 right places. It is used to detect when the abstractC statement of an
 396 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 397
 398 We need at least @Eq@ for @CLabels@, because we want to avoid
 399 duplicate declarations in generating C (see @labelSeenTE@ in
 400 @PprAbsC@).
 401
 402 -----------------------------------------------------------------------------
 403 Printing out CLabels.
 404
 405 Convention:
 406
 407       <name>_<type>
 408
 409 where <name> is <Module>_<name> for external names and <unique> for
 410 internal names. <type> is one of the following:
 411
 412          info                   Info table
 413          srt                    Static reference table
 414          entry                  Entry code
 415          ret                    Direct return address
 416          vtbl                   Vector table
 417          <n>_alt                Case alternative (tag n)
 418          dflt                   Default case alternative
 419          btm                    Large bitmap vector
 420          closure                Static closure
 421          con_entry              Dynamic Constructor entry code
 422          con_info               Dynamic Constructor info table
 423          static_entry           Static Constructor entry code
 424          static_info            Static Constructor info table
 425          sel_info               Selector info table
 426          sel_entry              Selector entry code
 427          cc                     Cost centre
 428          ccs                    Cost centre stack
 429
 430 \begin{code}
 431 pprCLabel :: CLabel -> SDoc
 432
 433 #if ! OMIT_NATIVE_CODEGEN
 434 pprCLabel (AsmTempLabel u)
 435   = text (fmtAsmLbl (show u))
 436 #endif
 437
 438 pprCLabel lbl =
 439 #if ! OMIT_NATIVE_CODEGEN
 440     getPprStyle $ \ sty ->
 441     if asmStyle sty && underscorePrefix then
 442        pp_cSEP <> pprCLbl lbl
 443     else
 444 #endif
 445        pprCLbl lbl
 446
 447 pprCLbl (CaseLabel u CaseReturnPt)
 448   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 449 pprCLbl (CaseLabel u CaseReturnInfo)
 450   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 451 pprCLbl (CaseLabel u CaseVecTbl)
 452   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 453 pprCLbl (CaseLabel u (CaseAlt tag))
 454   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 455 pprCLbl (CaseLabel u CaseDefault)
 456   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 457 pprCLbl (CaseLabel u CaseBitmap)
 458   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 459
 460 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
 461 -- used to be stg_error_entry but Windows can't have DLL entry points as static
 462 -- initialisers, and besides, this ShouldNeverHappen, right?
 463
 464 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("stg_upd_frame_info")
 465 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("stg_seq_frame_info")
 466 pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
 467 pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
 468 pprCLbl (RtsLabel (Rts_Closure str))     = text str
 469 pprCLbl (RtsLabel (Rts_Info str))        = text str
 470 pprCLbl (RtsLabel (Rts_Code str))        = text str
 471
 472 pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 473
 474 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 475
 476 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 477   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 478                 ptext (if upd_reqd
 479                         then SLIT("_upd_info")
 480                         else SLIT("_noupd_info"))
 481         ]
 482
 483 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 484   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 485                 ptext (if upd_reqd
 486                         then SLIT("_upd_entry")
 487                         else SLIT("_noupd_entry"))
 488         ]
 489
 490 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 491   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 492                 ptext (if upd_reqd
 493                         then SLIT("_upd_info")
 494                         else SLIT("_noupd_info"))
 495         ]
 496
 497 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 498   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 499                 ptext (if upd_reqd
 500                         then SLIT("_upd_entry")
 501                         else SLIT("_noupd_entry"))
 502         ]
 503
 504 pprCLbl (RtsLabel (RtsPrimOp primop))
 505   = ppr primop <> ptext SLIT("_fast")
 506
 507 pprCLbl (RtsLabel RtsModuleRegd)
 508   = ptext SLIT("module_registered")
 509
 510 pprCLbl (ForeignLabel str _)
 511   = ptext str
 512
 513 pprCLbl (TyConLabel tc)
 514   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 515
 516 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 517 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 518
 519 pprCLbl (CC_Label cc)           = ppr cc
 520 pprCLbl (CCS_Label ccs)         = ppr ccs
 521
 522 pprCLbl (ModuleInitLabel mod)
 523    = ptext SLIT("__stginit_") <> ptext (moduleNameFS (moduleName mod))
 524
 525 ppIdFlavor :: IdLabelInfo -> SDoc
 526
 527 ppIdFlavor x = pp_cSEP <>
 528                (case x of
 529                        Closure          -> ptext SLIT("closure")
 530                        SRT              -> ptext SLIT("srt")
 531                        InfoTbl          -> ptext SLIT("info")
 532                        EntryStd         -> ptext SLIT("entry")
 533                        EntryFast arity  -> --false:ASSERT (arity > 0)
 534                                            (<>) (ptext SLIT("fast")) (int arity)
 535                        RednCounts       -> ptext SLIT("ct")
 536                       )
 537
 538 ppConFlavor x = pp_cSEP <>
 539                 (case x of
 540                        ConEntry         -> ptext SLIT("con_entry")
 541                        ConInfoTbl       -> ptext SLIT("con_info")
 542                        StaticConEntry   -> ptext SLIT("static_entry")
 543                        StaticInfoTbl    -> ptext SLIT("static_info")
 544                 )
 545 \end{code}
 546