X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=1ba11266d5c9701528e92d67ce0555ccff97a750;hp=d62c8c54a9dc25d80f75424837a69894d0332a09;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=63cd3a632e974b2fde5b934b94260e2c79bcb23e diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index d62c8c5..1ba1126 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -15,6 +15,8 @@ module CLabel ( CLabel, -- abstract type + ForeignLabelSource(..), + pprDebugCLabel, mkClosureLabel, mkSRTLabel, @@ -49,13 +51,12 @@ module CLabel ( mkAsmTempLabel, - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, + mkPlainModuleInitLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_infoLabel, @@ -67,19 +68,16 @@ module CLabel ( mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, - mkRtsInfoLabel, - mkRtsEntryLabel, - mkRtsRetInfoLabel, - mkRtsRetLabel, - mkRtsCodeLabel, - mkRtsDataLabel, - mkRtsGcPtrLabel, + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkCmmGcPtrLabel, mkRtsApFastLabel, @@ -99,7 +97,6 @@ module CLabel ( mkDeadStripPreventer, mkHpcTicksLabel, - mkHpcModuleNameLabel, hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, @@ -160,19 +157,32 @@ data CLabel IdLabel Name CafInfo - IdLabelInfo - - -- | A label with a baked-in name that definitely comes from the RTS. - -- The code for it must compile into libHSrts.a \/ libHSrts.so \/ libHSrts.dll + 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 + -- | 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. - Bool -- True <=> is dynamic + + ForeignLabelSource -- what package the foreign label is in. + FunctionOrData -- | A family of labels related to a particular case expression. @@ -186,23 +196,9 @@ data CLabel | StringLitLabel {-# UNPACK #-} !Unique - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- 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 version & way info + | PlainModuleInitLabel -- without the version & way info Module - | ModuleInitTableLabel -- table of imported modules to init - Module - - | ModuleRegdLabel - | CC_Label CostCentre | CCS_Label CostCentreStack @@ -226,9 +222,6 @@ data CLabel -- | Per-module table of tick locations | HpcTicksLabel Module - -- | Per-module name of the module for Hpc - | HpcModuleNameLabel - -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -239,6 +232,56 @@ data CLabel deriving (Eq, Ord) + +-- | 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)") + + data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table @@ -274,23 +317,28 @@ data RtsLabelInfo | RtsApEntry Bool{-updatable-} Int{-arity-} | RtsPrimOp PrimOp - - | RtsInfo FastString -- ^ misc rts info tables - | RtsEntry FastString -- ^ misc rts entry points - | RtsRetInfo FastString -- ^ misc rts ret info tables - | RtsRet FastString -- ^ misc rts return points - | RtsData FastString -- ^ misc rts data bits, eg CHARLIKE_closure - | RtsCode FastString -- ^ misc rts code - | RtsGcPtr FastString -- ^ GcPtrs eg CHARLIKE_closure - | 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. + +-- | 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 @@ -298,12 +346,15 @@ data DynamicLinkerLabelInfo | GotSymbolOffset -- ELF: foo@gotoff deriving (Eq, Ord) - + + -- ----------------------------------------------------------------------------- -- Constructing CLabels +-- ----------------------------------------------------------------------------- +-- Constructing IdLabels -- These are always local: -mkSRTLabel name c = IdLabel name c SRT +mkSRTLabel name c = IdLabel name c SRT mkSlowEntryLabel name c = IdLabel name c Slow mkRednCountsLabel name c = IdLabel name c RednCounts @@ -327,144 +378,167 @@ mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable mkConEntryLabel name c = IdLabel name c ConEntry mkStaticConEntryLabel name c = IdLabel name c StaticConEntry -mkLargeSRTLabel uniq = LargeSRTLabel uniq -mkBitmapLabel uniq = LargeBitmapLabel uniq - -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 :: Uniquable a => a -> CLabel -mkAsmTempLabel a = AsmTempLabel (getUnique a) - -mkModuleInitLabel :: Module -> String -> CLabel -mkModuleInitLabel mod way = ModuleInitLabel mod way - -mkPlainModuleInitLabel :: Module -> CLabel -mkPlainModuleInitLabel mod = PlainModuleInitLabel mod - -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - - -- Some fixed runtime system labels - -mkSplitMarkerLabel = RtsLabel (RtsCode (fsLit "__stg_split_marker")) -mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (fsLit "dirty_MUT_VAR")) -mkUpdInfoLabel = RtsLabel (RtsInfo (fsLit "stg_upd_frame")) -mkIndStaticInfoLabel = RtsLabel (RtsInfo (fsLit "stg_IND_STATIC")) -mkMainCapabilityLabel = RtsLabel (RtsData (fsLit "MainCapability")) -mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_FROZEN0")) -mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (fsLit "stg_MUT_ARR_PTRS_DIRTY")) -mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (fsLit "stg_EMPTY_MVAR")) - -mkTopTickyCtrLabel = RtsLabel (RtsData (fsLit "top_ct")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (fsLit "stg_CAF_BLACKHOLE")) +-- 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) -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) +mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) +mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) +mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - -- Primitive / cmm call labels +-- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction +mkPrimCallLabel (PrimCall str pkg) + = CmmLabel pkg str CmmPrimCall - -- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz is_dynamic fod - = ForeignLabel str mb_sz is_dynamic fod +-- Constructing ForeignLabels +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> Maybe Int -- size prefix + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel + +mkForeignLabel str mb_sz src fod + = ForeignLabel str mb_sz src fod + + +-- | Update the label size field in a ForeignLabel addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ is_dynamic fod) sz - = ForeignLabel str (Just sz) is_dynamic fod +addLabelSize (ForeignLabel str _ src fod) sz + = ForeignLabel str (Just sz) src fod addLabelSize label _ - = label + = label +-- | Get the label size field from a ForeignLabel foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing - -- Cost centres etc. -mkCCLabel cc = CC_Label cc -mkCCSLabel ccs = CCS_Label ccs +-- 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 -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) -mkRtsGcPtrLabel str = RtsLabel (RtsGcPtr str) +-- Constructing Cost Center Labels +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs mkRtsApFastLabel str = RtsLabel (RtsApFast str) mkRtsSlowTickyCtrLabel :: String -> CLabel mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) - -- Coverage +-- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel - -- Dynamic linking - + +-- Constructing labels used for dynamic linking mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel +mkDynamicLinkerLabel = DynamicLinkerLabel dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing - - -- Position independent code - +dynamicLinkerLabelInfo _ = Nothing + mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel +mkPicBaseLabel = PicBaseLabel + +-- Constructing miscellaneous other labels mkDeadStripPreventer :: CLabel -> CLabel -mkDeadStripPreventer lbl = DeadStripPreventer lbl +mkDeadStripPreventer lbl = DeadStripPreventer lbl + +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel + +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) + +mkPlainModuleInitLabel :: Module -> CLabel +mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. infoLblToEntryLbl :: CLabel -> CLabel -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 (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) -infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet 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 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 (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) -entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) -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) +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 (IdLabel n c RednCounts) = 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? @@ -472,6 +546,7 @@ hasCAF :: CLabel -> Bool hasCAF (IdLabel _ MayHaveCafRefs _) = True hasCAF _ = False + -- ----------------------------------------------------------------------------- -- Does a CLabel need declaring before use or not? -- @@ -486,35 +561,45 @@ needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False +needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) + +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 + +needsCDecl l@(ForeignLabel{}) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False --- Whether the label is an assembler temporary: -isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation -isAsmTemp (AsmTempLabel _) = True -isAsmTemp _ = 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 +maybeAsmTemp (AsmTempLabel uq) = Just uq +maybeAsmTemp _ = Nothing --- some labels have C prototypes in scope when compiling via C, because --- they are builtin to the C compiler. For these labels we avoid --- generating our own C prototypes. + +-- | 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 avoid generating our +-- own C prototypes. isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs +isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs isMathFun _ = False math_funs = mkUniqSet [ @@ -598,30 +683,25 @@ math_funs = mkUniqSet [ ] -- ----------------------------------------------------------------------------- --- 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 (CaseLabel _ _) = False +externallyVisibleCLabel (StringLitLabel _) = False +externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (ForeignLabel _ _ _ _) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name -externallyVisibleCLabel (CC_Label _) = True -externallyVisibleCLabel (CCS_Label _) = True +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 +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -643,25 +723,26 @@ 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 (RtsGcPtr _)) = GcPtrLabel -labelType (RtsLabel (RtsCode _)) = CodeLabel -labelType (RtsLabel (RtsInfo _)) = DataLabel -labelType (RtsLabel (RtsEntry _)) = CodeLabel -labelType (RtsLabel (RtsRetInfo _)) = DataLabel -labelType (RtsLabel (RtsRet _)) = CodeLabel 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 (ForeignLabel _ _ _ IsFunction) = CodeLabel labelType (IdLabel _ _ info) = idInfoLabelType info labelType _ = DataLabel @@ -687,19 +768,37 @@ idInfoLabelType info = labelDynamic :: PackageId -> CLabel -> Bool labelDynamic this_pkg lbl = case lbl of - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? - IdLabel n _ k -> isDllName this_pkg n + -- 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 + + CmmLabel pkg _ _ -> True + #endif - 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 @@ -755,8 +854,8 @@ instance Outputable CLabel where pprCLabel :: CLabel -> SDoc -#if ! OMIT_NATIVE_CODEGEN pprCLabel (AsmTempLabel u) + | cGhcWithNativeCodeGen == "YES" = getPprStyle $ \ sty -> if asmStyle sty then ptext asmTempLabelPrefix <> pprUnique u @@ -764,23 +863,22 @@ pprCLabel (AsmTempLabel u) char '_' <> pprUnique u pprCLabel (DynamicLinkerLabel info lbl) + | cGhcWithNativeCodeGen == "YES" = pprDynamicLinkerAsmLabel info lbl pprCLabel PicBaseLabel + | cGhcWithNativeCodeGen == "YES" = ptext (sLit "1b") pprCLabel (DeadStripPreventer lbl) + | cGhcWithNativeCodeGen == "YES" = pprCLabel lbl <> ptext (sLit "_dsp") -#endif -pprCLabel lbl = -#if ! OMIT_NATIVE_CODEGEN - getPprStyle $ \ sty -> - if asmStyle sty then - maybe_underscore (pprAsmCLbl lbl) - else -#endif - pprCLbl lbl +pprCLabel lbl + = getPprStyle $ \ sty -> + if cGhcWithNativeCodeGen == "YES" && asmStyle sty + then maybe_underscore (pprAsmCLbl lbl) + else pprCLbl lbl maybe_underscore doc | underscorePrefix = pp_cSEP <> doc @@ -814,9 +912,10 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi -- with a letter so the label will be legal assmbly code. -pprCLbl (RtsLabel (RtsCode str)) = ftext str -pprCLbl (RtsLabel (RtsData str)) = ftext str -pprCLbl (RtsLabel (RtsGcPtr 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)) = ftext str <> ptext (sLit "_fast") @@ -848,16 +947,16 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) else (sLit "_noupd_entry")) ] -pprCLbl (RtsLabel (RtsInfo fs)) +pprCLbl (CmmLabel _ fs CmmInfo) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsEntry fs)) +pprCLbl (CmmLabel _ fs CmmEntry) = ftext fs <> ptext (sLit "_entry") -pprCLbl (RtsLabel (RtsRetInfo fs)) +pprCLbl (CmmLabel _ fs CmmRetInfo) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsRet fs)) +pprCLbl (CmmLabel _ fs CmmRet) = ftext fs <> ptext (sLit "_ret") pprCLbl (RtsLabel (RtsPrimOp primop)) @@ -866,33 +965,22 @@ pprCLbl (RtsLabel (RtsPrimOp primop)) pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") -pprCLbl ModuleRegdLabel - = ptext (sLit "_module_registered") - pprCLbl (ForeignLabel str _ _ _) = ftext str -pprCLbl (IdLabel name cafs 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 - <> char '_' <> text way 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 :: IdLabelInfo -> SDoc -ppIdFlavor x = pp_cSEP <> +ppIdFlavor :: Name -> IdLabelInfo -> SDoc +ppIdFlavor n x = pp_cSEP <> closureSuffix' n <> (case x of Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") @@ -910,6 +998,14 @@ ppIdFlavor x = pp_cSEP <> 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. @@ -943,6 +1039,7 @@ pprDynamicLinkerAsmLabel GotSymbolOffset lbl = pprCLabel lbl pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #elif darwin_TARGET_OS pprDynamicLinkerAsmLabel CodeStub lbl = char 'L' <> pprCLabel lbl <> text "$stub" @@ -950,14 +1047,16 @@ 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 x86_64_TARGET_ARCH && linux_TARGET_OS + +#elif x86_64_TARGET_ARCH && elf_OBJ_FORMAT pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" pprDynamicLinkerAsmLabel GotSymbolPtr lbl @@ -966,7 +1065,8 @@ pprDynamicLinkerAsmLabel GotSymbolOffset lbl = pprCLabel lbl pprDynamicLinkerAsmLabel SymbolPtr lbl = text ".LC_" <> pprCLabel lbl -#elif linux_TARGET_OS + +#elif elf_OBJ_FORMAT pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" pprDynamicLinkerAsmLabel SymbolPtr lbl @@ -975,11 +1075,13 @@ 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 pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #else pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel"