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 #include "HsVersions.h"
   8
   9 module CLabel (
  10         CLabel, -- abstract type
  11
  12         mkClosureLabel,
  13         mkInfoTableLabel,
  14         mkStdEntryLabel,
  15         mkFastEntryLabel,
  16         mkConEntryLabel,
  17         mkStaticConEntryLabel,
  18         mkRednCountsLabel,
  19         mkPhantomInfoTableLabel,
  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 import Ubiq{-uitous-}
  49 import AbsCLoop         ( CtrlReturnConvention(..),
  50                           ctrlReturnConvAlg
  51                         )
  52 #if ! OMIT_NATIVE_CODEGEN
  53 import NcgLoop          ( underscorePrefix, fmtAsmLbl )
  54 #endif
  55
  56 import CStrings         ( pp_cSEP )
  57 import Id               ( externallyVisibleId, cmpId_withSpecDataCon,
  58                           isDataCon, isDictFunId,
  59                           isConstMethodId_maybe,
  60                           isDefaultMethodId_maybe,
  61                           isSuperDictSelId_maybe, fIRST_TAG,
  62                           ConTag(..), GenId{-instance Outputable-}
  63                         )
  64 import Maybes           ( maybeToBool )
  65 import PprStyle         ( PprStyle(..) )
  66 import PprType          ( showTyCon, GenType{-instance Outputable-} )
  67 import Pretty           ( prettyToUn )
  68 import TyCon            ( TyCon{-instance Eq-} )
  69 import Unique           ( showUnique, pprUnique, Unique{-instance Eq-} )
  70 import Unpretty         -- NOTE!! ********************
  71 import Util             ( assertPanic )
  72 \end{code}
  73
  74 things we want to find out:
  75
  76 * should the labelled things be declared "static" (visible only in this file)?
  77
  78 * should it be declared "const" (read-only text space)?
  79
  80 * does it need declarations at all? (v common Prelude things are pre-declared)
  81
  82 \begin{code}
  83 data CLabel
  84   = IdLabel                     -- A family of labels related to the
  85         CLabelId                -- definition of a particular Id
  86         IdLabelInfo             -- Includes DataCon
  87
  88   | TyConLabel                  -- A family of labels related to the
  89         TyCon                   -- definition of a data type
  90         TyConLabelInfo
  91
  92   | CaseLabel                   -- A family of labels related to a particular case expression
  93         Unique                  -- Unique says which case expression
  94         CaseLabelInfo
  95
  96   | AsmTempLabel    Unique
  97
  98   | RtsLabel        RtsLabelInfo
  99
 100   deriving (Eq, Ord)
 101 \end{code}
 102
 103 The CLabelId is simply so we can declare alternative Eq and Ord
 104 instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
 105 comparing the Uniques of two specialised data constructors (which have
 106 the same as the uniques their respective unspecialised data
 107 constructors). Instead, the specialising types and the uniques of the
 108 unspecialised constructors are compared.
 109
 110 \begin{code}
 111 data CLabelId = CLabelId Id
 112
 113 instance Eq CLabelId where
 114     CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True;  _ -> False }
 115     CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True  }
 116
 117 instance Ord CLabelId where
 118     CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
 119          of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 120     CLabelId a <  CLabelId b = case cmpId_withSpecDataCon a b
 121          of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 122     CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
 123          of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 124     CLabelId a >  CLabelId b = case cmpId_withSpecDataCon a b
 125          of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 126     _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
 127          of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 128 \end{code}
 129
 130 \begin{code}
 131 data IdLabelInfo
 132   = Closure             -- Label for (static???) closure
 133
 134   | InfoTbl             -- Info table for a closure; always read-only
 135
 136   | EntryStd            -- Thunk, or "slow", code entry point (requires arg satis check)
 137   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 138                         -- Int is the arity of the function (to be
 139                         -- encoded into the name)
 140
 141   | ConEntry            -- the only kind of entry pt for constructors
 142   | StaticConEntry      -- static constructor entry point
 143
 144   | StaticInfoTbl       -- corresponding info table
 145
 146   | PhantomInfoTbl      -- for phantom constructors that only exist in regs
 147
 148   | VapInfoTbl Bool     -- True <=> the update-reqd version; False <=> the no-update-reqd version
 149   | VapEntry Bool
 150
 151         -- Ticky-ticky counting
 152   | RednCounts          -- Label of place to keep reduction-count info for this Id
 153   deriving (Eq, Ord)
 154
 155
 156 data TyConLabelInfo
 157   = UnvecConUpdCode      -- Update code for the data type if it's unvectored
 158
 159   | VecConUpdCode ConTag -- One for each constructor which returns in
 160                          -- regs; this code actually performs an update
 161
 162   | StdUpdCode ConTag    -- Update code for all constructors which return
 163                          -- in heap.  There are a small number of variants,
 164                          -- so that the update code returns (vectored/n or
 165                          -- unvectored) in the right way.
 166                          -- ToDo: maybe replace TyCon/Int with return conv.
 167
 168   | InfoTblVecTbl        -- For tables of info tables
 169
 170   | StdUpdVecTbl         -- Labels the update code, or table of update codes,
 171                          -- for a particular type.
 172   deriving (Eq, Ord)
 173
 174 data CaseLabelInfo
 175   = CaseReturnPt
 176   | CaseVecTbl
 177   | CaseAlt ConTag
 178   | CaseDefault
 179   deriving (Eq, Ord)
 180
 181 data RtsLabelInfo
 182   = RtsShouldNeverHappenCode
 183
 184   | RtsBlackHoleInfoTbl
 185
 186   | RtsSelectorInfoTbl  -- Selectors
 187         Bool            -- True <=> the update-reqd version;
 188                         -- False <=> the no-update-reqd version
 189         Int             -- 0-indexed Offset from the "goods"
 190
 191   | RtsSelectorEntry    -- Ditto entry code
 192         Bool
 193         Int
 194   deriving (Eq, Ord)
 195 \end{code}
 196
 197 \begin{code}
 198 mkClosureLabel          id              = IdLabel (CLabelId id) Closure
 199 mkInfoTableLabel        id              = IdLabel (CLabelId id) InfoTbl
 200 mkStdEntryLabel         id              = IdLabel (CLabelId id) EntryStd
 201 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 202                                           IdLabel (CLabelId id) (EntryFast arity)
 203 mkConEntryLabel         id              = IdLabel (CLabelId id) ConEntry
 204 mkStaticConEntryLabel   id              = IdLabel (CLabelId id) StaticConEntry
 205 mkRednCountsLabel       id              = IdLabel (CLabelId id) RednCounts
 206 mkPhantomInfoTableLabel id              = IdLabel (CLabelId id) PhantomInfoTbl
 207 mkStaticInfoTableLabel  id              = IdLabel (CLabelId id) StaticInfoTbl
 208 mkVapEntryLabel         id upd_flag     = IdLabel (CLabelId id) (VapEntry upd_flag)
 209 mkVapInfoTableLabel     id upd_flag     = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
 210
 211 mkConUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (VecConUpdCode tag)
 212 mkStdUpdCodePtrVecLabel   tycon tag = TyConLabel tycon (StdUpdCode tag)
 213
 214 mkInfoTableVecTblLabel    tycon     = TyConLabel tycon InfoTblVecTbl
 215 mkStdUpdVecTblLabel       tycon     = TyConLabel tycon StdUpdVecTbl
 216
 217 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 218 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 219 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 220 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 221
 222 mkAsmTempLabel                  = AsmTempLabel
 223
 224         -- Some fixed runtime system labels
 225
 226 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 227 mkBlackHoleInfoTableLabel       = RtsLabel RtsBlackHoleInfoTbl
 228 \end{code}
 229
 230 \begin{code}
 231 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 232 isReadOnly :: CLabel -> Bool    -- lives in C "text space"
 233 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 234 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 235 \end{code}
 236
 237 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 238 object.  {\em Also:} No need to spit out labels for things generated
 239 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 240 to them are always backwards.  These are return-point and vector-table
 241 labels.
 242
 243 Declarations for (non-prelude) @Id@-based things are needed because of
 244 mutual recursion.
 245 \begin{code}
 246 needsCDecl (IdLabel _ _)               = True
 247 needsCDecl (CaseLabel _ _)             = False
 248
 249 needsCDecl (TyConLabel _ (StdUpdCode _)) = False
 250 needsCDecl (TyConLabel _ InfoTblVecTbl)  = False
 251 needsCDecl (TyConLabel _ other)          = True
 252
 253 needsCDecl (AsmTempLabel _)            = False
 254 needsCDecl (RtsLabel _)                = False
 255
 256 needsCDecl other                       = True
 257 \end{code}
 258
 259 Whether the labelled thing can be put in C "text space":
 260 \begin{code}
 261 isReadOnly (IdLabel _ InfoTbl)         = True  -- info-tables: yes
 262 isReadOnly (IdLabel _ StaticInfoTbl)   = True  -- and so on, for other
 263 isReadOnly (IdLabel _ PhantomInfoTbl)  = True
 264 isReadOnly (IdLabel _ (VapInfoTbl _))  = True
 265 isReadOnly (IdLabel _ other)           = False -- others: pessimistically, no
 266
 267 isReadOnly (TyConLabel _ _)    = True
 268 isReadOnly (CaseLabel _ _)     = True
 269 isReadOnly (AsmTempLabel _)    = True
 270 isReadOnly (RtsLabel _)        = True
 271 \end{code}
 272
 273 Whether the label is an assembler temporary:
 274 \begin{code}
 275 isAsmTemp (AsmTempLabel _) = True
 276 isAsmTemp _                = False
 277 \end{code}
 278
 279 C ``static'' or not...
 280 \begin{code}
 281 externallyVisibleCLabel (TyConLabel tc _) = True
 282 externallyVisibleCLabel (CaseLabel _ _)   = False
 283 externallyVisibleCLabel (AsmTempLabel _)  = False
 284 externallyVisibleCLabel (RtsLabel _)      = True
 285 externallyVisibleCLabel (IdLabel (CLabelId id) _)
 286   | isDataCon id          = True
 287   | is_ConstMethodId id   = True  -- These are here to ensure splitting works
 288   | isDictFunId id        = True  -- when these values have not been exported
 289   | is_DefaultMethodId id = True
 290   | is_SuperDictSelId id  = True
 291   | otherwise             = externallyVisibleId id
 292   where
 293     is_ConstMethodId   id = maybeToBool (isConstMethodId_maybe   id)
 294     is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
 295     is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  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 (PprForAsm underscorePrefix fmtAsmLbl)
 310 #endif
 311
 312 pprCLabel :: PprStyle -> CLabel -> Unpretty
 313
 314 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
 315   = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
 316
 317 pprCLabel (PprForAsm prepend_cSEP _) lbl
 318   = if prepend_cSEP
 319     then uppBeside pp_cSEP prLbl
 320     else prLbl
 321   where
 322     prLbl = pprCLabel PprForC lbl
 323
 324 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
 325   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
 326                pp_cSEP, uppPStr SLIT("upd")]
 327
 328 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
 329   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
 330                      uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
 331
 332 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
 333   = case (ctrlReturnConvAlg tc) of
 334         UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
 335         VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
 336
 337 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
 338   = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
 339
 340 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
 341   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
 342                pp_cSEP, uppPStr SLIT("upd")]
 343
 344 pprCLabel sty (CaseLabel u CaseReturnPt)
 345   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
 346 pprCLabel sty (CaseLabel u CaseVecTbl)
 347   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
 348 pprCLabel sty (CaseLabel u (CaseAlt tag))
 349   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
 350 pprCLabel sty (CaseLabel u CaseDefault)
 351   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
 352
 353 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
 354
 355 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
 356
 357 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 358   = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
 359                 uppStr (if upd_reqd then "upd" else "noupd"),
 360                 uppPStr SLIT("__")]
 361
 362 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
 363   = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
 364                 uppStr (if upd_reqd then "upd" else "noupd"),
 365                 uppPStr SLIT("__")]
 366
 367 pprCLabel sty (IdLabel (CLabelId id) flavor)
 368   = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
 369
 370 ppr_u u = prettyToUn (pprUnique u)
 371
 372 ppFlavor :: IdLabelInfo -> Unpretty
 373
 374 ppFlavor x = uppBeside pp_cSEP
 375                       (case x of
 376                        Closure          -> uppPStr SLIT("closure")
 377                        InfoTbl          -> uppPStr SLIT("info")
 378                        EntryStd         -> uppPStr SLIT("entry")
 379                        EntryFast arity  -> --false:ASSERT (arity > 0)
 380                                            uppBeside (uppPStr SLIT("fast")) (uppInt arity)
 381                        ConEntry         -> uppPStr SLIT("entry")
 382                        StaticConEntry   -> uppPStr SLIT("static_entry")
 383                        StaticInfoTbl    -> uppPStr SLIT("static_info")
 384                        PhantomInfoTbl   -> uppPStr SLIT("inregs_info")
 385                        VapInfoTbl True  -> uppPStr SLIT("vap_info")
 386                        VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
 387                        VapEntry True    -> uppPStr SLIT("vap_entry")
 388                        VapEntry False   -> uppPStr SLIT("vap_noupd_entry")
 389                        RednCounts       -> uppPStr SLIT("ct")
 390                       )
 391 \end{code}