ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.37 2000/07/03 14:59:25 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, DataCon )
  87 import Module           ( ModuleName )
  88 import Name             ( Name, getName, isDllName, isExternallyVisibleName )
  89 import TyCon            ( TyCon )
  90 import Unique           ( pprUnique, Unique )
  91 import PrimOp           ( PrimOp, pprPrimOp )
  92 import CostCentre       ( CostCentre, CostCentreStack )
  93 import Util
  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 ModuleName
 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
 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 (CaseLabel _ _)              = False
 309 needsCDecl (TyConLabel _)               = True
 310
 311 needsCDecl (AsmTempLabel _)             = False
 312 needsCDecl (ModuleInitLabel _)          = 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
 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    RtsLabel _       -> not opt_Static  -- i.e., is the RTS in a DLL or not?
 383    IdLabel n k      -> isDllName n
 384    DataConLabel n k -> isDllName n
 385    TyConLabel tc    -> isDllName (getName tc)
 386    ForeignLabel _ d -> d
 387    _                -> False
 388 \end{code}
 389
 390
 391 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 392 right places. It is used to detect when the abstractC statement of an
 393 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 394
 395 We need at least @Eq@ for @CLabels@, because we want to avoid
 396 duplicate declarations in generating C (see @labelSeenTE@ in
 397 @PprAbsC@).
 398
 399 -----------------------------------------------------------------------------
 400 Printing out CLabels.
 401
 402 Convention:
 403
 404       <name>_<type>
 405
 406 where <name> is <Module>_<name> for external names and <unique> for
 407 internal names. <type> is one of the following:
 408
 409          info                   Info table
 410          srt                    Static reference table
 411          entry                  Entry code
 412          ret                    Direct return address
 413          vtbl                   Vector table
 414          <n>_alt                Case alternative (tag n)
 415          dflt                   Default case alternative
 416          btm                    Large bitmap vector
 417          closure                Static closure
 418          con_entry              Dynamic Constructor entry code
 419          con_info               Dynamic Constructor info table
 420          static_entry           Static Constructor entry code
 421          static_info            Static Constructor info table
 422          sel_info               Selector info table
 423          sel_entry              Selector entry code
 424          cc                     Cost centre
 425          ccs                    Cost centre stack
 426
 427 \begin{code}
 428 -- specialised for PprAsm: saves lots of arg passing in NCG
 429 #if ! OMIT_NATIVE_CODEGEN
 430 pprCLabel_asm = pprCLabel
 431 #endif
 432
 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("stg_error_entry")
 463
 464 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("upd_frame_info")
 465 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("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("__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("__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("__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("__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   = pprPrimOp 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)   = ptext SLIT("__init_") <> ptext mod
 523
 524 ppIdFlavor :: IdLabelInfo -> SDoc
 525
 526 ppIdFlavor x = pp_cSEP <>
 527                (case x of
 528                        Closure          -> ptext SLIT("closure")
 529                        SRT              -> ptext SLIT("srt")
 530                        InfoTbl          -> ptext SLIT("info")
 531                        EntryStd         -> ptext SLIT("entry")
 532                        EntryFast arity  -> --false:ASSERT (arity > 0)
 533                                            (<>) (ptext SLIT("fast")) (int arity)
 534                        RednCounts       -> ptext SLIT("ct")
 535                       )
 536
 537 ppConFlavor x = pp_cSEP <>
 538                 (case x of
 539                        ConEntry         -> ptext SLIT("con_entry")
 540                        ConInfoTbl       -> ptext SLIT("con_info")
 541                        StaticConEntry   -> ptext SLIT("static_entry")
 542                        StaticInfoTbl    -> ptext SLIT("static_info")
 543                 )
 544 \end{code}
 545