ghc/compiler/absCSyn/CLabel.lhs

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