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