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