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