ghc/compiler/absCSyn/CLabel.lhs

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