ghc/compiler/absCSyn/CLabel.lhs

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