ghc/compiler/absCSyn/CLabel.lhs

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