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
  47 #ifdef GRAN
  48         , isSlowEntryCCodeBlock
  49 #endif
  50     ) where
  51
  52 import Ubiq{-uitous-}
  53 import AbsCLoop         ( CtrlReturnConvention(..),
  54                           ctrlReturnConvAlg
  55                         )
  56 #if ! OMIT_NATIVE_CODEGEN
  57 import NcgLoop          ( underscorePrefix, fmtAsmLbl )
  58 #endif
  59
  60 import CStrings         ( pp_cSEP )
  61 import Id               ( externallyVisibleId, cmpId_withSpecDataCon,
  62                           isDataCon, isDictFunId,
  63                           isConstMethodId_maybe,
  64                           isDefaultMethodId_maybe,
  65                           isSuperDictSelId_maybe, fIRST_TAG,
  66                           ConTag(..), GenId{-instance Outputable-}
  67                         )
  68 import Maybes           ( maybeToBool )
  69 import PprStyle         ( PprStyle(..) )
  70 import PprType          ( showTyCon, GenType{-instance Outputable-} )
  71 import Pretty           ( prettyToUn )
  72 import TyCon            ( TyCon{-instance Eq-} )
  73 import Unique           ( showUnique, pprUnique, Unique{-instance Eq-} )
  74 import Unpretty         -- NOTE!! ********************
  75 import Util             ( assertPanic )
  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   | is_DefaultMethodId id = True
 294   | is_SuperDictSelId id  = True
 295   | otherwise             = externallyVisibleId id
 296   where
 297     is_ConstMethodId   id = maybeToBool (isConstMethodId_maybe   id)
 298     is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
 299     is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  id)
 300 \end{code}
 301
 302 These GRAN functions are needed for spitting out GRAN_FETCH() at the
 303 right places. It is used to detect when the abstractC statement of an
 304 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 305
 306 \begin{code}
 307 #ifdef GRAN
 308
 309 isSlowEntryCCodeBlock :: CLabel -> Bool
 310 isSlowEntryCCodeBlock _ = False
 311 -- Worth keeping?  ToDo (WDP)
 312
 313 #endif {-GRAN-}
 314 \end{code}
 315
 316 We need at least @Eq@ for @CLabels@, because we want to avoid
 317 duplicate declarations in generating C (see @labelSeenTE@ in
 318 @PprAbsC@).
 319
 320 \begin{code}
 321 -- specialised for PprAsm: saves lots of arg passing in NCG
 322 #if ! OMIT_NATIVE_CODEGEN
 323 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
 324 #endif
 325
 326 pprCLabel :: PprStyle -> CLabel -> Unpretty
 327
 328 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
 329   = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
 330
 331 pprCLabel (PprForAsm prepend_cSEP _) lbl
 332   = if prepend_cSEP
 333     then uppBeside pp_cSEP prLbl
 334     else prLbl
 335   where
 336     prLbl = pprCLabel PprForC lbl
 337
 338 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
 339   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
 340                pp_cSEP, uppPStr SLIT("upd")]
 341
 342 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
 343   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
 344                      uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
 345
 346 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
 347   = case (ctrlReturnConvAlg tc) of
 348         UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
 349         VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
 350
 351 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
 352   = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
 353
 354 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
 355   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
 356                pp_cSEP, uppPStr SLIT("upd")]
 357
 358 pprCLabel sty (CaseLabel u CaseReturnPt)
 359   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
 360 pprCLabel sty (CaseLabel u CaseVecTbl)
 361   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
 362 pprCLabel sty (CaseLabel u (CaseAlt tag))
 363   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
 364 pprCLabel sty (CaseLabel u CaseDefault)
 365   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
 366
 367 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
 368
 369 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
 370
 371 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 372   = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
 373                 uppStr (if upd_reqd then "upd" else "noupd"),
 374                 uppPStr SLIT("__")]
 375
 376 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
 377   = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
 378                 uppStr (if upd_reqd then "upd" else "noupd"),
 379                 uppPStr SLIT("__")]
 380
 381 pprCLabel sty (IdLabel (CLabelId id) flavor)
 382   = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
 383
 384 ppr_u u = prettyToUn (pprUnique u)
 385
 386 ppFlavor :: IdLabelInfo -> Unpretty
 387
 388 ppFlavor x = uppBeside pp_cSEP
 389                       (case x of
 390                        Closure          -> uppPStr SLIT("closure")
 391                        InfoTbl          -> uppPStr SLIT("info")
 392                        EntryStd         -> uppPStr SLIT("entry")
 393                        EntryFast arity  -> --false:ASSERT (arity > 0)
 394                                            uppBeside (uppPStr SLIT("fast")) (uppInt arity)
 395                        ConEntry         -> uppPStr SLIT("entry")
 396                        StaticConEntry   -> uppPStr SLIT("static_entry")
 397                        StaticInfoTbl    -> uppPStr SLIT("static_info")
 398                        PhantomInfoTbl   -> uppPStr SLIT("inregs_info")
 399                        VapInfoTbl True  -> uppPStr SLIT("vap_info")
 400                        VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
 401                        VapEntry True    -> uppPStr SLIT("vap_entry")
 402                        VapEntry False   -> uppPStr SLIT("vap_noupd_entry")
 403                        RednCounts       -> uppPStr SLIT("ct")
 404                       )
 405 \end{code}