ghc/compiler/absCSyn/CLabel.lhs

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