ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.26 1999/05/11 16:44:04 keithw 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         mkUpdEntryLabel,
  39         mkCAFBlackHoleInfoTableLabel,
  40         mkSECAFBlackHoleInfoTableLabel,
  41         mkRtsPrimOpLabel,
  42
  43         mkSelectorInfoLabel,
  44         mkSelectorEntryLabel,
  45
  46         mkCC_Label, mkCCS_Label,
  47
  48         needsCDecl, isReadOnly, 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   | RtsUpdEntry
 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 mkUpdEntryLabel                 = RtsLabel RtsUpdEntry
 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 isReadOnly :: CLabel -> Bool    -- lives in C "text space"
 236 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 237 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 238 \end{code}
 239
 240 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 241 object.  {\em Also:} No need to spit out labels for things generated
 242 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 243 to them are always backwards.  These are return-point and vector-table
 244 labels.
 245
 246 Declarations for (non-prelude) @Id@-based things are needed because of
 247 mutual recursion.
 248
 249 Declarations for direct return points are needed, because they may be
 250 let-no-escapes, which can be recursive.
 251
 252 \begin{code}
 253 needsCDecl (IdLabel _ _)                = True
 254 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 255 needsCDecl (DataConLabel _ _)           = True
 256 needsCDecl (CaseLabel _ _)              = False
 257 needsCDecl (TyConLabel _)               = True
 258
 259 needsCDecl (AsmTempLabel _)             = False
 260 needsCDecl (RtsLabel _)                 = False
 261 needsCDecl (CC_Label _)                 = False
 262 needsCDecl (CCS_Label _)                = False
 263 \end{code}
 264
 265 Whether the labelled thing can be put in C "text space":
 266
 267 \begin{code}
 268 isReadOnly (IdLabel _ InfoTbl)  = True  -- info-tables: yes
 269 isReadOnly (IdLabel _ other)    = False -- others: pessimistically, no
 270
 271 isReadOnly (DataConLabel _ _)   = True -- and so on, for other
 272 isReadOnly (TyConLabel _)       = True
 273 isReadOnly (CaseLabel _ _)      = True
 274 isReadOnly (AsmTempLabel _)     = True
 275 isReadOnly (RtsLabel _)         = True
 276 isReadOnly (CC_Label _)         = True
 277 isReadOnly (CCS_Label _)        = True
 278 \end{code}
 279
 280 Whether the label is an assembler temporary:
 281
 282 \begin{code}
 283 isAsmTemp (AsmTempLabel _) = True
 284 isAsmTemp _                = False
 285 \end{code}
 286
 287 C ``static'' or not...
 288 From the point of view of the code generator, a name is
 289 externally visible if it has to be declared as exported
 290 in the .o file's symbol table; that is, made non-static.
 291
 292 \begin{code}
 293 externallyVisibleCLabel (DataConLabel _ _) = True
 294 externallyVisibleCLabel (TyConLabel tc)    = True
 295 externallyVisibleCLabel (CaseLabel _ _)    = False
 296 externallyVisibleCLabel (AsmTempLabel _)   = False
 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 (CaseLabel _ CaseReturnInfo)        = InfoTblType
 311 labelType (CaseLabel _ CaseReturnPt)          = CodeType
 312 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 313 labelType (TyConLabel _)                      = ClosureTblType
 314
 315 labelType (IdLabel _ info) =
 316   case info of
 317     InfoTbl       -> InfoTblType
 318     Closure       -> ClosureType
 319     _             -> CodeType
 320
 321 labelType (DataConLabel _ info) =
 322   case info of
 323      ConInfoTbl    -> InfoTblType
 324      StaticInfoTbl -> InfoTblType
 325      StaticClosure -> ClosureType
 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      | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n)
 342    DataConLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n)
 343    TyConLabel tc    | not (isLocallyDefinedName (getName tc)) -> isDynamicModule (nameModule (getName tc))
 344    _ -> False
 345
 346 \end{code}
 347
 348
 349 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 350 right places. It is used to detect when the abstractC statement of an
 351 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 352
 353 We need at least @Eq@ for @CLabels@, because we want to avoid
 354 duplicate declarations in generating C (see @labelSeenTE@ in
 355 @PprAbsC@).
 356
 357 -----------------------------------------------------------------------------
 358 Printing out CLabels.
 359
 360 Convention:
 361
 362       <name>_<type>
 363
 364 where <name> is <Module>_<name> for external names and <unique> for
 365 internal names. <type> is one of the following:
 366
 367          info                   Info table
 368          srt                    Static reference table
 369          entry                  Entry code
 370          ret                    Direct return address
 371          vtbl                   Vector table
 372          <n>_alt                Case alternative (tag n)
 373          dflt                   Default case alternative
 374          btm                    Large bitmap vector
 375          closure                Static closure
 376          static_closure         Static closure (???)
 377          con_entry              Dynamic Constructor entry code
 378          con_info               Dynamic Constructor info table
 379          static_entry           Static Constructor entry code
 380          static_info            Static Constructor info table
 381          sel_info               Selector info table
 382          sel_entry              Selector entry code
 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 RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
 422
 423 pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
 424
 425 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 426   = hcat [ptext SLIT("__sel_"), text (show offset),
 427                 ptext (if upd_reqd
 428                         then SLIT("_upd_info")
 429                         else SLIT("_noupd_info"))
 430         ]
 431
 432 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 433   = hcat [ptext SLIT("__sel_"), text (show offset),
 434                 ptext (if upd_reqd
 435                         then SLIT("_upd_entry")
 436                         else SLIT("_noupd_entry"))
 437         ]
 438
 439 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 440   = hcat [ptext SLIT("__ap_"), text (show arity),
 441                 ptext (if upd_reqd
 442                         then SLIT("_upd_info")
 443                         else SLIT("_noupd_info"))
 444         ]
 445
 446 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 447   = hcat [ptext SLIT("__ap_"), text (show arity),
 448                 ptext (if upd_reqd
 449                         then SLIT("_upd_entry")
 450                         else SLIT("_noupd_entry"))
 451         ]
 452
 453 pprCLbl (RtsLabel (RtsPrimOp primop))
 454   = pprPrimOp primop <> ptext SLIT("_fast")
 455
 456 pprCLbl (TyConLabel tc)
 457   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 458
 459 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 460 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 461
 462 pprCLbl (CC_Label cc)           = ppr cc
 463 pprCLbl (CCS_Label ccs)         = ppr ccs
 464
 465 ppIdFlavor :: IdLabelInfo -> SDoc
 466
 467 ppIdFlavor x = pp_cSEP <>
 468                (case x of
 469                        Closure          -> ptext SLIT("closure")
 470                        SRT              -> ptext SLIT("srt")
 471                        InfoTbl          -> ptext SLIT("info")
 472                        EntryStd         -> ptext SLIT("entry")
 473                        EntryFast arity  -> --false:ASSERT (arity > 0)
 474                                            (<>) (ptext SLIT("fast")) (int arity)
 475                        RednCounts       -> ptext SLIT("ct")
 476                       )
 477
 478 ppConFlavor x = pp_cSEP <>
 479                 (case x of
 480                        StaticClosure    -> ptext SLIT("static_closure")
 481                        ConEntry         -> ptext SLIT("con_entry")
 482                        ConInfoTbl       -> ptext SLIT("con_info")
 483                        StaticConEntry   -> ptext SLIT("static_entry")
 484                        StaticInfoTbl    -> ptext SLIT("static_info")
 485                 )
 486 \end{code}
 487