+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Object-file symbols (called CLabel for histerical raisins).
--
--- (c) The University of Glasgow 2004
+-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
module CLabel (
CLabel, -- abstract type
+ ForeignLabelSource(..),
+ pprDebugCLabel,
mkClosureLabel,
mkSRTLabel,
- mkSRTDescLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
mkStaticInfoTableLabel,
+ mkLargeSRTLabel,
mkApEntryLabel,
mkApInfoTableLabel,
mkClosureTableLabel,
mkModuleInitLabel,
mkPlainModuleInitLabel,
+ mkModuleInitTableLabel,
mkSplitMarkerLabel,
mkDirty_MUT_VAR_Label,
mkUpdInfoLabel,
- mkSeqInfoLabel,
+ mkBHUpdInfoLabel,
mkIndStaticInfoLabel,
mkMainCapabilityLabel,
mkMAP_FROZEN_infoLabel,
mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel,
- mkSECAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
mkRtsSlowTickyCtrLabel,
moduleRegdLabel,
+ moduleRegTableLabel,
mkSelectorInfoLabel,
mkSelectorEntryLabel,
- mkRtsInfoLabel,
- mkRtsEntryLabel,
- mkRtsRetInfoLabel,
- mkRtsRetLabel,
- mkRtsCodeLabel,
- mkRtsDataLabel,
-
- mkRtsInfoLabelFS,
- mkRtsEntryLabelFS,
- mkRtsRetInfoLabelFS,
- mkRtsRetLabelFS,
- mkRtsCodeLabelFS,
- mkRtsDataLabelFS,
+ mkCmmInfoLabel,
+ mkCmmEntryLabel,
+ mkCmmRetInfoLabel,
+ mkCmmRetLabel,
+ mkCmmCodeLabel,
+ mkCmmDataLabel,
+ mkCmmGcPtrLabel,
mkRtsApFastLabel,
+ mkPrimCallLabel,
+
mkForeignLabel,
+ addLabelSize,
+ foreignLabelStdcallInfo,
mkCCLabel, mkCCSLabel,
mkPicBaseLabel,
mkDeadStripPreventer,
- infoLblToEntryLbl, entryLblToInfoLbl,
- needsCDecl, isAsmTemp, externallyVisibleCLabel,
- CLabelType(..), labelType, labelDynamic,
+ mkHpcTicksLabel,
+ mkHpcModuleNameLabel,
+
+ hasCAF,
+ infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
+ needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
+ isMathFun,
+ isCFunctionLabel, isGcPtrLabel, labelDynamic,
pprCLabel
) where
-
#include "HsVersions.h"
-import StaticFlags ( opt_Static, opt_DoTickyProfiling )
-import Packages ( isDllName )
-import DataCon ( ConTag )
-import PackageConfig ( PackageId )
-import Module ( Module, modulePackageId )
-import Name ( Name, isExternalName )
-import Unique ( pprUnique, Unique )
-import PrimOp ( PrimOp )
-import Config ( cLeadingUnderscore )
-import CostCentre ( CostCentre, CostCentreStack )
+import IdInfo
+import StaticFlags
+import BasicTypes
+import Literal
+import Packages
+import DataCon
+import PackageConfig
+import Module
+import Name
+import Unique
+import PrimOp
+import Config
+import CostCentre
import Outputable
import FastString
+import DynFlags
+import UniqSet
-- -----------------------------------------------------------------------------
-- The CLabel type
{-
-CLabel is an abstract type that supports the following operations:
+ | CLabel is an abstract type that supports the following operations:
- Pretty printing
-}
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.
+ = -- | A label related to the definition of a particular Id or Con in a .hs file.
+ IdLabel
+ Name
+ CafInfo
+ IdLabelInfo -- encodes the suffix of the label
+
+ -- | A label from a .cmm file that is not associated with a .hs level Id.
+ | CmmLabel
+ PackageId -- what package the label belongs to.
+ FastString -- identifier giving the prefix of the label
+ CmmLabelInfo -- encodes the suffix of the label
+
+ -- | A label with a baked-in \/ algorithmically generated name that definitely
+ -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
+ -- If it doesn't have an algorithmically generated name then use a CmmLabel
+ -- instead and give it an appropriate PackageId argument.
+ | RtsLabel
+ RtsLabelInfo
+
+ -- | A 'C' (or otherwise foreign) label.
+ --
+ | ForeignLabel
+ FastString -- name of the imported 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.
+
+ ForeignLabelSource -- what package the foreign label is in.
+
+ FunctionOrData
+
+ -- | A family of labels related to a particular case expression.
+ | CaseLabel
{-# UNPACK #-} !Unique -- Unique says which case expression
CaseLabelInfo
| 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
+ | PlainModuleInitLabel -- without the version & way info
Module
- Bool -- True <=> is in a different package
- | ModuleRegdLabel
-
- | RtsLabel RtsLabelInfo
+ | ModuleInitTableLabel -- table of imported modules to init
+ Module
- | 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
+ | ModuleRegdLabel
| CC_Label CostCentre
| CCS_Label CostCentreStack
- -- Dynamic Linking in the NCG:
- -- generated and used inside the NCG only,
- -- see module PositionIndependentCode for details.
-
+
+ -- | These labels are generated and used inside the NCG only.
+ -- They are special variants of a label used for dynamic linking
+ -- see module PositionIndependentCode for details.
| DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
- -- special variants of a label used for dynamic linking
+
+ -- | This label is generated and used inside the NCG only.
+ -- It is used as a base for PIC calculations on some platforms.
+ -- It takes the form of a local numeric assembler label '1'; and
+ -- is pretty-printed as 1b, referring to the previous definition
+ -- of 1: in the assembler source file.
+ | PicBaseLabel
+
+ -- | A label before an info table to prevent excessive dead-stripping on darwin
+ | DeadStripPreventer CLabel
- | 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
+ -- | Per-module table of tick locations
+ | HpcTicksLabel Module
+
+ -- | Per-module name of the module for Hpc
+ | HpcModuleNameLabel
+
+ -- | Label of an StgLargeSRT
+ | LargeSRTLabel
+ {-# UNPACK #-} !Unique
+
+ -- | A bitmap (function or case return)
+ | LargeBitmapLabel
+ {-# UNPACK #-} !Unique
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
+-- | Record where a foreign label is stored.
+data ForeignLabelSource
+
+ -- | Label is in a named package
+ = ForeignLabelInPackage PackageId
+
+ -- | Label is in some external, system package that doesn't also
+ -- contain compiled Haskell code, and is not associated with any .hi files.
+ -- We don't have to worry about Haskell code being inlined from
+ -- external packages. It is safe to treat the RTS package as "external".
+ | ForeignLabelInExternalPackage
+
+ -- | Label is in the package currenly being compiled.
+ -- This is only used for creating hacky tmp labels during code generation.
+ -- Don't use it in any code that might be inlined across a package boundary
+ -- (ie, core code) else the information will be wrong relative to the
+ -- destination module.
+ | ForeignLabelInThisPackage
+
+ deriving (Eq, Ord)
+
+closureSuffix' :: Name -> SDoc
+closureSuffix' hs_fn =
+ if depth==0 then ptext (sLit "") else ptext (sLit $ (show depth))
+ where depth = getNameDepth hs_fn
+
+-- | For debugging problems with the CLabel representation.
+-- We can't make a Show instance for CLabel because lots of its components don't have instances.
+-- The regular Outputable instance only shows the label name, and not its other info.
+--
+pprDebugCLabel :: CLabel -> SDoc
+pprDebugCLabel lbl
+ = case lbl of
+ IdLabel{} -> ppr lbl <> (parens $ text "IdLabel")
+ CmmLabel pkg name _info
+ -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+
+ RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel")
+
+ ForeignLabel name mSuffix src funOrData
+ -> ppr lbl <> (parens
+ $ text "ForeignLabel"
+ <+> ppr mSuffix
+ <+> ppr src
+ <+> ppr funOrData)
+
+ _ -> ppr lbl <> (parens $ text "other CLabel)")
+
- | Bitmap -- A bitmap (function or case return)
+data IdLabelInfo
+ = Closure -- ^ Label for closure
+ | SRT -- ^ Static reference table
+ | 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
- | ConEntry -- constructor entry point
- | ConInfoTable -- corresponding info table
- | StaticConEntry -- static constructor entry point
- | StaticInfoTable -- corresponding info table
+ | ConEntry -- ^ Constructor entry point
+ | ConInfoTable -- ^ Corresponding info table
+ | StaticConEntry -- ^ Static constructor entry point
+ | StaticInfoTable -- ^ Corresponding info table
- | ClosureTable -- table of closures for Enum tycons
+ | ClosureTable -- ^ Table of closures for Enum tycons
deriving (Eq, Ord)
data RtsLabelInfo
- = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- Selector thunks
- | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
+ = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks
+ | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
- | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- AP thunks
- | RtsApEntry Bool{-updatable-} Int{-arity-}
+ | 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
-
+ | RtsApFast FastString -- ^ _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.
+ -- NOTE: Eq on LitString compares the pointer only, so this isn't
+ -- a real equality.
+
+
+-- | What type of Cmm label we're dealing with.
+-- Determines the suffix appended to the name when a CLabel.CmmLabel
+-- is pretty printed.
+data CmmLabelInfo
+ = CmmInfo -- ^ misc rts info tabless, suffix _info
+ | CmmEntry -- ^ misc rts entry points, suffix _entry
+ | CmmRetInfo -- ^ misc rts ret info tables, suffix _info
+ | CmmRet -- ^ misc rts return points, suffix _ret
+ | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure
+ | CmmCode -- ^ misc rts code
+ | CmmGcPtr -- ^ GcPtrs eg CHARLIKE_closure
+ | CmmPrimCall -- ^ a prim call to some hand written Cmm code
+ deriving (Eq, Ord)
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
+ = 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
+-- -----------------------------------------------------------------------------
+-- Constructing IdLabels
-- 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
+mkSRTLabel name c = IdLabel name c SRT
+mkSlowEntryLabel name c = IdLabel name c Slow
+mkRednCountsLabel name c = IdLabel name c 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
+mkLocalClosureLabel name c = IdLabel name c Closure
+mkLocalInfoTableLabel name c = IdLabel name c InfoTable
+mkLocalEntryLabel name c = IdLabel name c Entry
+mkLocalClosureTableLabel name c = IdLabel name c ClosureTable
+
+mkClosureLabel name c = IdLabel name c Closure
+mkInfoTableLabel name c = IdLabel name c InfoTable
+mkEntryLabel name c = IdLabel name c Entry
+mkClosureTableLabel name c = IdLabel name c ClosureTable
+mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
+mkLocalConEntryLabel c con = IdLabel con c ConEntry
+mkLocalStaticInfoTableLabel c con = IdLabel con c StaticInfoTable
+mkLocalStaticConEntryLabel c con = IdLabel con c StaticConEntry
+mkConInfoTableLabel name c = IdLabel name c ConInfoTable
+mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable
+
+mkConEntryLabel name c = IdLabel name c ConEntry
+mkStaticConEntryLabel name c = IdLabel name c StaticConEntry
+
+-- Constructing Cmm Labels
+mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
+mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode
+mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
+mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+
+-----
+mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
+ mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel
+ :: PackageId -> FastString -> CLabel
+
+mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
+mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
+mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo
+mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet
+mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode
+mkCmmDataLabel pkg str = CmmLabel pkg str CmmData
+mkCmmGcPtrLabel pkg str = CmmLabel pkg str CmmGcPtr
+
+
+-- Constructing RtsLabels
+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
+
+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)
+
+
+-- A call to some primitive hand written Cmm code
+mkPrimCallLabel :: PrimCall -> CLabel
+mkPrimCallLabel (PrimCall str pkg)
+ = CmmLabel pkg str CmmPrimCall
-mkClosureLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name Closure
- | otherwise = IdLabel name Closure
-mkInfoTableLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name InfoTable
- | otherwise = IdLabel name InfoTable
+-- Constructing ForeignLabels
-mkEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name Entry
- | otherwise = IdLabel name Entry
+-- | Make a foreign label
+mkForeignLabel
+ :: FastString -- name
+ -> Maybe Int -- size prefix
+ -> ForeignLabelSource -- what package it's in
+ -> FunctionOrData
+ -> CLabel
-mkClosureTableLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name ClosureTable
- | otherwise = IdLabel name ClosureTable
+mkForeignLabel str mb_sz src fod
+ = ForeignLabel str mb_sz src fod
-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
+-- | Update the label size field in a ForeignLabel
+addLabelSize :: CLabel -> Int -> CLabel
+addLabelSize (ForeignLabel str _ src fod) sz
+ = ForeignLabel str (Just sz) src fod
+addLabelSize label _
+ = label
-mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable
-mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable
+-- | Get the label size field from a ForeignLabel
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
+foreignLabelStdcallInfo _lbl = Nothing
-mkConEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name ConEntry
- | otherwise = IdLabel name ConEntry
-mkStaticConEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name StaticConEntry
- | otherwise = IdLabel name StaticConEntry
+-- Constructing Large*Labels
+mkLargeSRTLabel uniq = LargeSRTLabel uniq
+mkBitmapLabel uniq = LargeBitmapLabel uniq
+-- Constructin CaseLabels
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 :: PackageId -> Module -> String -> CLabel
-mkModuleInitLabel this_pkg mod way
- = ModuleInitLabel mod way $! modulePackageId mod /= this_pkg
-
-mkPlainModuleInitLabel :: PackageId -> Module -> CLabel
-mkPlainModuleInitLabel this_pkg mod
- = PlainModuleInitLabel mod $! modulePackageId mod /= this_pkg
-
- -- 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)
+-- Constructing Cost Center Labels
+mkCCLabel cc = CC_Label cc
+mkCCSLabel ccs = CCS_Label ccs
-moduleRegdLabel = ModuleRegdLabel
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
-mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off)
-mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
+mkRtsSlowTickyCtrLabel :: String -> CLabel
+mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
-mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off)
-mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
- -- Foreign labels
+-- Constructing Code Coverage Labels
+mkHpcTicksLabel = HpcTicksLabel
+mkHpcModuleNameLabel = HpcModuleNameLabel
-mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
-mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic
- -- Cost centres etc.
+-- Constructing labels used for dynamic linking
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel = DynamicLinkerLabel
-mkCCLabel cc = CC_Label cc
-mkCCSLabel ccs = CCS_Label ccs
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _ = Nothing
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel = PicBaseLabel
-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)
+-- Constructing miscellaneous other labels
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl = DeadStripPreventer lbl
-mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+mkStringLitLabel :: Unique -> CLabel
+mkStringLitLabel = StringLitLabel
-mkRtsSlowTickyCtrLabel :: String -> CLabel
-mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+mkAsmTempLabel :: Uniquable a => a -> CLabel
+mkAsmTempLabel a = AsmTempLabel (getUnique a)
- -- Dynamic linking
-
-mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
-mkDynamicLinkerLabel = DynamicLinkerLabel
+mkModuleInitLabel :: Module -> String -> CLabel
+mkModuleInitLabel mod way = ModuleInitLabel mod way
-dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
-dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
-dynamicLinkerLabelInfo _ = Nothing
+mkPlainModuleInitLabel :: Module -> CLabel
+mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
- -- Position independent code
-
-mkPicBaseLabel :: CLabel
-mkPicBaseLabel = PicBaseLabel
+mkModuleInitTableLabel :: Module -> CLabel
+mkModuleInitTableLabel mod = ModuleInitTableLabel mod
+
+moduleRegdLabel = ModuleRegdLabel
+moduleRegTableLabel = ModuleInitTableLabel
-mkDeadStripPreventer :: CLabel -> CLabel
-mkDeadStripPreventer lbl = DeadStripPreventer lbl
-- -----------------------------------------------------------------------------
--- Converting info labels to entry labels.
+-- Converting between info labels and entry/ret 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"
+infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
+infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
+infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
+infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet
+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)
+entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
+entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
+entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
+entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo
+entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo
+entryLblToInfoLbl l
+ = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
+
+
+cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure
+cvtToClosureLbl l@(IdLabel n c Closure) = l
+cvtToClosureLbl l
+ = pprPanic "cvtToClosureLbl" (pprCLabel l)
+
+
+cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c
+cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c
+cvtToSRTLbl l
+ = pprPanic "cvtToSRTLbl" (pprCLabel l)
+
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel refer to a CAF?
+hasCAF :: CLabel -> Bool
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _ = False
+
-- -----------------------------------------------------------------------------
-- Does a CLabel need declaring before use or not?
+--
+-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
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 (IdLabel _ _ SRT) = False
+needsCDecl (LargeSRTLabel _) = False
+needsCDecl (LargeBitmapLabel _) = False
+needsCDecl (IdLabel _ _ _) = True
needsCDecl (CaseLabel _ _) = True
-needsCDecl (ModuleInitLabel _ _ _) = True
-needsCDecl (PlainModuleInitLabel _ _) = True
+needsCDecl (ModuleInitLabel _ _) = True
+needsCDecl (PlainModuleInitLabel _) = True
+needsCDecl (ModuleInitTableLabel _) = 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:
+needsCDecl (CmmLabel pkgId _ _)
+ -- Prototypes for labels defined in the runtime system are imported
+ -- into HC files via includes/Stg.h.
+ | pkgId == rtsPackageId = False
+
+ -- For other labels we inline one into the HC file directly.
+ | otherwise = True
-isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
-isAsmTemp (AsmTempLabel _) = True
-isAsmTemp _ = False
+needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
+needsCDecl (CC_Label _) = True
+needsCDecl (CCS_Label _) = True
+needsCDecl (HpcTicksLabel _) = True
+needsCDecl HpcModuleNameLabel = False
+
+
+-- | Check whether a label is a local temporary for native code generation
+isAsmTemp :: CLabel -> Bool
+isAsmTemp (AsmTempLabel _) = True
+isAsmTemp _ = False
+
+
+-- | If a label is a local temporary used for native code generation
+-- then return just its unique, otherwise nothing.
+maybeAsmTemp :: CLabel -> Maybe Unique
+maybeAsmTemp (AsmTempLabel uq) = Just uq
+maybeAsmTemp _ = Nothing
+
+
+-- | Check whether a label corresponds to a C function that has
+-- a prototype in a system header somehere, or is built-in
+-- to the C compiler. For these labels we abovoid generating our
+-- own C prototypes.
+isMathFun :: CLabel -> Bool
+isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs
+isMathFun _ = False
+
+math_funs = mkUniqSet [
+ -- _ISOC99_SOURCE
+ (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"),
+ (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"),
+ (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"),
+ (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"),
+ (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"),
+ (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"),
+ (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"),
+ (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"),
+ (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"),
+ (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"),
+ (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"),
+ (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"),
+ (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"),
+ (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"),
+ (fsLit "exp"), (fsLit "expf"), (fsLit "expl"),
+ (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"),
+ (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"),
+ (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"),
+ (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"),
+ (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"),
+ (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"),
+ (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"),
+ (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"),
+ (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"),
+ (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"),
+ (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"),
+ (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"),
+ (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"),
+ (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"),
+ (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"),
+ (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"),
+ (fsLit "log"), (fsLit "logf"), (fsLit "logl"),
+ (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"),
+ (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"),
+ (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"),
+ (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"),
+ (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"),
+ (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"),
+ (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"),
+ (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"),
+ (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"),
+ (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"),
+ (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"),
+ (fsLit "pow"), (fsLit "powf"), (fsLit "powl"),
+ (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"),
+ (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"),
+ (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"),
+ (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"),
+ (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"),
+ (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"),
+ (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"),
+ (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"),
+ (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"),
+ (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"),
+ (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"),
+ (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"),
+ (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"),
+ -- ISO C 99 also defines these function-like macros in math.h:
+ -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,
+ -- isgreaterequal, isless, islessequal, islessgreater, isunordered
+
+ -- additional symbols from _BSD_SOURCE
+ (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"),
+ (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"),
+ (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"),
+ (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"),
+ (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"),
+ (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"),
+ (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"),
+ (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"),
+ (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"),
+ (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"),
+ (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"),
+ (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"),
+ (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"),
+ (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl")
+ ]
-- -----------------------------------------------------------------------------
--- 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.
-
+-- | 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 (CaseLabel _ _) = False
+externallyVisibleCLabel (StringLitLabel _) = False
+externallyVisibleCLabel (AsmTempLabel _) = False
+externallyVisibleCLabel (ModuleInitLabel _ _) = True
+externallyVisibleCLabel (PlainModuleInitLabel _)= True
+externallyVisibleCLabel (ModuleInitTableLabel _)= False
+externallyVisibleCLabel ModuleRegdLabel = False
+externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (CmmLabel _ _ _) = True
+externallyVisibleCLabel (ForeignLabel{}) = True
+externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
+externallyVisibleCLabel (CC_Label _) = True
+externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
+externallyVisibleCLabel (HpcTicksLabel _) = True
+externallyVisibleCLabel HpcModuleNameLabel = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
-- For generating correct types in label declarations:
data CLabelType
- = CodeLabel
- | DataLabel
+ = CodeLabel -- Address of some executable instructions
+ | DataLabel -- Address of data, not a GC ptr
+ | GcPtrLabel -- Address of a (presumably static) GC object
+isCFunctionLabel :: CLabel -> Bool
+isCFunctionLabel lbl = case labelType lbl of
+ CodeLabel -> True
+ _other -> False
+
+isGcPtrLabel :: CLabel -> Bool
+isGcPtrLabel lbl = case labelType lbl of
+ GcPtrLabel -> True
+ _other -> False
+
+
+-- | Work out the general type of data at the address of this label
+-- whether it be code, data, or static GC object.
labelType :: CLabel -> CLabelType
+labelType (CmmLabel _ _ CmmData) = DataLabel
+labelType (CmmLabel _ _ CmmGcPtr) = GcPtrLabel
+labelType (CmmLabel _ _ CmmCode) = CodeLabel
+labelType (CmmLabel _ _ CmmInfo) = DataLabel
+labelType (CmmLabel _ _ CmmEntry) = CodeLabel
+labelType (CmmLabel _ _ CmmRetInfo) = DataLabel
+labelType (CmmLabel _ _ CmmRet) = CodeLabel
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
+labelType (RtsLabel (RtsApFast _)) = CodeLabel
+labelType (CaseLabel _ CaseReturnInfo) = DataLabel
+labelType (CaseLabel _ _) = CodeLabel
+labelType (ModuleInitLabel _ _) = CodeLabel
+labelType (PlainModuleInitLabel _) = CodeLabel
+labelType (ModuleInitTableLabel _) = DataLabel
+labelType (LargeSRTLabel _) = DataLabel
+labelType (LargeBitmapLabel _) = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
+labelType (IdLabel _ _ info) = idInfoLabelType info
+labelType _ = DataLabel
idInfoLabelType info =
case info of
InfoTable -> DataLabel
- Closure -> DataLabel
- Bitmap -> DataLabel
+ Closure -> GcPtrLabel
ConInfoTable -> DataLabel
StaticInfoTable -> DataLabel
ClosureTable -> DataLabel
+ RednCounts -> DataLabel
_ -> CodeLabel
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: CLabel -> Bool
-labelDynamic lbl =
+labelDynamic :: PackageId -> CLabel -> Bool
+labelDynamic this_pkg 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
+ -- is the RTS in a DLL or not?
+ RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId)
+
+ IdLabel n _ k -> isDllName this_pkg n
+
#if mingw32_TARGET_OS
- ForeignLabel _ _ d -> d
+ -- When compiling in the "dyn" way, eack package is to be linked into its own shared library.
+ CmmLabel pkg _ _
+ -> not opt_Static && (this_pkg /= pkg)
+
+ -- Foreign label is in some un-named foreign package (or DLL)
+ ForeignLabel _ _ ForeignLabelInExternalPackage _ -> True
+
+ -- Foreign label is linked into the same package as the source file currently being compiled.
+ ForeignLabel _ _ ForeignLabelInThisPackage _ -> False
+
+ -- Foreign label is in some named package.
+ -- When compiling in the "dyn" way, each package is to be linked into its own DLL.
+ ForeignLabel _ _ (ForeignLabelInPackage pkgId) _
+ -> (not opt_Static) && (this_pkg /= pkgId)
+
#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
+ ForeignLabel _ _ _ _ -> True
+
+ CmmLabel pkg _ _ -> True
+
#endif
- ModuleInitLabel m _ dyn -> not opt_Static && dyn
- PlainModuleInitLabel m dyn -> not opt_Static && dyn
+ ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
+ PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
+ ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
= pprDynamicLinkerAsmLabel info lbl
pprCLabel PicBaseLabel
- = ptext SLIT("1b")
+ = ptext (sLit "1b")
pprCLabel (DeadStripPreventer lbl)
- = pprCLabel lbl <> ptext SLIT("_dsp")
+ = pprCLabel lbl <> ptext (sLit "_dsp")
#endif
pprCLabel lbl =
#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) _)
+pprAsmCLbl (ForeignLabel fs (Just sz) _ _)
= ftext fs <> char '@' <> int sz
#endif
pprAsmCLbl lbl
= pprCLbl lbl
pprCLbl (StringLitLabel u)
- = pprUnique u <> ptext SLIT("_str")
+ = pprUnique u <> ptext (sLit "_str")
pprCLbl (CaseLabel u CaseReturnPt)
- = hcat [pprUnique u, ptext SLIT("_ret")]
+ = hcat [pprUnique u, ptext (sLit "_ret")]
pprCLbl (CaseLabel u CaseReturnInfo)
- = hcat [pprUnique u, ptext SLIT("_info")]
+ = hcat [pprUnique u, ptext (sLit "_info")]
pprCLbl (CaseLabel u (CaseAlt tag))
- = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
+ = hcat [pprUnique u, pp_cSEP, int tag, ptext (sLit "_alt")]
pprCLbl (CaseLabel u CaseDefault)
- = hcat [pprUnique u, ptext SLIT("_dflt")]
+ = 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 (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
+pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assmbly code.
+
-pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext SLIT("_fast")
+pprCLbl (CmmLabel _ str CmmCode) = ftext str
+pprCLbl (CmmLabel _ str CmmData) = ftext str
+pprCLbl (CmmLabel _ str CmmGcPtr) = ftext str
+pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str
+
+pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast")
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
- = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ = hcat [ptext (sLit "stg_sel_"), text (show offset),
ptext (if upd_reqd
- then SLIT("_upd_info")
- else SLIT("_noupd_info"))
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
]
pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ = hcat [ptext (sLit "stg_sel_"), text (show offset),
ptext (if upd_reqd
- then SLIT("_upd_entry")
- else SLIT("_noupd_entry"))
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
]
pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
- = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ = hcat [ptext (sLit "stg_ap_"), text (show arity),
ptext (if upd_reqd
- then SLIT("_upd_info")
- else SLIT("_noupd_info"))
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
]
pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
- = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ = hcat [ptext (sLit "stg_ap_"), text (show arity),
ptext (if upd_reqd
- then SLIT("_upd_entry")
- else SLIT("_noupd_entry"))
+ 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 (CmmLabel _ fs CmmInfo)
+ = ftext fs <> ptext (sLit "_info")
-pprCLbl (RtsLabel (RtsInfoFS fs))
- = ftext fs <> ptext SLIT("_info")
+pprCLbl (CmmLabel _ fs CmmEntry)
+ = ftext fs <> ptext (sLit "_entry")
-pprCLbl (RtsLabel (RtsEntryFS fs))
- = ftext fs <> ptext SLIT("_entry")
+pprCLbl (CmmLabel _ fs CmmRetInfo)
+ = ftext fs <> ptext (sLit "_info")
-pprCLbl (RtsLabel (RtsRetInfoFS fs))
- = ftext fs <> ptext SLIT("_info")
-
-pprCLbl (RtsLabel (RtsRetFS fs))
- = ftext fs <> ptext SLIT("_ret")
+pprCLbl (CmmLabel _ fs CmmRet)
+ = ftext fs <> ptext (sLit "_ret")
pprCLbl (RtsLabel (RtsPrimOp primop))
- = ppr primop <> ptext SLIT("_fast")
+ = ptext (sLit "stg_") <> ppr primop
pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
- = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")
+ = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
pprCLbl ModuleRegdLabel
- = ptext SLIT("_module_registered")
+ = ptext (sLit "_module_registered")
-pprCLbl (ForeignLabel str _ _)
+pprCLbl (ForeignLabel str _ _ _)
= ftext str
-pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor
-pprCLbl (DynIdLabel name flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor name flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
-pprCLbl (ModuleInitLabel mod way _)
- = ptext SLIT("__stginit_") <> ppr mod
+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 <>
+pprCLbl (PlainModuleInitLabel mod)
+ = ptext (sLit "__stginit_") <> ppr mod
+
+pprCLbl (ModuleInitTableLabel mod)
+ = ptext (sLit "__stginittable_") <> ppr mod
+
+pprCLbl (HpcTicksLabel mod)
+ = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc")
+
+pprCLbl HpcModuleNameLabel
+ = ptext (sLit "_hpc_module_name_str")
+
+ppIdFlavor :: Name -> IdLabelInfo -> SDoc
+ppIdFlavor n x = pp_cSEP <> closureSuffix' n <>
(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")
+ Closure -> ptext (sLit "closure")
+ SRT -> ptext (sLit "srt")
+ InfoTable -> ptext (sLit "info")
+ Entry -> ptext (sLit "entry")
+ Slow -> ptext (sLit "slow")
+ RednCounts -> ptext (sLit "ct")
+ 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 '_'
+
+instance Outputable ForeignLabelSource where
+ ppr fs
+ = case fs of
+ ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId
+ ForeignLabelInThisPackage -> parens $ text "this package"
+ ForeignLabelInExternalPackage -> parens $ text "external package"
+
-- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels.
instead of L123. (Don't toss the L, because then Lf28
turns into $f28.)
-}
- SLIT("$")
+ (sLit "$")
#elif darwin_TARGET_OS
- SLIT("L")
+ (sLit "L")
#else
- SLIT(".L")
+ (sLit ".L")
#endif
pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc
-#if darwin_TARGET_OS
+#if x86_64_TARGET_ARCH && darwin_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = char 'L' <> pprCLabel lbl <> text "$stub"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
+pprDynamicLinkerAsmLabel GotSymbolPtr lbl
+ = pprCLabel lbl <> text "@GOTPCREL"
+pprDynamicLinkerAsmLabel GotSymbolOffset lbl
+ = pprCLabel lbl
+pprDynamicLinkerAsmLabel _ _
+ = panic "pprDynamicLinkerAsmLabel"
+
+#elif darwin_TARGET_OS
pprDynamicLinkerAsmLabel CodeStub lbl
= char 'L' <> pprCLabel lbl <> text "$stub"
pprDynamicLinkerAsmLabel SymbolPtr lbl
= char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
pprDynamicLinkerAsmLabel _ _
= panic "pprDynamicLinkerAsmLabel"
-#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+
+#elif powerpc_TARGET_ARCH && elf_OBJ_FORMAT
pprDynamicLinkerAsmLabel CodeStub lbl
= pprCLabel lbl <> text "@plt"
pprDynamicLinkerAsmLabel SymbolPtr lbl
= text ".LC_" <> pprCLabel lbl
pprDynamicLinkerAsmLabel _ _
= panic "pprDynamicLinkerAsmLabel"
-#elif linux_TARGET_OS
+
+#elif x86_64_TARGET_ARCH && elf_OBJ_FORMAT
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel GotSymbolPtr lbl
+ = pprCLabel lbl <> text "@gotpcrel"
+pprDynamicLinkerAsmLabel GotSymbolOffset lbl
+ = pprCLabel lbl
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text ".LC_" <> pprCLabel lbl
+
+#elif elf_OBJ_FORMAT
pprDynamicLinkerAsmLabel CodeStub lbl
= pprCLabel lbl <> text "@plt"
pprDynamicLinkerAsmLabel SymbolPtr lbl
= pprCLabel lbl <> text "@got"
pprDynamicLinkerAsmLabel GotSymbolOffset lbl
= pprCLabel lbl <> text "@gotoff"
+
#elif mingw32_TARGET_OS
pprDynamicLinkerAsmLabel SymbolPtr lbl
= text "__imp_" <> pprCLabel lbl
pprDynamicLinkerAsmLabel _ _
= panic "pprDynamicLinkerAsmLabel"
+
#else
pprDynamicLinkerAsmLabel _ _
= panic "pprDynamicLinkerAsmLabel"
projects / ghc-hetmet.git / blobdiff