X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FCLabel.hs;h=aa72b65243e8d241e4c8c5313d289441125f5f59;hb=e6243a818496aad82b6f47511d3bd9bc800f747d;hp=3c061291206b6b5f1bc09a17d264dbc7fde8423a;hpb=7febf770225048f47f661fb864b687ade189a8a0;p=ghc-hetmet.git diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 3c06129..aa72b65 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -51,6 +51,7 @@ module CLabel ( mkModuleInitLabel, mkPlainModuleInitLabel, + mkModuleInitTableLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, @@ -63,11 +64,11 @@ module CLabel ( mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, - mkSECAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, moduleRegdLabel, + moduleRegTableLabel, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -78,6 +79,7 @@ module CLabel ( mkRtsRetLabel, mkRtsCodeLabel, mkRtsDataLabel, + mkRtsGcPtrLabel, mkRtsInfoLabelFS, mkRtsEntryLabelFS, @@ -90,6 +92,7 @@ module CLabel ( mkForeignLabel, addLabelSize, + foreignLabelStdcallInfo, mkCCLabel, mkCCSLabel, @@ -103,14 +106,18 @@ module CLabel ( mkHpcTicksLabel, mkHpcModuleNameLabel, - infoLblToEntryLbl, entryLblToInfoLbl, + hasCAF, + infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, - CLabelType(..), labelType, labelDynamic, + isCFunctionLabel, isGcPtrLabel, labelDynamic, pprCLabel ) where +#include "HsVersions.h" + +import IdInfo import StaticFlags import Packages import DataCon @@ -153,6 +160,7 @@ 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 + CafInfo IdLabelInfo | CaseLabel -- A family of labels related to a particular @@ -175,7 +183,10 @@ data CLabel -- 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 + + | ModuleInitTableLabel -- table of imported modules to init Module | ModuleRegdLabel @@ -260,7 +271,8 @@ data RtsLabelInfo | 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 + | RtsData LitString -- misc rts data bits + | RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure | RtsCode LitString -- misc rts code | RtsInfoFS FastString -- misc rts info tables @@ -290,29 +302,29 @@ data DynamicLinkerLabelInfo -- Constructing CLabels -- These are always local: -mkSRTLabel name = IdLabel name SRT -mkSlowEntryLabel name = IdLabel name Slow -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 - -mkClosureLabel name = IdLabel name Closure -mkInfoTableLabel name = IdLabel name InfoTable -mkEntryLabel name = IdLabel name Entry -mkClosureTableLabel name = IdLabel name ClosureTable -mkLocalConInfoTableLabel con = IdLabel con ConInfoTable -mkLocalConEntryLabel con = IdLabel con ConEntry -mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable -mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry -mkConInfoTableLabel name = IdLabel name ConInfoTable -mkStaticInfoTableLabel name = IdLabel name StaticInfoTable - -mkConEntryLabel name = IdLabel name ConEntry -mkStaticConEntryLabel name = IdLabel name StaticConEntry +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 mkLargeSRTLabel uniq = LargeSRTLabel uniq mkBitmapLabel uniq = LargeBitmapLabel uniq @@ -332,6 +344,9 @@ 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 (sLit "__stg_split_marker")) @@ -345,13 +360,10 @@ mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR")) mkTopTickyCtrLabel = RtsLabel (RtsData (sLit "top_ct")) mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE")) -mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then - RtsLabel (RtsInfo (sLit "stg_SE_CAF_BLACKHOLE")) - else -- RTS won't have info table unless -ticky is on - panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) moduleRegdLabel = ModuleRegdLabel +moduleRegTableLabel = ModuleInitTableLabel mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) @@ -370,6 +382,10 @@ addLabelSize (ForeignLabel str _ is_dynamic) sz addLabelSize label _ = label +foreignLabelStdcallInfo :: CLabel -> Maybe Int +foreignLabelStdcallInfo (ForeignLabel _ info _) = info +foreignLabelStdcallInfo _lbl = Nothing + -- Cost centres etc. mkCCLabel cc = CC_Label cc @@ -381,6 +397,7 @@ 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) mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str) mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str) @@ -420,9 +437,9 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl -- 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 (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) @@ -431,9 +448,9 @@ infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl" entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable -entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable -entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable +entryLblToInfoLbl (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) @@ -441,6 +458,24 @@ entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS 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) + +-- ----------------------------------------------------------------------------- +-- 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? -- @@ -450,13 +485,14 @@ 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 _ _ SRT) = False needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False -needsCDecl (IdLabel _ _) = True +needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True needsCDecl (ModuleInitLabel _ _) = True needsCDecl (PlainModuleInitLabel _) = True +needsCDecl (ModuleInitTableLabel _) = True needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False @@ -493,8 +529,16 @@ isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs (fsLit "cosf"), (fsLit "tanf"), (fsLit "sinhf"), (fsLit "coshf"), (fsLit "tanhf"), (fsLit "asinf"), (fsLit "acosf"), (fsLit "atanf"), (fsLit "logf"), - (fsLit "expf"), (fsLit "sqrtf") - ] + (fsLit "expf"), (fsLit "sqrtf"), (fsLit "frexp"), + (fsLit "modf"), (fsLit "ilogb"), (fsLit "copysign"), + (fsLit "remainder"), (fsLit "nextafter"), (fsLit "logb"), + (fsLit "cbrt"), (fsLit "atanh"), (fsLit "asinh"), + (fsLit "acosh"), (fsLit "lgamma"),(fsLit "hypot"), + (fsLit "erfc"), (fsLit "erf"), (fsLit "trunc"), + (fsLit "round"), (fsLit "fmod"), (fsLit "floor"), + (fsLit "fabs"), (fsLit "ceil"), (fsLit "log10"), + (fsLit "ldexp"), (fsLit "atan2"), (fsLit "rint") + ] isMathFun _ = False -- ----------------------------------------------------------------------------- @@ -510,10 +554,11 @@ externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True +externallyVisibleCLabel (ModuleInitTableLabel _)= False externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (ForeignLabel _ _ _) = True -externallyVisibleCLabel (IdLabel name _) = isExternalName name +externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -528,13 +573,25 @@ externallyVisibleCLabel (LargeSRTLabel _) = 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 labelType :: CLabel -> CLabelType 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 @@ -551,20 +608,19 @@ labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (ModuleInitLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel +labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel - -labelType (IdLabel _ info) = idInfoLabelType info -labelType _ = DataLabel +labelType (IdLabel _ _ info) = idInfoLabelType info +labelType _ = DataLabel idInfoLabelType info = case info of InfoTable -> DataLabel - Closure -> DataLabel + Closure -> GcPtrLabel ConInfoTable -> DataLabel StaticInfoTable -> DataLabel ClosureTable -> DataLabel --- krc: aie! a ticky counter label is data RednCounts -> DataLabel _ -> CodeLabel @@ -581,7 +637,7 @@ 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 + IdLabel n _ k -> isDllName this_pkg n #if mingw32_TARGET_OS ForeignLabel _ _ d -> d #else @@ -591,6 +647,7 @@ labelDynamic this_pkg lbl = #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 @@ -708,6 +765,7 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi pprCLbl (RtsLabel (RtsCode str)) = ptext str pprCLbl (RtsLabel (RtsData str)) = ptext str +pprCLbl (RtsLabel (RtsGcPtr str)) = ptext str pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str pprCLbl (RtsLabel (RtsDataFS str)) = ftext str @@ -777,7 +835,7 @@ pprCLbl ModuleRegdLabel pprCLbl (ForeignLabel str _ _) = ftext str -pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor +pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs @@ -787,6 +845,8 @@ pprCLbl (ModuleInitLabel mod way) <> 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")