ghc/compiler/absCSyn/CLabel.lhs

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