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