X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=4e9ef8c5ae95f983dca7cc5993655e1462939933;hp=aacac3e0ddf7c279a02f87bff64977cda530c0b9;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index aacac3e..4e9ef8c 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -1,17 +1,25 @@ +{-# 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, @@ -20,6 +28,7 @@ module CLabel ( mkRednCountsLabel, mkConInfoTableLabel, mkStaticInfoTableLabel, + mkLargeSRTLabel, mkApEntryLabel, mkApInfoTableLabel, mkClosureTableLabel, @@ -44,11 +53,12 @@ module CLabel ( mkModuleInitLabel, mkPlainModuleInitLabel, + mkModuleInitTableLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel, - mkSeqInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_infoLabel, @@ -57,32 +67,30 @@ module CLabel ( 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, @@ -93,34 +101,43 @@ module CLabel ( 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 @@ -142,16 +159,40 @@ CLabel is an abstract type that supports the following operations: -} 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 @@ -164,68 +205,121 @@ data CLabel | 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) - | Bitmap -- A bitmap (function or case return) + _ -> ppr lbl <> (parens $ text "other CLabel)") - | ConEntry -- constructor entry point - | ConInfoTable -- corresponding info table - | StaticConEntry -- static constructor entry point - | StaticInfoTable -- corresponding info table - | ClosureTable -- table of closures for Enum tycons +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 + + | ClosureTable -- ^ Table of closures for Enum tycons deriving (Eq, Ord) @@ -239,268 +333,416 @@ data CaseLabelInfo 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 + +dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) +dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) +dynamicLinkerLabelInfo _ = Nothing + +mkPicBaseLabel :: CLabel +mkPicBaseLabel = PicBaseLabel -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) +-- Constructing miscellaneous other labels +mkDeadStripPreventer :: CLabel -> CLabel +mkDeadStripPreventer lbl = DeadStripPreventer lbl -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) +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel -mkRtsApFastLabel str = RtsLabel (RtsApFast str) +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) -mkRtsSlowTickyCtrLabel :: String -> CLabel -mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) +mkModuleInitLabel :: Module -> String -> CLabel +mkModuleInitLabel mod way = ModuleInitLabel mod way - -- Dynamic linking - -mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel +mkPlainModuleInitLabel :: Module -> CLabel +mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) -dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing +mkModuleInitTableLabel :: Module -> CLabel +mkModuleInitTableLabel mod = ModuleInitTableLabel mod - -- Position independent code - -mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel +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 @@ -508,42 +750,53 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _) = False -- 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 @@ -555,21 +808,41 @@ idInfoLabelType info = -- @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 @@ -638,10 +911,10 @@ pprCLabel (DynamicLinkerLabel info lbl) = 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 = @@ -660,128 +933,138 @@ maybe_underscore 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) _) +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 (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 (RtsCode str)) = ptext str -pprCLbl (RtsLabel (RtsData str)) = ptext str -pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str -pprCLbl (RtsLabel (RtsDataFS str)) = ftext str +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)) = ptext str <> ptext SLIT("_fast") +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 (CmmLabel _ fs CmmInfo) + = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsEntry fs)) - = ptext fs <> ptext SLIT("_entry") +pprCLbl (CmmLabel _ fs CmmEntry) + = ftext fs <> ptext (sLit "_entry") -pprCLbl (RtsLabel (RtsRetInfo fs)) - = ptext fs <> ptext SLIT("_info") +pprCLbl (CmmLabel _ fs CmmRetInfo) + = ftext 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 (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. @@ -795,37 +1078,70 @@ asmTempLabelPrefix = 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" -#elif powerpc_TARGET_ARCH && linux_TARGET_OS +pprDynamicLinkerAsmLabel SymbolPtr lbl + = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" +pprDynamicLinkerAsmLabel _ _ + = panic "pprDynamicLinkerAsmLabel" + +#elif powerpc_TARGET_ARCH && elf_OBJ_FORMAT pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" pprDynamicLinkerAsmLabel SymbolPtr lbl = text ".LC_" <> pprCLabel lbl -#elif linux_TARGET_OS +pprDynamicLinkerAsmLabel _ _ + = panic "pprDynamicLinkerAsmLabel" + +#elif x86_64_TARGET_ARCH && elf_OBJ_FORMAT pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@got" + = pprCLabel lbl <> text "@gotpcrel" pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl <> text "@gotoff" + = pprCLabel lbl pprDynamicLinkerAsmLabel SymbolPtr lbl = text ".LC_" <> pprCLabel lbl + +#elif elf_OBJ_FORMAT +pprDynamicLinkerAsmLabel CodeStub lbl + = pprCLabel lbl <> text "@plt" +pprDynamicLinkerAsmLabel SymbolPtr lbl + = text ".LC_" <> pprCLabel lbl +pprDynamicLinkerAsmLabel GotSymbolPtr lbl + = pprCLabel lbl <> text "@got" +pprDynamicLinkerAsmLabel GotSymbolOffset lbl + = pprCLabel lbl <> text "@gotoff" + #elif mingw32_TARGET_OS pprDynamicLinkerAsmLabel SymbolPtr lbl = text "__imp_" <> pprCLabel lbl -#endif pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + +#else +pprDynamicLinkerAsmLabel _ _ + = panic "pprDynamicLinkerAsmLabel" +#endif