ghc/compiler/absCSyn/CLabel.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CLabel.lhs,v 1.24 1999/03/02 16:44:26 sof Exp $
   5 %
   6 \section[CLabel]{@CLabel@: Information to make C Labels}
   7
   8 \begin{code}
   9 module CLabel (
  10         CLabel, -- abstract type
  11
  12         mkClosureLabel,
  13         mkSRTLabel,
  14         mkInfoTableLabel,
  15         mkStdEntryLabel,
  16         mkFastEntryLabel,
  17         mkConEntryLabel,
  18         mkStaticConEntryLabel,
  19         mkRednCountsLabel,
  20         mkConInfoTableLabel,
  21         mkStaticClosureLabel,
  22         mkStaticInfoTableLabel,
  23         mkApEntryLabel,
  24         mkApInfoTableLabel,
  25
  26         mkReturnPtLabel,
  27         mkReturnInfoLabel,
  28         mkVecTblLabel,
  29         mkAltLabel,
  30         mkDefaultLabel,
  31         mkBitmapLabel,
  32
  33         mkClosureTblLabel,
  34
  35         mkAsmTempLabel,
  36
  37         mkErrorStdEntryLabel,
  38         mkUpdEntryLabel,
  39         mkBlackHoleInfoTableLabel,
  40         mkRtsPrimOpLabel,
  41
  42         mkSelectorInfoLabel,
  43         mkSelectorEntryLabel,
  44
  45         mkCC_Label, mkCCS_Label,
  46
  47         needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
  48
  49         CLabelType(..), labelType, labelDynamic,
  50
  51         pprCLabel
  52 #if ! OMIT_NATIVE_CODEGEN
  53         , pprCLabel_asm
  54 #endif
  55     ) where
  56
  57
  58 #include "HsVersions.h"
  59
  60 #if ! OMIT_NATIVE_CODEGEN
  61 import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
  62 #endif
  63
  64 import CmdLineOpts      ( opt_Static )
  65 import CStrings         ( pp_cSEP )
  66 import DataCon          ( ConTag, DataCon )
  67 import Module           ( isDynamicModule )
  68 import Name             ( Name, getName, isExternallyVisibleName, nameModule, isLocallyDefinedName )
  69 import TyCon            ( TyCon )
  70 import Unique           ( pprUnique, Unique )
  71 import PrimOp           ( PrimOp, pprPrimOp )
  72 import CostCentre       ( CostCentre, CostCentreStack )
  73 import Util
  74 import Outputable
  75 \end{code}
  76
  77 things we want to find out:
  78
  79 * should the labelled things be declared "static" (visible only in this file)?
  80
  81 * should it be declared "const" (read-only text space)?
  82
  83 * does it need declarations at all? (v common Prelude things are pre-declared)
  84
  85 * what type does it have? (for generating accurate enough C declarations
  86   so that the C compiler won't complain).
  87
  88 \begin{code}
  89 data CLabel
  90   = IdLabel                     -- A family of labels related to the
  91         Name                    -- definition of a particular Id
  92         IdLabelInfo
  93
  94   | DataConLabel                -- Ditto data constructors
  95         Name
  96         DataConLabelInfo
  97
  98   | CaseLabel                   -- A family of labels related to a particular case expression
  99         Unique                  -- Unique says which case expression
 100         CaseLabelInfo
 101
 102   | TyConLabel TyCon            -- currently only one kind of TyconLabel,
 103                                 -- a 'Closure Table'.
 104
 105   | AsmTempLabel    Unique
 106
 107   | RtsLabel        RtsLabelInfo
 108
 109   | CC_Label CostCentre
 110   | CCS_Label CostCentreStack
 111
 112   deriving (Eq, Ord)
 113 \end{code}
 114
 115 \begin{code}
 116 data IdLabelInfo
 117   = Closure             -- Label for (static???) closure
 118
 119   | SRT                 -- Static reference table
 120
 121   | InfoTbl             -- Info table for a closure; always read-only
 122
 123   | EntryStd            -- Thunk, or "slow", code entry point
 124
 125   | EntryFast Int       -- entry pt when no arg satisfaction chk needed;
 126                         -- Int is the arity of the function (to be
 127                         -- encoded into the name)
 128
 129                         -- Ticky-ticky counting
 130   | RednCounts          -- Label of place to keep reduction-count info for
 131                         -- this Id
 132   deriving (Eq, Ord)
 133
 134 data DataConLabelInfo
 135   = ConEntry            -- the only kind of entry pt for constructors
 136   | ConInfoTbl          -- corresponding info table
 137
 138   | StaticClosure       -- Static constructor closure
 139                         -- e.g., nullary constructor
 140   | StaticConEntry      -- static constructor entry point
 141   | StaticInfoTbl       -- corresponding info table
 142   deriving (Eq, Ord)
 143
 144 data CaseLabelInfo
 145   = CaseReturnPt
 146   | CaseReturnInfo
 147   | CaseVecTbl
 148   | CaseAlt ConTag
 149   | CaseDefault
 150   | CaseBitmap
 151   deriving (Eq, Ord)
 152
 153 data RtsLabelInfo
 154   = RtsShouldNeverHappenCode
 155
 156   | RtsBlackHoleInfoTbl
 157
 158   | RtsUpdEntry
 159
 160   | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-}  -- Selector thunks
 161   | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
 162
 163   | RtsApInfoTbl Bool{-updatable-} Int{-arity-}         -- AP thunks
 164   | RtsApEntry   Bool{-updatable-} Int{-arity-}
 165
 166   | RtsPrimOp PrimOp
 167
 168   deriving (Eq, Ord)
 169
 170 -- Label Type: for generating C declarations.
 171
 172 data CLabelType
 173   = InfoTblType
 174   | ClosureType
 175   | VecTblType
 176   | CodeType
 177   | DataType
 178 \end{code}
 179
 180 \begin{code}
 181 mkClosureLabel          id              = IdLabel id  Closure
 182 mkSRTLabel              id              = IdLabel id  SRT
 183 mkInfoTableLabel        id              = IdLabel id  InfoTbl
 184 mkStdEntryLabel         id              = IdLabel id  EntryStd
 185 mkFastEntryLabel        id arity        = ASSERT(arity > 0)
 186                                           IdLabel id  (EntryFast arity)
 187
 188 mkRednCountsLabel       id              = IdLabel id  RednCounts
 189
 190 mkStaticClosureLabel    con             = DataConLabel con StaticClosure
 191 mkStaticInfoTableLabel  con             = DataConLabel con StaticInfoTbl
 192 mkConInfoTableLabel     con             = DataConLabel con ConInfoTbl
 193 mkConEntryLabel         con             = DataConLabel con ConEntry
 194 mkStaticConEntryLabel   con             = DataConLabel con StaticConEntry
 195
 196
 197 mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
 198 mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
 199 mkVecTblLabel   uniq            = CaseLabel uniq CaseVecTbl
 200 mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
 201 mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
 202 mkBitmapLabel   uniq            = CaseLabel uniq CaseBitmap
 203
 204 mkClosureTblLabel tycon         = TyConLabel tycon
 205
 206 mkAsmTempLabel                  = AsmTempLabel
 207
 208         -- Some fixed runtime system labels
 209
 210 mkErrorStdEntryLabel            = RtsLabel RtsShouldNeverHappenCode
 211 mkUpdEntryLabel                 = RtsLabel RtsUpdEntry
 212 mkBlackHoleInfoTableLabel       = RtsLabel RtsBlackHoleInfoTbl
 213 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 214
 215 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTbl upd off)
 216 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry   upd off)
 217
 218 mkApInfoTableLabel  upd off     = RtsLabel (RtsApInfoTbl upd off)
 219 mkApEntryLabel upd off          = RtsLabel (RtsApEntry   upd off)
 220
 221         -- Cost centres etc.
 222
 223 mkCC_Label      cc              = CC_Label cc
 224 mkCCS_Label     ccs             = CCS_Label ccs
 225 \end{code}
 226
 227 \begin{code}
 228 needsCDecl :: CLabel -> Bool    -- False <=> it's pre-declared; don't bother
 229 isReadOnly :: CLabel -> Bool    -- lives in C "text space"
 230 isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
 231 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 232 \end{code}
 233
 234 @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
 235 object.  {\em Also:} No need to spit out labels for things generated
 236 by the flattener (in @AbsCUtils@)---it is careful to ensure references
 237 to them are always backwards.  These are return-point and vector-table
 238 labels.
 239
 240 Declarations for (non-prelude) @Id@-based things are needed because of
 241 mutual recursion.
 242
 243 Declarations for direct return points are needed, because they may be
 244 let-no-escapes, which can be recursive.
 245
 246 \begin{code}
 247 needsCDecl (IdLabel _ _)                = True
 248 needsCDecl (CaseLabel _ CaseReturnPt)   = True
 249 needsCDecl (DataConLabel _ _)           = True
 250 needsCDecl (CaseLabel _ _)              = False
 251
 252 needsCDecl (AsmTempLabel _)             = False
 253 needsCDecl (TyConLabel _)               = False
 254 needsCDecl (RtsLabel _)                 = False
 255 needsCDecl (CC_Label _)                 = False
 256 needsCDecl (CCS_Label _)                = False
 257 \end{code}
 258
 259 Whether the labelled thing can be put in C "text space":
 260
 261 \begin{code}
 262 isReadOnly (IdLabel _ InfoTbl)  = True  -- info-tables: yes
 263 isReadOnly (IdLabel _ other)    = False -- others: pessimistically, no
 264
 265 isReadOnly (DataConLabel _ _)   = True -- and so on, for other
 266 isReadOnly (TyConLabel _)       = True
 267 isReadOnly (CaseLabel _ _)      = True
 268 isReadOnly (AsmTempLabel _)     = True
 269 isReadOnly (RtsLabel _)         = True
 270 isReadOnly (CC_Label _)         = True
 271 isReadOnly (CCS_Label _)        = True
 272 \end{code}
 273
 274 Whether the label is an assembler temporary:
 275
 276 \begin{code}
 277 isAsmTemp (AsmTempLabel _) = True
 278 isAsmTemp _                = False
 279 \end{code}
 280
 281 C ``static'' or not...
 282 From the point of view of the code generator, a name is
 283 externally visible if it has to be declared as exported
 284 in the .o file's symbol table; that is, made non-static.
 285
 286 \begin{code}
 287 externallyVisibleCLabel (DataConLabel _ _) = True
 288 externallyVisibleCLabel (TyConLabel tc)    = True
 289 externallyVisibleCLabel (CaseLabel _ _)    = False
 290 externallyVisibleCLabel (AsmTempLabel _)   = False
 291 externallyVisibleCLabel (RtsLabel _)       = True
 292 externallyVisibleCLabel (IdLabel id _)     = isExternallyVisibleName id
 293 externallyVisibleCLabel (CC_Label _)       = False -- not strictly true
 294 externallyVisibleCLabel (CCS_Label _)      = False -- not strictly true
 295 \end{code}
 296
 297 For generating correct types in label declarations...
 298
 299 \begin{code}
 300 labelType :: CLabel -> CLabelType
 301 labelType (RtsLabel RtsBlackHoleInfoTbl)      = InfoTblType
 302 labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
 303 labelType (RtsLabel (RtsApInfoTbl _ _))       = InfoTblType
 304 labelType (CaseLabel _ CaseReturnInfo)        = InfoTblType
 305 labelType (CaseLabel _ CaseReturnPt)          = CodeType
 306 labelType (CaseLabel _ CaseVecTbl)            = VecTblType
 307
 308 labelType (IdLabel _ info) =
 309   case info of
 310     InfoTbl       -> InfoTblType
 311     Closure       -> ClosureType
 312     _             -> CodeType
 313
 314 labelType (DataConLabel _ info) =
 315   case info of
 316      ConInfoTbl    -> InfoTblType
 317      StaticInfoTbl -> InfoTblType
 318      StaticClosure -> ClosureType
 319      _             -> CodeType
 320
 321 labelType _        = DataType
 322 \end{code}
 323
 324 When referring to data in code, we need to know whether
 325 that data resides in a DLL or not. [Win32 only.]
 326 @labelDynamic@ returns @True@ if the label is located
 327 in a DLL, be it a data reference or not.
 328
 329 \begin{code}
 330 labelDynamic :: CLabel -> Bool
 331 labelDynamic lbl =
 332   case lbl of
 333    RtsLabel _  -> not opt_Static  -- i.e., is the RTS in a DLL or not?
 334    IdLabel n k      | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n)
 335    DataConLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n)
 336    TyConLabel tc    | not (isLocallyDefinedName (getName tc)) -> isDynamicModule (nameModule (getName tc))
 337    _ -> False
 338
 339 \end{code}
 340
 341
 342 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
 343 right places. It is used to detect when the abstractC statement of an
 344 CCodeBlock actually contains the code for a slow entry point.  -- HWL
 345
 346 We need at least @Eq@ for @CLabels@, because we want to avoid
 347 duplicate declarations in generating C (see @labelSeenTE@ in
 348 @PprAbsC@).
 349
 350 -----------------------------------------------------------------------------
 351 Printing out CLabels.
 352
 353 Convention:
 354
 355       <name>_<type>
 356
 357 where <name> is <Module>_<name> for external names and <unique> for
 358 internal names. <type> is one of the following:
 359
 360          info                   Info table
 361          srt                    Static reference table
 362          entry                  Entry code
 363          ret                    Direct return address
 364          vtbl                   Vector table
 365          <n>_alt                Case alternative (tag n)
 366          dflt                   Default case alternative
 367          btm                    Large bitmap vector
 368          closure                Static closure
 369          static_closure         Static closure (???)
 370          con_entry              Dynamic Constructor entry code
 371          con_info               Dynamic Constructor info table
 372          static_entry           Static Constructor entry code
 373          static_info            Static Constructor info table
 374          sel_info               Selector info table
 375          sel_entry              Selector entry code
 376
 377 \begin{code}
 378 -- specialised for PprAsm: saves lots of arg passing in NCG
 379 #if ! OMIT_NATIVE_CODEGEN
 380 pprCLabel_asm = pprCLabel
 381 #endif
 382
 383 pprCLabel :: CLabel -> SDoc
 384
 385 #if ! OMIT_NATIVE_CODEGEN
 386 pprCLabel (AsmTempLabel u)
 387   = text (fmtAsmLbl (show u))
 388 #endif
 389
 390 pprCLabel lbl =
 391 #if ! OMIT_NATIVE_CODEGEN
 392     getPprStyle $ \ sty ->
 393     if asmStyle sty && underscorePrefix then
 394        pp_cSEP <> pprCLbl lbl
 395     else
 396 #endif
 397        pprCLbl lbl
 398
 399 pprCLbl (CaseLabel u CaseReturnPt)
 400   = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
 401 pprCLbl (CaseLabel u CaseReturnInfo)
 402   = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
 403 pprCLbl (CaseLabel u CaseVecTbl)
 404   = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
 405 pprCLbl (CaseLabel u (CaseAlt tag))
 406   = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
 407 pprCLbl (CaseLabel u CaseDefault)
 408   = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
 409 pprCLbl (CaseLabel u CaseBitmap)
 410   = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
 411
 412 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
 413
 414 pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
 415
 416 pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("CAF_BLACKHOLE_info")
 417
 418 pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
 419   = hcat [ptext SLIT("__sel_"), text (show offset),
 420                 ptext (if upd_reqd
 421                         then SLIT("_upd_info")
 422                         else SLIT("_noupd_info"))
 423         ]
 424
 425 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
 426   = hcat [ptext SLIT("__sel_"), text (show offset),
 427                 ptext (if upd_reqd
 428                         then SLIT("_upd_entry")
 429                         else SLIT("_noupd_entry"))
 430         ]
 431
 432 pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
 433   = hcat [ptext SLIT("__ap_"), text (show arity),
 434                 ptext (if upd_reqd
 435                         then SLIT("_upd_info")
 436                         else SLIT("_noupd_info"))
 437         ]
 438
 439 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
 440   = hcat [ptext SLIT("__ap_"), text (show arity),
 441                 ptext (if upd_reqd
 442                         then SLIT("_upd_entry")
 443                         else SLIT("_noupd_entry"))
 444         ]
 445
 446 pprCLbl (RtsLabel (RtsPrimOp primop))
 447   = pprPrimOp primop <> ptext SLIT("_fast")
 448
 449 pprCLbl (TyConLabel tc)
 450   = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
 451
 452 pprCLbl (IdLabel      id  flavor) = ppr id <> ppIdFlavor flavor
 453 pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
 454
 455 pprCLbl (CC_Label cc)           = ppr cc
 456 pprCLbl (CCS_Label ccs)         = ppr ccs
 457
 458 ppIdFlavor :: IdLabelInfo -> SDoc
 459
 460 ppIdFlavor x = pp_cSEP <>
 461                (case x of
 462                        Closure          -> ptext SLIT("closure")
 463                        SRT              -> ptext SLIT("srt")
 464                        InfoTbl          -> ptext SLIT("info")
 465                        EntryStd         -> ptext SLIT("entry")
 466                        EntryFast arity  -> --false:ASSERT (arity > 0)
 467                                            (<>) (ptext SLIT("fast")) (int arity)
 468                        RednCounts       -> ptext SLIT("ct")
 469                       )
 470
 471 ppConFlavor x = pp_cSEP <>
 472                 (case x of
 473                        StaticClosure    -> ptext SLIT("static_closure")
 474                        ConEntry         -> ptext SLIT("con_entry")
 475                        ConInfoTbl       -> ptext SLIT("con_info")
 476                        StaticConEntry   -> ptext SLIT("static_entry")
 477                        StaticInfoTbl    -> ptext SLIT("static_info")
 478                 )
 479 \end{code}
 480