X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=4e9ef8c5ae95f983dca7cc5993655e1462939933;hp=31749d4a2c84389a655c4258c26e8ebd729e7009;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=374a85aec86d9c15ed4c48af3e284f9fee19ad72 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 31749d4..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, @@ -171,16 +174,21 @@ data CLabel -- | 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 @@ -346,6 +405,7 @@ mkStaticConEntryLabel name c = IdLabel name c StaticConEntry 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 @@ -378,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 --- Foreign labels -mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz is_dynamic fod - = ForeignLabel str mb_sz is_dynamic fod +-- | 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 +-- | Get the label size field from a ForeignLabel foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing @@ -530,8 +602,16 @@ needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl (CmmLabel _ _ _) = 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 @@ -551,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 [ @@ -640,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 @@ -656,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 @@ -707,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 @@ -733,15 +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? - CmmLabel pkg _ _ -> not opt_Static && (this_pkg /= pkg) + -- 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) @@ -864,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") @@ -919,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 @@ -940,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") @@ -959,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. @@ -1001,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 @@ -1009,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 @@ -1019,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