ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.36 2000/05/22 17:05:57 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         mkUpdInfoLabel,
  42         mkSeqInfoLabel,
  43         mkIndInfoLabel,
  44         mkIndStaticInfoLabel,
  45         mkRtsGCEntryLabel,
  46         mkMainRegTableLabel,
  47         mkCharlikeClosureLabel,
  48         mkIntlikeClosureLabel,
  49         mkTopClosureLabel,
  50         mkErrorIO_innardsLabel,
  51         mkMAP_FROZEN_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 #if ! OMIT_NATIVE_CODEGEN
  74         , pprCLabel_asm
  75 #endif
  76     ) where
  77
  78
  79 #include "HsVersions.h"
  80
  81 #if ! OMIT_NATIVE_CODEGEN
  82 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
  83 #endif
  84
  85 import CmdLineOpts      ( opt_Static, opt_DoTickyProfiling )
  86 import CStrings         ( pp_cSEP )
  87 import DataCon          ( ConTag, DataCon )
  88 import Module           ( ModuleName )
  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 ModuleName
 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, eg ErrorIO_innards
 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
 247 mkStgUpdatePAPLabel             = RtsLabel (Rts_Code "stg_update_PAP")
 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 mkTopClosureLabel               = RtsLabel (Rts_Closure "TopClosure")
 257 mkErrorIO_innardsLabel          = RtsLabel (Rts_Code "ErrorIO_innards")
 258 mkMAP_FROZEN_infoLabel          = RtsLabel (Rts_Info "MUT_ARR_PTRS_FROZEN_info")
 259
 260 mkTopTickyCtrLabel              = RtsLabel RtsTopTickyCtr
 261 mkBlackHoleInfoTableLabel       = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
 262 mkCAFBlackHoleInfoTableLabel    = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
 263 mkSECAFBlackHoleInfoTableLabel  = if opt_DoTickyProfiling then
 264                                     RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
 265                                   else  -- RTS won't have info table unless -ticky is on
 266                                     panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 267 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 268
 269 moduleRegdLabel                 = RtsLabel RtsModuleRegd
 270
 271 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTbl upd off)
 272 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry   upd off)
 273
 274 mkApInfoTableLabel  upd off     = RtsLabel (RtsApInfoTbl upd off)
 275 mkApEntryLabel upd off          = RtsLabel (RtsApEntry   upd off)
 276
 277         -- Foreign labels
 278
 279 mkForeignLabel :: FAST_STRING -> Bool -> CLabel
 280 mkForeignLabel str is_dynamic   = ForeignLabel str is_dynamic
 281
 282         -- Cost centres etc.
 283
 284 mkCC_Label      cc              = CC_Label cc
 285 mkCCS_Label     ccs             = CCS_Label ccs
 286 \end{code}
 287
 288 \begin{code}
 289 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 290 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 291 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 292 \end{code}
 293
 294 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 295 object.  {\em Also:} No need to spit out labels for things generated
 296 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 297 to them are always backwards.  These are return-point and vector-table
 298 labels.
 299
 300 Declarations for (non-prelude) @Id@-based things are needed because of
 301 mutual recursion.
 302
 303 Declarations for direct return points are needed, because they may be
 304 let-no-escapes, which can be recursive.
 305
 306 \begin{code}
 307 needsCDecl (IdLabel _ _)                = True
 308 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 309 needsCDecl (DataConLabel _ _)           = True
 310 needsCDecl (CaseLabel _ _)              = False
 311 needsCDecl (TyConLabel _)               = True
 312
 313 needsCDecl (AsmTempLabel _)             = False
 314 needsCDecl (ModuleInitLabel _)          = False
 315 needsCDecl (RtsLabel _)                 = False
 316 needsCDecl (ForeignLabel _ _)           = False
 317 needsCDecl (CC_Label _)                 = False
 318 needsCDecl (CCS_Label _)                = False
 319 \end{code}
 320
 321 Whether the label is an assembler temporary:
 322
 323 \begin{code}
 324 isAsmTemp (AsmTempLabel _) = True
 325 isAsmTemp _                = False
 326 \end{code}
 327
 328 C ``static'' or not...
 329 From the point of view of the code generator, a name is
 330 externally visible if it has to be declared as exported
 331 in the .o file's symbol table; that is, made non-static.
 332
 333 \begin{code}
 334 externallyVisibleCLabel (DataConLabel _ _) = True
 335 externallyVisibleCLabel (TyConLabel tc)    = True
 336 externallyVisibleCLabel (CaseLabel _ _)    = False
 337 externallyVisibleCLabel (AsmTempLabel _)   = False
 338 externallyVisibleCLabel (ModuleInitLabel _)= True
 339 externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
 340 externallyVisibleCLabel (RtsLabel _)       = True
 341 externallyVisibleCLabel (ForeignLabel _ _) = True
 342 externallyVisibleCLabel (IdLabel id _)     = isExternallyVisibleName id
 343 externallyVisibleCLabel (CC_Label _)       = False -- not strictly true
 344 externallyVisibleCLabel (CCS_Label _)      = False -- not strictly true
 345 \end{code}
 346
 347 For generating correct types in label declarations...
 348
 349 \begin{code}
 350 labelType :: CLabel -> CLabelType
 351 labelType (RtsLabel (RtsBlackHoleInfoTbl _))  = InfoTblType
 352 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
 353 labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
 354 labelType (RtsLabel RtsUpdInfo)               = InfoTblType
 355 labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
 356 labelType (CaseLabel _ CaseReturnPt)          = CodeType
 357 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 358 labelType (TyConLabel _)                      = ClosureTblType
 359
 360 labelType (IdLabel _ info) =
 361   case info of
 362     InfoTbl       -> InfoTblType
 363     Closure       -> ClosureType
 364     _             -> CodeType
 365
 366 labelType (DataConLabel _ info) =
 367   case info of
 368      ConInfoTbl    -> InfoTblType
 369      StaticInfoTbl -> InfoTblType
 370      _             -> CodeType
 371
 372 labelType _        = DataType
 373 \end{code}
 374
 375 When referring to data in code, we need to know whether
 376 that data resides in a DLL or not. [Win32 only.]
 377 @labelDynamic@ returns @True@ if the label is located
 378 in a DLL, be it a data reference or not.
 379
 380 \begin{code}
 381 labelDynamic :: CLabel -> Bool
 382 labelDynamic lbl =
 383   case lbl of
 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    _                -> False
 390 \end{code}
 391
 392
 393 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 394 right places. It is used to detect when the abstractC statement of an
 395 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 396
 397 We need at least @Eq@ for @CLabels@, because we want to avoid
 398 duplicate declarations in generating C (see @labelSeenTE@ in
 399 @PprAbsC@).
 400
 401 -----------------------------------------------------------------------------
 402 Printing out CLabels.
 403
 404 Convention:
 405
 406       <name>_<type>
 407
 408 where <name> is <Module>_<name> for external names and <unique> for
 409 internal names. <type> is one of the following:
 410
 411          info                   Info table
 412          srt                    Static reference table
 413          entry                  Entry code
 414          ret                    Direct return address
 415          vtbl                   Vector table
 416          <n>_alt                Case alternative (tag n)
 417          dflt                   Default case alternative
 418          btm                    Large bitmap vector
 419          closure                Static closure
 420          con_entry              Dynamic Constructor entry code
 421          con_info               Dynamic Constructor info table
 422          static_entry           Static Constructor entry code
 423          static_info            Static Constructor info table
 424          sel_info               Selector info table
 425          sel_entry              Selector entry code
 426          cc                     Cost centre
 427          ccs                    Cost centre stack
 428
 429 \begin{code}
 430 -- specialised for PprAsm: saves lots of arg passing in NCG
 431 #if ! OMIT_NATIVE_CODEGEN
 432 pprCLabel_asm = pprCLabel
 433 #endif
 434
 435 pprCLabel :: CLabel -> SDoc
 436
 437 #if ! OMIT_NATIVE_CODEGEN
 438 pprCLabel (AsmTempLabel u)
 439   = text (fmtAsmLbl (show u))
 440 #endif
 441
 442 pprCLabel lbl =
 443 #if ! OMIT_NATIVE_CODEGEN
 444     getPprStyle $ \ sty ->
 445     if asmStyle sty && underscorePrefix then
 446        pp_cSEP <> pprCLbl lbl
 447     else
 448 #endif
 449        pprCLbl lbl
 450
 451 pprCLbl (CaseLabel u CaseReturnPt)
 452   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 453 pprCLbl (CaseLabel u CaseReturnInfo)
 454   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 455 pprCLbl (CaseLabel u CaseVecTbl)
 456   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 457 pprCLbl (CaseLabel u (CaseAlt tag))
 458   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 459 pprCLbl (CaseLabel u CaseDefault)
 460   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 461 pprCLbl (CaseLabel u CaseBitmap)
 462   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 463
 464 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
 465
 466 pprCLbl (RtsLabel RtsUpdInfo)            = ptext SLIT("upd_frame_info")
 467 pprCLbl (RtsLabel RtsSeqInfo)            = ptext SLIT("seq_frame_info")
 468 pprCLbl (RtsLabel RtsMainRegTable)       = ptext SLIT("MainRegTable")
 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)) = ptext info
 477
 478 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 479   = hcat [ptext SLIT("__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("__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("__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("__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   = pprPrimOp primop <> ptext SLIT("_fast")
 508
 509 pprCLbl (RtsLabel RtsModuleRegd)
 510   = ptext SLIT("module_registered")
 511
 512 pprCLbl (ForeignLabel str _)
 513   = ptext 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)   = ptext SLIT("__init_") <> ptext mod
 525
 526 ppIdFlavor :: IdLabelInfo -> SDoc
 527
 528 ppIdFlavor x = pp_cSEP <>
 529                (case x of
 530                        Closure          -> ptext SLIT("closure")
 531                        SRT              -> ptext SLIT("srt")
 532                        InfoTbl          -> ptext SLIT("info")
 533                        EntryStd         -> ptext SLIT("entry")
 534                        EntryFast arity  -> --false:ASSERT (arity > 0)
 535                                            (<>) (ptext SLIT("fast")) (int arity)
 536                        RednCounts       -> ptext SLIT("ct")
 537                       )
 538
 539 ppConFlavor x = pp_cSEP <>
 540                 (case x of
 541                        ConEntry         -> ptext SLIT("con_entry")
 542                        ConInfoTbl       -> ptext SLIT("con_info")
 543                        StaticConEntry   -> ptext SLIT("static_entry")
 544                        StaticInfoTbl    -> ptext SLIT("static_info")
 545                 )
 546 \end{code}
 547