summaryrefslogtreecommitdiff
path: root/compiler/cmm/CLabel.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm/CLabel.hs')
-rw-r--r--compiler/cmm/CLabel.hs831
1 files changed, 831 insertions, 0 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
new file mode 100644
index 0000000000..e42b92db5a
--- /dev/null
+++ b/compiler/cmm/CLabel.hs
@@ -0,0 +1,831 @@
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CLabel (
+ CLabel, -- abstract type
+
+ mkClosureLabel,
+ mkSRTLabel,
+ mkSRTDescLabel,
+ mkInfoTableLabel,
+ mkEntryLabel,
+ mkSlowEntryLabel,
+ mkConEntryLabel,
+ mkStaticConEntryLabel,
+ mkRednCountsLabel,
+ mkConInfoTableLabel,
+ mkStaticInfoTableLabel,
+ mkApEntryLabel,
+ mkApInfoTableLabel,
+ mkClosureTableLabel,
+
+ mkLocalClosureLabel,
+ mkLocalInfoTableLabel,
+ mkLocalEntryLabel,
+ mkLocalConEntryLabel,
+ mkLocalStaticConEntryLabel,
+ mkLocalConInfoTableLabel,
+ mkLocalStaticInfoTableLabel,
+ mkLocalClosureTableLabel,
+
+ mkReturnPtLabel,
+ mkReturnInfoLabel,
+ mkAltLabel,
+ mkDefaultLabel,
+ mkBitmapLabel,
+ mkStringLitLabel,
+
+ mkAsmTempLabel,
+
+ mkModuleInitLabel,
+ mkPlainModuleInitLabel,
+
+ mkSplitMarkerLabel,
+ mkDirty_MUT_VAR_Label,
+ mkUpdInfoLabel,
+ mkSeqInfoLabel,
+ mkIndStaticInfoLabel,
+ mkMainCapabilityLabel,
+ mkMAP_FROZEN_infoLabel,
+ mkMAP_DIRTY_infoLabel,
+ mkEMPTY_MVAR_infoLabel,
+
+ mkTopTickyCtrLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkSECAFBlackHoleInfoTableLabel,
+ mkRtsPrimOpLabel,
+ mkRtsSlowTickyCtrLabel,
+
+ moduleRegdLabel,
+
+ mkSelectorInfoLabel,
+ mkSelectorEntryLabel,
+
+ mkRtsInfoLabel,
+ mkRtsEntryLabel,
+ mkRtsRetInfoLabel,
+ mkRtsRetLabel,
+ mkRtsCodeLabel,
+ mkRtsDataLabel,
+
+ mkRtsInfoLabelFS,
+ mkRtsEntryLabelFS,
+ mkRtsRetInfoLabelFS,
+ mkRtsRetLabelFS,
+ mkRtsCodeLabelFS,
+ mkRtsDataLabelFS,
+
+ mkRtsApFastLabel,
+
+ mkForeignLabel,
+
+ mkCCLabel, mkCCSLabel,
+
+ DynamicLinkerLabelInfo(..),
+ mkDynamicLinkerLabel,
+ dynamicLinkerLabelInfo,
+
+ mkPicBaseLabel,
+ mkDeadStripPreventer,
+
+ infoLblToEntryLbl, entryLblToInfoLbl,
+ needsCDecl, isAsmTemp, externallyVisibleCLabel,
+ CLabelType(..), labelType, labelDynamic,
+
+ pprCLabel
+ ) where
+
+
+#include "HsVersions.h"
+
+import Packages ( HomeModules )
+import StaticFlags ( opt_Static, opt_DoTickyProfiling )
+import Packages ( isHomeModule, isDllName )
+import DataCon ( ConTag )
+import Module ( moduleFS, Module )
+import Name ( Name, isExternalName )
+import Unique ( pprUnique, Unique )
+import PrimOp ( PrimOp )
+import Config ( cLeadingUnderscore )
+import CostCentre ( CostCentre, CostCentreStack )
+import Outputable
+import FastString
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{-
+CLabel is an abstract type that supports the following operations:
+
+ - Pretty printing
+
+ - In a C file, does it need to be declared before use? (i.e. is it
+ guaranteed to be already in scope in the places we need to refer to it?)
+
+ - If it needs to be declared, what type (code or data) should it be
+ declared to have?
+
+ - Is it visible outside this object file or not?
+
+ - Is it "dynamic" (see details below)
+
+ - Eq and Ord, so that we can make sets of CLabels (currently only
+ used in outputting C as far as I can tell, to avoid generating
+ more than one declaration for any given label).
+
+ - Converting an info table label into an entry label.
+-}
+
+data CLabel
+ = IdLabel -- A family of labels related to the
+ Name -- definition of a particular Id or Con
+ IdLabelInfo
+
+ | DynIdLabel -- like IdLabel, but in a separate package,
+ Name -- and might therefore need a dynamic
+ IdLabelInfo -- reference.
+
+ | CaseLabel -- A family of labels related to a particular
+ -- case expression.
+ {-# UNPACK #-} !Unique -- Unique says which case expression
+ CaseLabelInfo
+
+ | AsmTempLabel
+ {-# UNPACK #-} !Unique
+
+ | StringLitLabel
+ {-# UNPACK #-} !Unique
+
+ | ModuleInitLabel
+ Module -- the module name
+ String -- its "way"
+ Bool -- True <=> is in a different package
+ -- at some point we might want some kind of version number in
+ -- the module init label, to guard against compiling modules in
+ -- the wrong order. We can't use the interface file version however,
+ -- because we don't always recompile modules which depend on a module
+ -- whose version has changed.
+
+ | PlainModuleInitLabel -- without the vesrion & way info
+ Module
+ Bool -- True <=> is in a different package
+
+ | ModuleRegdLabel
+
+ | RtsLabel RtsLabelInfo
+
+ | ForeignLabel FastString -- a 'C' (or otherwise foreign) label
+ (Maybe Int) -- possible '@n' suffix for stdcall functions
+ -- When generating C, the '@n' suffix is omitted, but when
+ -- generating assembler we must add it to the label.
+ Bool -- True <=> is dynamic
+
+ | CC_Label CostCentre
+ | CCS_Label CostCentreStack
+
+ -- Dynamic Linking in the NCG:
+ -- generated and used inside the NCG only,
+ -- see module PositionIndependentCode for details.
+
+ | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+ -- special variants of a label used for dynamic linking
+
+ | PicBaseLabel -- a label used as a base for PIC calculations
+ -- on some platforms.
+ -- It takes the form of a local numeric
+ -- assembler label '1'; it is pretty-printed
+ -- as 1b, referring to the previous definition
+ -- of 1: in the assembler source file.
+
+ | DeadStripPreventer CLabel
+ -- label before an info table to prevent excessive dead-stripping on darwin
+
+ deriving (Eq, Ord)
+
+data IdLabelInfo
+ = Closure -- Label for closure
+ | SRT -- Static reference table
+ | SRTDesc -- Static reference table descriptor
+ | InfoTable -- Info tables for closures; always read-only
+ | Entry -- entry point
+ | Slow -- slow entry point
+
+ | RednCounts -- Label of place to keep Ticky-ticky info for
+ -- this Id
+
+ | Bitmap -- A bitmap (function or case return)
+
+ | ConEntry -- constructor entry point
+ | ConInfoTable -- corresponding info table
+ | StaticConEntry -- static constructor entry point
+ | StaticInfoTable -- corresponding info table
+
+ | ClosureTable -- table of closures for Enum tycons
+
+ deriving (Eq, Ord)
+
+
+data CaseLabelInfo
+ = CaseReturnPt
+ | CaseReturnInfo
+ | CaseAlt ConTag
+ | CaseDefault
+ deriving (Eq, Ord)
+
+
+data RtsLabelInfo
+ = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- Selector thunks
+ | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
+
+ | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- AP thunks
+ | RtsApEntry Bool{-updatable-} Int{-arity-}
+
+ | RtsPrimOp PrimOp
+
+ | RtsInfo LitString -- misc rts info tables
+ | RtsEntry LitString -- misc rts entry points
+ | RtsRetInfo LitString -- misc rts ret info tables
+ | RtsRet LitString -- misc rts return points
+ | RtsData LitString -- misc rts data bits, eg CHARLIKE_closure
+ | RtsCode LitString -- misc rts code
+
+ | RtsInfoFS FastString -- misc rts info tables
+ | RtsEntryFS FastString -- misc rts entry points
+ | RtsRetInfoFS FastString -- misc rts ret info tables
+ | RtsRetFS FastString -- misc rts return points
+ | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure
+ | RtsCodeFS FastString -- misc rts code
+
+ | RtsApFast LitString -- _fast versions of generic apply
+
+ | RtsSlowTickyCtr String
+
+ deriving (Eq, Ord)
+ -- NOTE: Eq on LitString compares the pointer only, so this isn't
+ -- a real equality.
+
+data DynamicLinkerLabelInfo
+ = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt
+ | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+ | GotSymbolPtr -- ELF: foo@got
+ | GotSymbolOffset -- ELF: foo@gotoff
+
+ deriving (Eq, Ord)
+
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+
+-- These are always local:
+mkSRTLabel name = IdLabel name SRT
+mkSRTDescLabel name = IdLabel name SRTDesc
+mkSlowEntryLabel name = IdLabel name Slow
+mkBitmapLabel name = IdLabel name Bitmap
+mkRednCountsLabel name = IdLabel name RednCounts
+
+-- These have local & (possibly) external variants:
+mkLocalClosureLabel name = IdLabel name Closure
+mkLocalInfoTableLabel name = IdLabel name InfoTable
+mkLocalEntryLabel name = IdLabel name Entry
+mkLocalClosureTableLabel name = IdLabel name ClosureTable
+
+mkClosureLabel hmods name
+ | isDllName hmods name = DynIdLabel name Closure
+ | otherwise = IdLabel name Closure
+
+mkInfoTableLabel hmods name
+ | isDllName hmods name = DynIdLabel name InfoTable
+ | otherwise = IdLabel name InfoTable
+
+mkEntryLabel hmods name
+ | isDllName hmods name = DynIdLabel name Entry
+ | otherwise = IdLabel name Entry
+
+mkClosureTableLabel hmods name
+ | isDllName hmods name = DynIdLabel name ClosureTable
+ | otherwise = IdLabel name ClosureTable
+
+mkLocalConInfoTableLabel con = IdLabel con ConInfoTable
+mkLocalConEntryLabel con = IdLabel con ConEntry
+mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable
+mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry
+
+mkConInfoTableLabel name False = IdLabel name ConInfoTable
+mkConInfoTableLabel name True = DynIdLabel name ConInfoTable
+
+mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable
+mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable
+
+mkConEntryLabel hmods name
+ | isDllName hmods name = DynIdLabel name ConEntry
+ | otherwise = IdLabel name ConEntry
+
+mkStaticConEntryLabel hmods name
+ | isDllName hmods name = DynIdLabel name StaticConEntry
+ | otherwise = IdLabel name StaticConEntry
+
+
+mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
+mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
+mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
+mkDefaultLabel uniq = CaseLabel uniq CaseDefault
+
+mkStringLitLabel = StringLitLabel
+mkAsmTempLabel = AsmTempLabel
+
+mkModuleInitLabel :: HomeModules -> Module -> String -> CLabel
+mkModuleInitLabel hmods mod way
+ = ModuleInitLabel mod way $! (not (isHomeModule hmods mod))
+
+mkPlainModuleInitLabel :: HomeModules -> Module -> CLabel
+mkPlainModuleInitLabel hmods mod
+ = PlainModuleInitLabel mod $! (not (isHomeModule hmods mod))
+
+ -- Some fixed runtime system labels
+
+mkSplitMarkerLabel = RtsLabel (RtsCode SLIT("__stg_split_marker"))
+mkDirty_MUT_VAR_Label = RtsLabel (RtsCode SLIT("dirty_MUT_VAR"))
+mkUpdInfoLabel = RtsLabel (RtsInfo SLIT("stg_upd_frame"))
+mkSeqInfoLabel = RtsLabel (RtsInfo SLIT("stg_seq_frame"))
+mkIndStaticInfoLabel = RtsLabel (RtsInfo SLIT("stg_IND_STATIC"))
+mkMainCapabilityLabel = RtsLabel (RtsData SLIT("MainCapability"))
+mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN0"))
+mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_DIRTY"))
+mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR"))
+
+mkTopTickyCtrLabel = RtsLabel (RtsData SLIT("top_ct"))
+mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE"))
+mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
+ RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE"))
+ else -- RTS won't have info table unless -ticky is on
+ panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
+
+moduleRegdLabel = ModuleRegdLabel
+
+mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off)
+mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
+
+mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off)
+mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
+
+ -- Foreign labels
+
+mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
+mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic
+
+ -- Cost centres etc.
+
+mkCCLabel cc = CC_Label cc
+mkCCSLabel ccs = CCS_Label ccs
+
+mkRtsInfoLabel str = RtsLabel (RtsInfo str)
+mkRtsEntryLabel str = RtsLabel (RtsEntry str)
+mkRtsRetInfoLabel str = RtsLabel (RtsRetInfo str)
+mkRtsRetLabel str = RtsLabel (RtsRet str)
+mkRtsCodeLabel str = RtsLabel (RtsCode str)
+mkRtsDataLabel str = RtsLabel (RtsData str)
+
+mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str)
+mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str)
+mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
+mkRtsRetLabelFS str = RtsLabel (RtsRetFS str)
+mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str)
+mkRtsDataLabelFS str = RtsLabel (RtsDataFS str)
+
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+
+mkRtsSlowTickyCtrLabel :: String -> CLabel
+mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+
+ -- Dynamic linking
+
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _ = Nothing
+
+ -- Position independent code
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel = PicBaseLabel
+
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl = DeadStripPreventer lbl
+
+-- -----------------------------------------------------------------------------
+-- Converting info labels to entry labels.
+
+infoLblToEntryLbl :: CLabel -> CLabel
+infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry
+infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry
+infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry
+infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry
+infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry
+infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
+infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
+infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
+
+entryLblToInfoLbl :: CLabel -> CLabel
+entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable
+entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable
+entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable
+entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable
+entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable
+entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable
+entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
+entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
+entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
+entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
+entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+
+needsCDecl :: CLabel -> Bool
+ -- False <=> it's pre-declared; don't bother
+ -- don't bother declaring SRT & Bitmap labels, we always make sure
+ -- they are defined before use.
+needsCDecl (IdLabel _ SRT) = False
+needsCDecl (IdLabel _ SRTDesc) = False
+needsCDecl (IdLabel _ Bitmap) = False
+needsCDecl (IdLabel _ _) = True
+needsCDecl (DynIdLabel _ _) = True
+needsCDecl (CaseLabel _ _) = True
+needsCDecl (ModuleInitLabel _ _ _) = True
+needsCDecl (PlainModuleInitLabel _ _) = True
+needsCDecl ModuleRegdLabel = False
+
+needsCDecl (StringLitLabel _) = False
+needsCDecl (AsmTempLabel _) = False
+needsCDecl (RtsLabel _) = False
+needsCDecl (ForeignLabel _ _ _) = False
+needsCDecl (CC_Label _) = True
+needsCDecl (CCS_Label _) = True
+
+-- Whether the label is an assembler temporary:
+
+isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
+isAsmTemp (AsmTempLabel _) = True
+isAsmTemp _ = False
+
+-- -----------------------------------------------------------------------------
+-- Is a CLabel visible outside this object file or not?
+
+-- From the point of view of the code generator, a name is
+-- externally visible if it has to be declared as exported
+-- in the .o file's symbol table; that is, made non-static.
+
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (CaseLabel _ _) = False
+externallyVisibleCLabel (StringLitLabel _) = False
+externallyVisibleCLabel (AsmTempLabel _) = False
+externallyVisibleCLabel (ModuleInitLabel _ _ _)= True
+externallyVisibleCLabel (PlainModuleInitLabel _ _)= True
+externallyVisibleCLabel ModuleRegdLabel = False
+externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (ForeignLabel _ _ _) = True
+externallyVisibleCLabel (IdLabel name _) = isExternalName name
+externallyVisibleCLabel (DynIdLabel name _) = isExternalName name
+externallyVisibleCLabel (CC_Label _) = True
+externallyVisibleCLabel (CCS_Label _) = True
+externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+ = CodeLabel
+ | DataLabel
+
+labelType :: CLabel -> CLabelType
+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsData _)) = DataLabel
+labelType (RtsLabel (RtsCode _)) = CodeLabel
+labelType (RtsLabel (RtsInfo _)) = DataLabel
+labelType (RtsLabel (RtsEntry _)) = CodeLabel
+labelType (RtsLabel (RtsRetInfo _)) = DataLabel
+labelType (RtsLabel (RtsRet _)) = CodeLabel
+labelType (RtsLabel (RtsDataFS _)) = DataLabel
+labelType (RtsLabel (RtsCodeFS _)) = CodeLabel
+labelType (RtsLabel (RtsInfoFS _)) = DataLabel
+labelType (RtsLabel (RtsEntryFS _)) = CodeLabel
+labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel
+labelType (RtsLabel (RtsRetFS _)) = CodeLabel
+labelType (RtsLabel (RtsApFast _)) = CodeLabel
+labelType (CaseLabel _ CaseReturnInfo) = DataLabel
+labelType (CaseLabel _ _) = CodeLabel
+labelType (ModuleInitLabel _ _ _) = CodeLabel
+labelType (PlainModuleInitLabel _ _) = CodeLabel
+
+labelType (IdLabel _ info) = idInfoLabelType info
+labelType (DynIdLabel _ info) = idInfoLabelType info
+labelType _ = DataLabel
+
+idInfoLabelType info =
+ case info of
+ InfoTable -> DataLabel
+ Closure -> DataLabel
+ Bitmap -> DataLabel
+ ConInfoTable -> DataLabel
+ StaticInfoTable -> DataLabel
+ ClosureTable -> DataLabel
+ _ -> CodeLabel
+
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need dynamic linkage?
+
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+
+labelDynamic :: CLabel -> Bool
+labelDynamic lbl =
+ case lbl of
+ RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
+ IdLabel n k -> False
+ DynIdLabel n k -> True
+#if mingw32_TARGET_OS
+ ForeignLabel _ _ d -> d
+#else
+ -- On Mac OS X and on ELF platforms, false positives are OK,
+ -- so we claim that all foreign imports come from dynamic libraries
+ ForeignLabel _ _ _ -> True
+#endif
+ ModuleInitLabel m _ dyn -> not opt_Static && dyn
+ PlainModuleInitLabel m dyn -> not opt_Static && dyn
+
+ -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
+ _ -> False
+
+{-
+OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
+right places. It is used to detect when the abstractC statement of an
+CCodeBlock actually contains the code for a slow entry point. -- HWL
+
+We need at least @Eq@ for @CLabels@, because we want to avoid
+duplicate declarations in generating C (see @labelSeenTE@ in
+@PprAbsC@).
+-}
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+ <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+ info Info table
+ srt Static reference table
+ srtd Static reference table descriptor
+ entry Entry code (function, closure)
+ slow Slow entry code (if any)
+ ret Direct return address
+ vtbl Vector table
+ <n>_alt Case alternative (tag n)
+ dflt Default case alternative
+ btm Large bitmap vector
+ closure Static closure
+ con_entry Dynamic Constructor entry code
+ con_info Dynamic Constructor info table
+ static_entry Static Constructor entry code
+ static_info Static Constructor info table
+ sel_info Selector info table
+ sel_entry Selector entry code
+ cc Cost centre
+ ccs Cost centre stack
+
+Many of these distinctions are only for documentation reasons. For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+-}
+
+instance Outputable CLabel where
+ ppr = pprCLabel
+
+pprCLabel :: CLabel -> SDoc
+
+#if ! OMIT_NATIVE_CODEGEN
+pprCLabel (AsmTempLabel u)
+ = getPprStyle $ \ sty ->
+ if asmStyle sty then
+ ptext asmTempLabelPrefix <> pprUnique u
+ else
+ char '_' <> pprUnique u
+
+pprCLabel (DynamicLinkerLabel info lbl)
+ = pprDynamicLinkerAsmLabel info lbl
+
+pprCLabel PicBaseLabel
+ = ptext SLIT("1b")
+
+pprCLabel (DeadStripPreventer lbl)
+ = pprCLabel lbl <> ptext SLIT("_dsp")
+#endif
+
+pprCLabel lbl =
+#if ! OMIT_NATIVE_CODEGEN
+ getPprStyle $ \ sty ->
+ if asmStyle sty then
+ maybe_underscore (pprAsmCLbl lbl)
+ else
+#endif
+ pprCLbl lbl
+
+maybe_underscore doc
+ | underscorePrefix = pp_cSEP <> doc
+ | otherwise = doc
+
+#ifdef mingw32_TARGET_OS
+-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+-- (The C compiler does this itself).
+pprAsmCLbl (ForeignLabel fs (Just sz) _)
+ = ftext fs <> char '@' <> int sz
+#endif
+pprAsmCLbl lbl
+ = pprCLbl lbl
+
+pprCLbl (StringLitLabel u)
+ = pprUnique u <> ptext SLIT("_str")
+
+pprCLbl (CaseLabel u CaseReturnPt)
+ = hcat [pprUnique u, ptext SLIT("_ret")]
+pprCLbl (CaseLabel u CaseReturnInfo)
+ = hcat [pprUnique u, ptext SLIT("_info")]
+pprCLbl (CaseLabel u (CaseAlt tag))
+ = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
+pprCLbl (CaseLabel u CaseDefault)
+ = hcat [pprUnique u, ptext SLIT("_dflt")]
+
+pprCLbl (RtsLabel (RtsCode str)) = ptext str
+pprCLbl (RtsLabel (RtsData str)) = ptext str
+pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
+pprCLbl (RtsLabel (RtsDataFS str)) = ftext str
+
+pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext SLIT("_fast")
+
+pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
+ = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+ = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
+ = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+ = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsInfo fs))
+ = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntry fs))
+ = ptext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfo fs))
+ = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRet fs))
+ = ptext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsInfoFS fs))
+ = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntryFS fs))
+ = ftext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfoFS fs))
+ = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRetFS fs))
+ = ftext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+ = ppr primop <> ptext SLIT("_fast")
+
+pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
+ = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")
+
+pprCLbl ModuleRegdLabel
+ = ptext SLIT("_module_registered")
+
+pprCLbl (ForeignLabel str _ _)
+ = ftext str
+
+pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (DynIdLabel name flavor) = ppr name <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc) = ppr cc
+pprCLbl (CCS_Label ccs) = ppr ccs
+
+pprCLbl (ModuleInitLabel mod way _)
+ = ptext SLIT("__stginit_") <> ppr mod
+ <> char '_' <> text way
+pprCLbl (PlainModuleInitLabel mod _)
+ = ptext SLIT("__stginit_") <> ppr mod
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <>
+ (case x of
+ Closure -> ptext SLIT("closure")
+ SRT -> ptext SLIT("srt")
+ SRTDesc -> ptext SLIT("srtd")
+ InfoTable -> ptext SLIT("info")
+ Entry -> ptext SLIT("entry")
+ Slow -> ptext SLIT("slow")
+ RednCounts -> ptext SLIT("ct")
+ Bitmap -> ptext SLIT("btm")
+ ConEntry -> ptext SLIT("con_entry")
+ ConInfoTable -> ptext SLIT("con_info")
+ StaticConEntry -> ptext SLIT("static_entry")
+ StaticInfoTable -> ptext SLIT("static_info")
+ ClosureTable -> ptext SLIT("closure_tbl")
+ )
+
+
+pp_cSEP = char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+underscorePrefix :: Bool -- leading underscore on assembler labels?
+underscorePrefix = (cLeadingUnderscore == "YES")
+
+asmTempLabelPrefix :: LitString -- for formatting labels
+asmTempLabelPrefix =
+#if alpha_TARGET_OS
+ {- The alpha assembler likes temporary labels to look like $L123
+ instead of L123. (Don't toss the L, because then Lf28
+ turns into $f28.)
+ -}
+ SLIT("$")
+#elif darwin_TARGET_OS
+ SLIT("L")
+#else
+ SLIT(".L")
+#endif
+
+pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc
+
+#if darwin_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = char 'L' <> pprCLabel lbl <> text "$stub"
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text ".LC_" <> pprCLabel lbl
+#elif linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel GotSymbolPtr lbl
+ = pprCLabel lbl <> text "@got"
+pprDynamicLinkerAsmLabel GotSymbolOffset lbl
+ = pprCLabel lbl <> text "@gotoff"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text ".LC_" <> pprCLabel lbl
+#elif mingw32_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text "__imp_" <> pprCLabel lbl
+#endif
+pprDynamicLinkerAsmLabel _ _
+ = panic "pprDynamicLinkerAsmLabel"
View Lorry Controller Status