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