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