ghc/compiler/absCSyn/CLabel.lhs

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