X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=9ba55ac7b2baabf834009ee5a04da0a7e64fb307;hp=f9a94b79b13c0f857477ec435ddb22476a01b65d;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=37323ea050c72aab86f01de04374844c8f66c3a2 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index f9a94b7..9ba55ac 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, @@ -88,8 +90,11 @@ module CLabel ( mkRtsApFastLabel, + mkPrimCallLabel, + mkForeignLabel, addLabelSize, + foreignLabelStdcallInfo, mkCCLabel, mkCCSLabel, @@ -103,18 +108,21 @@ 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 BasicTypes +import Literal import Packages import DataCon import PackageConfig @@ -127,6 +135,7 @@ import CostCentre import Outputable import FastString import DynFlags +import UniqSet -- ----------------------------------------------------------------------------- -- The CLabel type @@ -156,6 +165,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 @@ -178,18 +188,22 @@ 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 | RtsLabel RtsLabelInfo - | ForeignLabel FastString -- a 'C' (or otherwise foreign) label - (Maybe Int) -- possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - Bool -- True <=> is dynamic + | 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 + FunctionOrData | CC_Label CostCentre | CCS_Label CostCentreStack @@ -263,7 +277,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 @@ -293,29 +308,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 @@ -335,26 +350,26 @@ 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")) -mkDirty_MUT_VAR_Label = RtsLabel (RtsCode SLIT("dirty_MUT_VAR")) -mkUpdInfoLabel = RtsLabel (RtsInfo SLIT("stg_upd_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" +mkSplitMarkerLabel = RtsLabel (RtsCode (sLit "__stg_split_marker")) +mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (sLit "dirty_MUT_VAR")) +mkUpdInfoLabel = RtsLabel (RtsInfo (sLit "stg_upd_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")) mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) moduleRegdLabel = ModuleRegdLabel +moduleRegTableLabel = ModuleInitTableLabel mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) @@ -362,17 +377,27 @@ mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) + -- Primitive / cmm call labels + +mkPrimCallLabel :: PrimCall -> CLabel +mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction + -- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel -mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic +mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel +mkForeignLabel str mb_sz is_dynamic fod + = ForeignLabel str mb_sz is_dynamic fod addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ is_dynamic) sz - = ForeignLabel str (Just sz) is_dynamic +addLabelSize (ForeignLabel str _ is_dynamic fod) sz + = ForeignLabel str (Just sz) is_dynamic fod addLabelSize label _ = label +foreignLabelStdcallInfo :: CLabel -> Maybe Int +foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info +foreignLabelStdcallInfo _lbl = Nothing + -- Cost centres etc. mkCCLabel cc = CC_Label cc @@ -384,6 +409,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) @@ -423,9 +449,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) @@ -434,9 +460,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) @@ -444,6 +470,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? -- @@ -453,19 +497,20 @@ 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 needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl l@(ForeignLabel _ _ _) = not (isMathFun l) +needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True @@ -485,21 +530,89 @@ maybeAsmTemp _ = Nothing -- they are builtin to the C compiler. For these labels we avoid -- generating our own C prototypes. isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs - where - math_funs = [ - FSLIT("pow"), FSLIT("sin"), FSLIT("cos"), - FSLIT("tan"), FSLIT("sinh"), FSLIT("cosh"), - FSLIT("tanh"), FSLIT("asin"), FSLIT("acos"), - FSLIT("atan"), FSLIT("log"), FSLIT("exp"), - FSLIT("sqrt"), FSLIT("powf"), FSLIT("sinf"), - FSLIT("cosf"), FSLIT("tanf"), FSLIT("sinhf"), - FSLIT("coshf"), FSLIT("tanhf"), FSLIT("asinf"), - FSLIT("acosf"), FSLIT("atanf"), FSLIT("logf"), - FSLIT("expf"), FSLIT("sqrtf") - ] +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? @@ -513,10 +626,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 (ForeignLabel _ _ _ _) = True +externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -531,13 +645,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 @@ -554,20 +680,20 @@ 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 (ForeignLabel _ _ _ IsFunction) = CodeLabel +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 @@ -584,16 +710,17 @@ 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 + ForeignLabel _ _ d _ -> d #else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic libraries - ForeignLabel _ _ _ -> True + ForeignLabel _ _ _ _ -> 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 @@ -662,10 +789,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 = @@ -684,26 +811,26 @@ 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") +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. @@ -711,106 +838,109 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext SLIT 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 -pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext SLIT("_fast") +pprCLbl (RtsLabel (RtsApFast str)) = ptext 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") + = ptext fs <> ptext (sLit "_info") pprCLbl (RtsLabel (RtsEntry fs)) - = ptext fs <> ptext SLIT("_entry") + = ptext fs <> ptext (sLit "_entry") pprCLbl (RtsLabel (RtsRetInfo fs)) - = ptext fs <> ptext SLIT("_info") + = ptext fs <> ptext (sLit "_info") pprCLbl (RtsLabel (RtsRet fs)) - = ptext fs <> ptext SLIT("_ret") + = ptext fs <> ptext (sLit "_ret") pprCLbl (RtsLabel (RtsInfoFS fs)) - = ftext fs <> ptext SLIT("_info") + = ftext fs <> ptext (sLit "_info") pprCLbl (RtsLabel (RtsEntryFS fs)) - = ftext fs <> ptext SLIT("_entry") + = ftext fs <> ptext (sLit "_entry") pprCLbl (RtsLabel (RtsRetInfoFS fs)) - = ftext fs <> ptext SLIT("_info") + = ftext fs <> ptext (sLit "_info") pprCLbl (RtsLabel (RtsRetFS fs)) - = ftext fs <> ptext SLIT("_ret") + = ftext fs <> ptext (sLit "_ret") pprCLbl (RtsLabel (RtsPrimOp primop)) - = ppr primop <> ptext SLIT("_fast") + = ppr primop <> ptext (sLit "_fast") 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 (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs pprCLbl (ModuleInitLabel mod way) - = ptext SLIT("__stginit_") <> ppr mod + = ptext (sLit "__stginit_") <> ppr mod <> char '_' <> text way pprCLbl (PlainModuleInitLabel mod) - = ptext SLIT("__stginit_") <> ppr 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") + = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") pprCLbl HpcModuleNameLabel - = ptext SLIT("_hpc_module_name_str") + = ptext (sLit "_hpc_module_name_str") ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> (case x of - 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") + 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") ) @@ -829,16 +959,20 @@ 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 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