X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=4e9ef8c5ae95f983dca7cc5993655e1462939933;hp=8b8a7f98e6b676db7662c22165f9053ef921f3e6;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=ddb7062b0674e8a08bd90b4eca0b9379195d5e40 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8b8a7f9..4e9ef8c 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -15,6 +15,8 @@ module CLabel ( CLabel, -- abstract type + ForeignLabelSource(..), + pprDebugCLabel, mkClosureLabel, mkSRTLabel, @@ -56,6 +58,7 @@ module CLabel ( mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_infoLabel, @@ -73,13 +76,13 @@ module CLabel ( mkSelectorInfoLabel, mkSelectorEntryLabel, - mkRtsInfoLabel, - mkRtsEntryLabel, - mkRtsRetInfoLabel, - mkRtsRetLabel, - mkRtsCodeLabel, - mkRtsDataLabel, - mkRtsGcPtrLabel, + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkCmmGcPtrLabel, mkRtsApFastLabel, @@ -164,23 +167,28 @@ data CLabel -- | A label from a .cmm file that is not associated with a .hs level Id. | CmmLabel - Module -- what Cmm source module the label belongs to + 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 Module argument. + -- 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. @@ -247,6 +255,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 @@ -301,6 +359,7 @@ data CmmLabelInfo | 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 @@ -342,38 +401,31 @@ mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable mkConEntryLabel name c = IdLabel name c ConEntry mkStaticConEntryLabel name c = IdLabel name c StaticConEntry - -- Constructing Cmm Labels - --- | Pretend that wired-in names from the RTS are in a top-level module called RTS, --- located in the RTS package. It doesn't matter what module they're actually in --- as long as that module is in the correct package. -topRtsModule :: Module -topRtsModule = mkModule rtsPackageId (mkModuleNameFS (fsLit "RTS")) - -mkSplitMarkerLabel = CmmLabel topRtsModule (fsLit "__stg_split_marker") CmmCode -mkDirty_MUT_VAR_Label = CmmLabel topRtsModule (fsLit "dirty_MUT_VAR") CmmCode -mkUpdInfoLabel = CmmLabel topRtsModule (fsLit "stg_upd_frame") CmmInfo -mkIndStaticInfoLabel = CmmLabel topRtsModule (fsLit "stg_IND_STATIC") CmmInfo -mkMainCapabilityLabel = CmmLabel topRtsModule (fsLit "MainCapability") CmmData -mkMAP_FROZEN_infoLabel = CmmLabel topRtsModule (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkMAP_DIRTY_infoLabel = CmmLabel topRtsModule (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo -mkEMPTY_MVAR_infoLabel = CmmLabel topRtsModule (fsLit "stg_EMPTY_MVAR") CmmInfo -mkTopTickyCtrLabel = CmmLabel topRtsModule (fsLit "top_ct") CmmData -mkCAFBlackHoleInfoTableLabel = CmmLabel topRtsModule (fsLit "stg_CAF_BLACKHOLE") CmmInfo +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 ----- -mkRtsInfoLabel, mkRtsEntryLabel, mkRtsRetInfoLabel, mkRtsRetLabel, - mkRtsCodeLabel, mkRtsDataLabel, mkRtsGcPtrLabel - :: FastString -> CLabel +mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, + mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel + :: PackageId -> FastString -> CLabel -mkRtsInfoLabel str = CmmLabel topRtsModule str CmmInfo -mkRtsEntryLabel str = CmmLabel topRtsModule str CmmEntry -mkRtsRetInfoLabel str = CmmLabel topRtsModule str CmmRetInfo -mkRtsRetLabel str = CmmLabel topRtsModule str CmmRet -mkRtsCodeLabel str = CmmLabel topRtsModule str CmmCode -mkRtsDataLabel str = CmmLabel topRtsModule str CmmData -mkRtsGcPtrLabel str = CmmLabel topRtsModule str CmmGcPtr +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 @@ -386,22 +438,34 @@ mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) --- Constructing ForeignLabels --- 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 + + +-- Constructing ForeignLabels + +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> Maybe Int -- size prefix + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel --- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz is_dynamic fod - = ForeignLabel str mb_sz is_dynamic fod +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 +-- | Get the label size field from a ForeignLabel foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing @@ -538,7 +602,16 @@ needsCDecl ModuleRegdLabel = False 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 @@ -558,12 +631,12 @@ maybeAsmTemp (AsmTempLabel uq) = Just uq maybeAsmTemp _ = Nothing --- Check whether a label corresponds to a C function that has +-- | 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 (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs isMathFun _ = False math_funs = mkUniqSet [ @@ -647,12 +720,10 @@ 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 @@ -663,7 +734,7 @@ externallyVisibleCLabel (ModuleInitTableLabel _)= False externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True -externallyVisibleCLabel (ForeignLabel _ _ _ _) = True +externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True @@ -714,7 +785,7 @@ 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 @@ -740,14 +811,34 @@ 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) @@ -870,6 +961,7 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi 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") @@ -925,7 +1017,7 @@ pprCLbl ModuleRegdLabel 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 @@ -946,8 +1038,8 @@ pprCLbl (HpcTicksLabel mod) 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") @@ -965,6 +1057,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. @@ -1007,7 +1107,7 @@ pprDynamicLinkerAsmLabel SymbolPtr lbl 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 @@ -1015,7 +1115,7 @@ pprDynamicLinkerAsmLabel SymbolPtr 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 @@ -1025,7 +1125,7 @@ pprDynamicLinkerAsmLabel GotSymbolOffset 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