ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CLabel]{@CLabel@: Information to make C Labels}
   5
   6 \begin{code}
   7 module CLabel (
   8         CLabel, -- abstract type
   9
  10         mkClosureLabel,
  11         mkInfoTableLabel,
  12         mkStdEntryLabel,
  13         mkFastEntryLabel,
  14         mkConEntryLabel,
  15         mkStaticConEntryLabel,
  16         mkRednCountsLabel,
  17         mkConInfoTableLabel,
  18         mkPhantomInfoTableLabel,
  19         mkStaticClosureLabel,
  20         mkStaticInfoTableLabel,
  21         mkVapEntryLabel,
  22         mkVapInfoTableLabel,
  23
  24         mkConUpdCodePtrVecLabel,
  25         mkStdUpdCodePtrVecLabel,
  26
  27         mkInfoTableVecTblLabel,
  28         mkStdUpdVecTblLabel,
  29
  30         mkReturnPtLabel,
  31         mkVecTblLabel,
  32         mkAltLabel,
  33         mkDefaultLabel,
  34
  35         mkAsmTempLabel,
  36
  37         mkErrorStdEntryLabel,
  38         mkBlackHoleInfoTableLabel,
  39
  40         needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
  41
  42         pprCLabel
  43 #if ! OMIT_NATIVE_CODEGEN
  44         , pprCLabel_asm
  45 #endif
  46     ) where
  47
  48
  49 #include "HsVersions.h"
  50
  51 #if ! OMIT_NATIVE_CODEGEN
  52 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
  53 #endif
  54
  55 import CgRetConv        ( CtrlReturnConvention(..), ctrlReturnConvAlg )
  56 import CStrings         ( pp_cSEP )
  57 import Id               ( externallyVisibleId, cmpId_withSpecDataCon,
  58                           isDataCon, isDictFunId,
  59                           isDefaultMethodId_maybe,
  60                           isSuperDictSelId_maybe, fIRST_TAG,
  61                           ConTag, GenId{-instance Outputable-},
  62                           Id
  63                         )
  64 import Maybes           ( maybeToBool )
  65 import PprType          ( showTyCon, GenType{-instance Outputable-} )
  66 import TyCon            ( TyCon{-instance Eq-} )
  67 import Unique           ( showUnique, pprUnique, Unique{-instance Eq-} )
  68 import Util             ( assertPanic{-, pprTraceToDo:rm-} )
  69 import Outputable
  70 \end{code}
  71
  72 things we want to find out:
  73
  74 * should the labelled things be declared "static" (visible only in this file)?
  75
  76 * should it be declared "const" (read-only text space)?
  77
  78 * does it need declarations at all? (v common Prelude things are pre-declared)
  79
  80 \begin{code}
  81 data CLabel
  82   = IdLabel                     -- A family of labels related to the
  83         CLabelId                -- definition of a particular Id
  84         IdLabelInfo             -- Includes DataCon
  85
  86   | TyConLabel                  -- A family of labels related to the
  87         TyCon                   -- definition of a data type
  88         TyConLabelInfo
  89
  90   | CaseLabel                   -- A family of labels related to a particular case expression
  91         Unique                  -- Unique says which case expression
  92         CaseLabelInfo
  93
  94   | AsmTempLabel    Unique
  95
  96   | RtsLabel        RtsLabelInfo
  97
  98   deriving (Eq, Ord)
  99 \end{code}
 100
 101 The CLabelId is simply so we can declare alternative Eq and Ord
 102 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
 103 comparing the Uniques of two specialised data constructors (which have
 104 the same as the uniques their respective unspecialised data
 105 constructors). Instead, the specialising types and the uniques of the
 106 unspecialised constructors are compared.
 107
 108 \begin{code}
 109 data CLabelId = CLabelId Id
 110
 111 instance Eq CLabelId where
 112     CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True;  _ -> False }
 113     CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True  }
 114
 115 instance Ord CLabelId where
 116     CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 117     CLabelId a <  CLabelId b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 118     CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 119     CLabelId a >  CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 120     compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b
 121 \end{code}
 122
 123 \begin{code}
 124 data IdLabelInfo
 125   = Closure             -- Label for (static???) closure
 126   | StaticClosure       -- Static closure -- e.g., nullary constructor
 127
 128   | InfoTbl             -- Info table for a closure; always read-only
 129
 130   | EntryStd            -- Thunk, or "slow", code entry point (requires arg satis check)
 131   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 132                         -- Int is the arity of the function (to be
 133                         -- encoded into the name)
 134
 135   | ConEntry            -- the only kind of entry pt for constructors
 136   | ConInfoTbl          -- corresponding info table
 137
 138   | StaticConEntry      -- static constructor entry point
 139   | StaticInfoTbl       -- corresponding info table
 140
 141   | PhantomInfoTbl      -- for phantom constructors that only exist in regs
 142
 143   | VapInfoTbl Bool     -- True <=> the update-reqd version; False <=> the no-update-reqd version
 144   | VapEntry   Bool
 145
 146         -- Ticky-ticky counting
 147   | RednCounts          -- Label of place to keep reduction-count info for this Id
 148   deriving (Eq, Ord)
 149
 150
 151 data TyConLabelInfo
 152   = UnvecConUpdCode      -- Update code for the data type if it's unvectored
 153
 154   | VecConUpdCode ConTag -- One for each constructor which returns in
 155                          -- regs; this code actually performs an update
 156
 157   | StdUpdCode ConTag    -- Update code for all constructors which return
 158                          -- in heap.  There are a small number of variants,
 159                          -- so that the update code returns (vectored/n or
 160                          -- unvectored) in the right way.
 161                          -- ToDo: maybe replace TyCon/Int with return conv.
 162
 163   | InfoTblVecTbl        -- For tables of info tables
 164
 165   | StdUpdVecTbl         -- Labels the update code, or table of update codes,
 166                          -- for a particular type.
 167   deriving (Eq, Ord)
 168
 169 data CaseLabelInfo
 170   = CaseReturnPt
 171   | CaseVecTbl
 172   | CaseAlt ConTag
 173   | CaseDefault
 174   deriving (Eq, Ord)
 175
 176 data RtsLabelInfo
 177   = RtsShouldNeverHappenCode
 178
 179   | RtsBlackHoleInfoTbl
 180
 181   | RtsSelectorInfoTbl  -- Selectors
 182         Bool            -- True <=> the update-reqd version;
 183                         -- False <=> the no-update-reqd version
 184         Int             -- 0-indexed Offset from the "goods"
 185
 186   | RtsSelectorEntry    -- Ditto entry code
 187         Bool
 188         Int
 189   deriving (Eq, Ord)
 190 \end{code}
 191
 192 \begin{code}
 193 mkClosureLabel          id              = IdLabel (CLabelId id)  Closure
 194 mkInfoTableLabel        id              = IdLabel (CLabelId id)  InfoTbl
 195 mkStdEntryLabel         id              = IdLabel (CLabelId id)  EntryStd
 196 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 197                                           IdLabel (CLabelId id)  (EntryFast arity)
 198
 199 mkStaticClosureLabel    con             = ASSERT(isDataCon con)
 200                                           IdLabel (CLabelId con) StaticClosure
 201 mkStaticInfoTableLabel  con             = ASSERT(isDataCon con)
 202                                           IdLabel (CLabelId con) StaticInfoTbl
 203 mkConInfoTableLabel     con             = ASSERT(isDataCon con)
 204                                           IdLabel (CLabelId con) ConInfoTbl
 205 mkPhantomInfoTableLabel con             = ASSERT(isDataCon con)
 206                                           IdLabel (CLabelId con) PhantomInfoTbl
 207 mkConEntryLabel         con             = ASSERT(isDataCon con)
 208                                           IdLabel (CLabelId con) ConEntry
 209 mkStaticConEntryLabel   con             = ASSERT(isDataCon con)
 210                                           IdLabel (CLabelId con) StaticConEntry
 211
 212 mkRednCountsLabel       id              = IdLabel (CLabelId id)  RednCounts
 213 mkVapEntryLabel         id upd_flag     = IdLabel (CLabelId id)  (VapEntry upd_flag)
 214 mkVapInfoTableLabel     id upd_flag     = IdLabel (CLabelId id)  (VapInfoTbl upd_flag)
 215
 216 mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
 217 mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
 218
 219 mkInfoTableVecTblLabel    tycon     = TyConLabel tycon InfoTblVecTbl
 220 mkStdUpdVecTblLabel       tycon     = TyConLabel tycon StdUpdVecTbl
 221
 222 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 223 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 224 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 225 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 226
 227 mkAsmTempLabel                  = AsmTempLabel
 228
 229         -- Some fixed runtime system labels
 230
 231 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 232 mkBlackHoleInfoTableLabel       = RtsLabel RtsBlackHoleInfoTbl
 233 \end{code}
 234
 235 \begin{code}
 236 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 237 isReadOnly :: CLabel -> Bool    -- lives in C "text space"
 238 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 239 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 240 \end{code}
 241
 242 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 243 object.  {\em Also:} No need to spit out labels for things generated
 244 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 245 to them are always backwards.  These are return-point and vector-table
 246 labels.
 247
 248 Declarations for (non-prelude) @Id@-based things are needed because of
 249 mutual recursion.
 250 \begin{code}
 251 needsCDecl (IdLabel _ _)               = True
 252 needsCDecl (CaseLabel _ _)             = False
 253
 254 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
 255 needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
 256 needsCDecl (TyConLabel _ other)          = True
 257
 258 needsCDecl (AsmTempLabel _)            = False
 259 needsCDecl (RtsLabel _)                = False
 260
 261 needsCDecl other                       = True
 262 \end{code}
 263
 264 Whether the labelled thing can be put in C "text space":
 265 \begin{code}
 266 isReadOnly (IdLabel _ InfoTbl)          = True  -- info-tables: yes
 267 isReadOnly (IdLabel _ ConInfoTbl)       = True -- and so on, for other
 268 isReadOnly (IdLabel _ StaticInfoTbl)    = True
 269 isReadOnly (IdLabel _ PhantomInfoTbl)   = True
 270 isReadOnly (IdLabel _ (VapInfoTbl _))   = True
 271 isReadOnly (IdLabel _ other)            = False -- others: pessimistically, no
 272
 273 isReadOnly (TyConLabel _ _)    = True
 274 isReadOnly (CaseLabel _ _)     = True
 275 isReadOnly (AsmTempLabel _)    = True
 276 isReadOnly (RtsLabel _)        = True
 277 \end{code}
 278
 279 Whether the label is an assembler temporary:
 280 \begin{code}
 281 isAsmTemp (AsmTempLabel _) = True
 282 isAsmTemp _                = False
 283 \end{code}
 284
 285 C ``static'' or not...
 286 From the point of view of the code generator, a name is
 287 externally visible if it should be given put in the .o file's
 288 symbol table; that is, made static.
 289
 290 \begin{code}
 291 externallyVisibleCLabel (TyConLabel tc _) = True
 292 externallyVisibleCLabel (CaseLabel _ _)   = False
 293 externallyVisibleCLabel (AsmTempLabel _)  = False
 294 externallyVisibleCLabel (RtsLabel _)      = True
 295 externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
 296 \end{code}
 297
 298 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 299 right places. It is used to detect when the abstractC statement of an
 300 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 301
 302 We need at least @Eq@ for @CLabels@, because we want to avoid
 303 duplicate declarations in generating C (see @labelSeenTE@ in
 304 @PprAbsC@).
 305
 306 \begin{code}
 307 -- specialised for PprAsm: saves lots of arg passing in NCG
 308 #if ! OMIT_NATIVE_CODEGEN
 309 pprCLabel_asm = pprCLabel
 310 #endif
 311
 312 pprCLabel :: CLabel -> SDoc
 313
 314 pprCLabel (AsmTempLabel u)
 315   = text (fmtAsmLbl (showUnique u))
 316
 317 pprCLabel lbl
 318   = getPprStyle $ \ sty ->
 319     if asmStyle sty && underscorePrefix then
 320        pp_cSEP <> pprCLbl lbl
 321     else
 322        pprCLbl lbl
 323
 324
 325 pprCLbl (TyConLabel tc UnvecConUpdCode)
 326   = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
 327                pp_cSEP, ptext SLIT("upd")]
 328
 329 pprCLbl (TyConLabel tc (VecConUpdCode tag))
 330   = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP,
 331                      int tag, pp_cSEP, ptext SLIT("upd")]
 332
 333 pprCLbl (TyConLabel tc (StdUpdCode tag))
 334   = case (ctrlReturnConvAlg tc) of
 335         UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
 336         VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
 337
 338 pprCLbl (TyConLabel tc InfoTblVecTbl)
 339   = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")]
 340
 341 pprCLbl (TyConLabel tc StdUpdVecTbl)
 342   = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
 343                pp_cSEP, ptext SLIT("upd")]
 344
 345 pprCLbl (CaseLabel u CaseReturnPt)
 346   = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
 347 pprCLbl (CaseLabel u CaseVecTbl)
 348   = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
 349 pprCLbl (CaseLabel u (CaseAlt tag))
 350   = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
 351 pprCLbl (CaseLabel u CaseDefault)
 352   = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
 353
 354 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
 355
 356 pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
 357
 358 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 359   = hcat [ptext SLIT("__sel_info_"), text (show offset),
 360                 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
 361                 ptext SLIT("__")]
 362
 363 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 364   = hcat [ptext SLIT("__sel_entry_"), text (show offset),
 365                 ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
 366                 ptext SLIT("__")]
 367
 368 pprCLbl (IdLabel (CLabelId id) flavor)
 369   = ppr id <> ppFlavor flavor
 370
 371
 372 ppr_u u = pprUnique u
 373
 374 ppr_tycon :: TyCon -> SDoc
 375 ppr_tycon tc = ppr tc
 376 {-
 377   = let
 378         str = showTyCon tc
 379     in
 380     --pprTrace "ppr_tycon:" (text str) $
 381     text str
 382 -}
 383
 384 ppFlavor :: IdLabelInfo -> SDoc
 385
 386 ppFlavor x = (<>) pp_cSEP
 387                       (case x of
 388                        Closure          -> ptext SLIT("closure")
 389                        InfoTbl          -> ptext SLIT("info")
 390                        EntryStd         -> ptext SLIT("entry")
 391                        EntryFast arity  -> --false:ASSERT (arity > 0)
 392                                            (<>) (ptext SLIT("fast")) (int arity)
 393                        StaticClosure    -> ptext SLIT("static_closure")
 394                        ConEntry         -> ptext SLIT("con_entry")
 395                        ConInfoTbl       -> ptext SLIT("con_info")
 396                        StaticConEntry   -> ptext SLIT("static_entry")
 397                        StaticInfoTbl    -> ptext SLIT("static_info")
 398                        PhantomInfoTbl   -> ptext SLIT("inregs_info")
 399                        VapInfoTbl True  -> ptext SLIT("vap_info")
 400                        VapInfoTbl False -> ptext SLIT("vap_noupd_info")
 401                        VapEntry True    -> ptext SLIT("vap_entry")
 402                        VapEntry False   -> ptext SLIT("vap_noupd_entry")
 403                        RednCounts       -> ptext SLIT("ct")
 404                       )
 405 \end{code}