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