ghc/compiler/absCSyn/CLabel.lhs

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