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