ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.44 2000/12/04 12:31:19 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
  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 )
  87 import Module           ( moduleName, moduleNameFS,
  88                           Module, isHomeModule )
  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 Outputable
  95 \end{code}
  96
  97 things we want to find out:
  98
  99 * should the labelled things be declared "static" (visible only in this file)?
 100
 101 * should it be declared "const" (read-only text space)?
 102
 103 * does it need declarations at all? (v common Prelude things are pre-declared)
 104
 105 * what type does it have? (for generating accurate enough C declarations
 106   so that the C compiler won't complain).
 107
 108 \begin{code}
 109 data CLabel
 110   = IdLabel                     -- A family of labels related to the
 111         Name                    -- definition of a particular Id
 112         IdLabelInfo
 113
 114   | DataConLabel                -- Ditto data constructors
 115         Name
 116         DataConLabelInfo
 117
 118   | CaseLabel                   -- A family of labels related to a particular case expression
 119         Unique                  -- Unique says which case expression
 120         CaseLabelInfo
 121
 122   | TyConLabel TyCon            -- currently only one kind of TyconLabel,
 123                                 -- a 'Closure Table'.
 124
 125   | AsmTempLabel    Unique
 126
 127   | ModuleInitLabel Module
 128
 129   | RtsLabel        RtsLabelInfo
 130
 131   | ForeignLabel FAST_STRING Bool  -- a 'C' (or otherwise foreign) label
 132                                    -- Bool <=> is dynamic
 133
 134   | CC_Label CostCentre
 135   | CCS_Label CostCentreStack
 136
 137   deriving (Eq, Ord)
 138 \end{code}
 139
 140 \begin{code}
 141 data IdLabelInfo
 142   = Closure             -- Label for (static???) closure
 143
 144   | SRT                 -- Static reference table
 145
 146   | InfoTbl             -- Info table for a closure; always read-only
 147
 148   | EntryStd            -- Thunk, or "slow", code entry point
 149
 150   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 151                         -- Int is the arity of the function (to be
 152                         -- encoded into the name)
 153
 154                         -- Ticky-ticky counting
 155   | RednCounts          -- Label of place to keep reduction-count info for
 156                         -- this Id
 157   deriving (Eq, Ord)
 158
 159 data DataConLabelInfo
 160   = ConEntry            -- the only kind of entry pt for constructors
 161   | ConInfoTbl          -- corresponding info table
 162   | StaticConEntry      -- static constructor entry point
 163   | StaticInfoTbl       -- corresponding info table
 164   deriving (Eq, Ord)
 165
 166 data CaseLabelInfo
 167   = CaseReturnPt
 168   | CaseReturnInfo
 169   | CaseVecTbl
 170   | CaseAlt ConTag
 171   | CaseDefault
 172   | CaseBitmap
 173   deriving (Eq, Ord)
 174
 175 data RtsLabelInfo
 176   = RtsShouldNeverHappenCode
 177
 178   | RtsBlackHoleInfoTbl FAST_STRING  -- black hole with info table name
 179
 180   | RtsUpdInfo                  -- upd_frame_info
 181   | RtsSeqInfo                  -- seq_frame_info
 182   | RtsGCEntryLabel String      -- a heap check fail handler, eg  stg_chk_2
 183   | RtsMainRegTable             -- MainRegTable (??? Capabilities wurble ???)
 184   | Rts_Closure String          -- misc rts closures, eg CHARLIKE_closure
 185   | Rts_Info String             -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
 186   | Rts_Code String             -- misc rts code
 187
 188   | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}  -- Selector thunks
 189   | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
 190
 191   | RtsApInfoTbl Bool{-updatable-} Int{-arity-}         -- AP thunks
 192   | RtsApEntry   Bool{-updatable-} Int{-arity-}
 193
 194   | RtsPrimOp PrimOp
 195
 196   | RtsTopTickyCtr
 197
 198   | RtsModuleRegd
 199
 200   deriving (Eq, Ord)
 201
 202 -- Label Type: for generating C declarations.
 203
 204 data CLabelType
 205   = InfoTblType
 206   | ClosureType
 207   | VecTblType
 208   | ClosureTblType
 209   | CodeType
 210   | DataType
 211 \end{code}
 212
 213 \begin{code}
 214 mkClosureLabel          id              = IdLabel id  Closure
 215 mkSRTLabel              id              = IdLabel id  SRT
 216 mkInfoTableLabel        id              = IdLabel id  InfoTbl
 217 mkStdEntryLabel         id              = IdLabel id  EntryStd
 218 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 219                                           IdLabel id  (EntryFast arity)
 220
 221 mkRednCountsLabel       id              = IdLabel id  RednCounts
 222
 223 mkStaticInfoTableLabel  con             = DataConLabel con StaticInfoTbl
 224 mkConInfoTableLabel     con             = DataConLabel con ConInfoTbl
 225 mkConEntryLabel         con             = DataConLabel con ConEntry
 226 mkStaticConEntryLabel   con             = DataConLabel con StaticConEntry
 227
 228
 229 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 230 mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
 231 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 232 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 233 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 234 mkBitmapLabel   uniq            = CaseLabel uniq CaseBitmap
 235
 236 mkClosureTblLabel tycon         = TyConLabel tycon
 237
 238 mkAsmTempLabel                  = AsmTempLabel
 239
 240 mkModuleInitLabel               = ModuleInitLabel
 241
 242         -- Some fixed runtime system labels
 243
 244 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 245 mkStgUpdatePAPLabel             = RtsLabel (Rts_Code "stg_update_PAP")
 246 mkSplitMarkerLabel              = RtsLabel (Rts_Code "__stg_split_marker")
 247 mkUpdInfoLabel                  = RtsLabel RtsUpdInfo
 248 mkSeqInfoLabel                  = RtsLabel RtsSeqInfo
 249 mkIndInfoLabel                  = RtsLabel (Rts_Info "stg_IND_info")
 250 mkIndStaticInfoLabel            = RtsLabel (Rts_Info "stg_IND_STATIC_info")
 251 mkRtsGCEntryLabel str           = RtsLabel (RtsGCEntryLabel str)
 252 mkMainRegTableLabel             = RtsLabel RtsMainRegTable
 253 mkCharlikeClosureLabel          = RtsLabel (Rts_Closure "stg_CHARLIKE_closure")
 254 mkIntlikeClosureLabel           = RtsLabel (Rts_Closure "stg_INTLIKE_closure")
 255 mkMAP_FROZEN_infoLabel          = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
 256
 257 mkTopTickyCtrLabel              = RtsLabel RtsTopTickyCtr
 258 mkBlackHoleInfoTableLabel       = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
 259 mkCAFBlackHoleInfoTableLabel    = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
 260 mkSECAFBlackHoleInfoTableLabel  = if opt_DoTickyProfiling then
 261                                     RtsLabel (RtsBlackHoleInfoTbl SLIT("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 :: FAST_STRING -> 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 _)     = isExternallyVisibleName 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 (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 -- specialised for PprAsm: saves lots of arg passing in NCG
 433 #if ! OMIT_NATIVE_CODEGEN
 434 pprCLabel_asm = pprCLabel
 435 #endif
 436
 437 pprCLabel :: CLabel -> SDoc
 438
 439 #if ! OMIT_NATIVE_CODEGEN
 440 pprCLabel (AsmTempLabel u)
 441   = text (fmtAsmLbl (show u))
 442 #endif
 443
 444 pprCLabel lbl =
 445 #if ! OMIT_NATIVE_CODEGEN
 446     getPprStyle $ \ sty ->
 447     if asmStyle sty && underscorePrefix then
 448        pp_cSEP <> pprCLbl lbl
 449     else
 450 #endif
 451        pprCLbl lbl
 452
 453 pprCLbl (CaseLabel u CaseReturnPt)
 454   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 455 pprCLbl (CaseLabel u CaseReturnInfo)
 456   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 457 pprCLbl (CaseLabel u CaseVecTbl)
 458   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 459 pprCLbl (CaseLabel u (CaseAlt tag))
 460   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 461 pprCLbl (CaseLabel u CaseDefault)
 462   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 463 pprCLbl (CaseLabel u CaseBitmap)
 464   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 465
 466 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
 467 -- used to be stg_error_entry but Windows can't have DLL entry points as static
 468 -- initialisers, and besides, this ShouldNeverHappen, right?
 469
 470 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("stg_upd_frame_info")
 471 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("stg_seq_frame_info")
 472 pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
 473 pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
 474 pprCLbl (RtsLabel (Rts_Closure str))     = text str
 475 pprCLbl (RtsLabel (Rts_Info str))        = text str
 476 pprCLbl (RtsLabel (Rts_Code str))        = text str
 477
 478 pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 479
 480 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 481
 482 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 483   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 484                 ptext (if upd_reqd
 485                         then SLIT("_upd_info")
 486                         else SLIT("_noupd_info"))
 487         ]
 488
 489 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 490   = hcat [ptext SLIT("stg_sel_"), text (show offset),
 491                 ptext (if upd_reqd
 492                         then SLIT("_upd_entry")
 493                         else SLIT("_noupd_entry"))
 494         ]
 495
 496 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 497   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 498                 ptext (if upd_reqd
 499                         then SLIT("_upd_info")
 500                         else SLIT("_noupd_info"))
 501         ]
 502
 503 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 504   = hcat [ptext SLIT("stg_ap_"), text (show arity),
 505                 ptext (if upd_reqd
 506                         then SLIT("_upd_entry")
 507                         else SLIT("_noupd_entry"))
 508         ]
 509
 510 pprCLbl (RtsLabel (RtsPrimOp primop))
 511   = pprPrimOp primop <> ptext SLIT("_fast")
 512
 513 pprCLbl (RtsLabel RtsModuleRegd)
 514   = ptext SLIT("module_registered")
 515
 516 pprCLbl (ForeignLabel str _)
 517   = ptext str
 518
 519 pprCLbl (TyConLabel tc)
 520   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 521
 522 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 523 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 524
 525 pprCLbl (CC_Label cc)           = ppr cc
 526 pprCLbl (CCS_Label ccs)         = ppr ccs
 527
 528 pprCLbl (ModuleInitLabel mod)
 529    = ptext SLIT("__init_") <> ptext (moduleNameFS (moduleName mod))
 530
 531 ppIdFlavor :: IdLabelInfo -> SDoc
 532
 533 ppIdFlavor x = pp_cSEP <>
 534                (case x of
 535                        Closure          -> ptext SLIT("closure")
 536                        SRT              -> ptext SLIT("srt")
 537                        InfoTbl          -> ptext SLIT("info")
 538                        EntryStd         -> ptext SLIT("entry")
 539                        EntryFast arity  -> --false:ASSERT (arity > 0)
 540                                            (<>) (ptext SLIT("fast")) (int arity)
 541                        RednCounts       -> ptext SLIT("ct")
 542                       )
 543
 544 ppConFlavor x = pp_cSEP <>
 545                 (case x of
 546                        ConEntry         -> ptext SLIT("con_entry")
 547                        ConInfoTbl       -> ptext SLIT("con_info")
 548                        StaticConEntry   -> ptext SLIT("static_entry")
 549                        StaticInfoTbl    -> ptext SLIT("static_info")
 550                 )
 551 \end{code}
 552