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, pprTrace{-ToDo: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 \begin{code}
 294 externallyVisibleCLabel (TyConLabel tc _) = True
 295 externallyVisibleCLabel (CaseLabel _ _)   = False
 296 externallyVisibleCLabel (AsmTempLabel _)  = False
 297 externallyVisibleCLabel (RtsLabel _)      = True
 298 externallyVisibleCLabel (IdLabel (CLabelId id) _)
 299   | isDataCon id          = True
 300   | is_ConstMethodId id   = True  -- These are here to ensure splitting works
 301   | isDictFunId id        = True  -- when these values have not been exported
 302   | is_DefaultMethodId id = True
 303   | is_SuperDictSelId id  = True
 304   | otherwise             = externallyVisibleId id
 305   where
 306     is_ConstMethodId   id = maybeToBool (isConstMethodId_maybe   id)
 307     is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
 308     is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  id)
 309 \end{code}
 310
 311 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 312 right places. It is used to detect when the abstractC statement of an
 313 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 314
 315 We need at least @Eq@ for @CLabels@, because we want to avoid
 316 duplicate declarations in generating C (see @labelSeenTE@ in
 317 @PprAbsC@).
 318
 319 \begin{code}
 320 -- specialised for PprAsm: saves lots of arg passing in NCG
 321 #if ! OMIT_NATIVE_CODEGEN
 322 pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
 323 #endif
 324
 325 pprCLabel :: PprStyle -> CLabel -> Unpretty
 326
 327 pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
 328   = uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
 329
 330 pprCLabel (PprForAsm prepend_cSEP _) lbl
 331   = if prepend_cSEP
 332     then uppBeside pp_cSEP prLbl
 333     else prLbl
 334   where
 335     prLbl = pprCLabel PprForC lbl
 336
 337 pprCLabel sty (TyConLabel tc UnvecConUpdCode)
 338   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
 339                pp_cSEP, uppPStr SLIT("upd")]
 340
 341 pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
 342   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
 343                      uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
 344
 345 pprCLabel sty (TyConLabel tc (StdUpdCode tag))
 346   = case (ctrlReturnConvAlg tc) of
 347         UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
 348         VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
 349
 350 pprCLabel sty (TyConLabel tc InfoTblVecTbl)
 351   = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")]
 352
 353 pprCLabel sty (TyConLabel tc StdUpdVecTbl)
 354   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
 355                pp_cSEP, uppPStr SLIT("upd")]
 356
 357 pprCLabel sty (CaseLabel u CaseReturnPt)
 358   = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
 359 pprCLabel sty (CaseLabel u CaseVecTbl)
 360   = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
 361 pprCLabel sty (CaseLabel u (CaseAlt tag))
 362   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
 363 pprCLabel sty (CaseLabel u CaseDefault)
 364   = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
 365
 366 pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
 367
 368 pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
 369
 370 pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 371   = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
 372                 uppStr (if upd_reqd then "upd" else "noupd"),
 373                 uppPStr SLIT("__")]
 374
 375 pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
 376   = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
 377                 uppStr (if upd_reqd then "upd" else "noupd"),
 378                 uppPStr SLIT("__")]
 379
 380 pprCLabel sty (IdLabel (CLabelId id) flavor)
 381   = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
 382
 383 ppr_u u = prettyToUn (pprUnique u)
 384
 385 ppr_tycon sty tc
 386   = let
 387         str = showTyCon sty tc
 388     in
 389     --pprTrace "ppr_tycon:" (ppStr str) $
 390     uppStr str
 391
 392 ppFlavor :: IdLabelInfo -> Unpretty
 393
 394 ppFlavor x = uppBeside pp_cSEP
 395                       (case x of
 396                        Closure          -> uppPStr SLIT("closure")
 397                        InfoTbl          -> uppPStr SLIT("info")
 398                        EntryStd         -> uppPStr SLIT("entry")
 399                        EntryFast arity  -> --false:ASSERT (arity > 0)
 400                                            uppBeside (uppPStr SLIT("fast")) (uppInt arity)
 401                        StaticClosure    -> uppPStr SLIT("static_closure")
 402                        ConEntry         -> uppPStr SLIT("con_entry")
 403                        ConInfoTbl       -> uppPStr SLIT("con_info")
 404                        StaticConEntry   -> uppPStr SLIT("static_entry")
 405                        StaticInfoTbl    -> uppPStr SLIT("static_info")
 406                        PhantomInfoTbl   -> uppPStr SLIT("inregs_info")
 407                        VapInfoTbl True  -> uppPStr SLIT("vap_info")
 408                        VapInfoTbl False -> uppPStr SLIT("vap_noupd_info")
 409                        VapEntry True    -> uppPStr SLIT("vap_entry")
 410                        VapEntry False   -> uppPStr SLIT("vap_noupd_entry")
 411                        RednCounts       -> uppPStr SLIT("ct")
 412                       )
 413 \end{code}