X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCLabel.hs;h=181071f7a0db83610f264ecfa0c42c011cda93db;hb=984a288119983912d40a80845c674ee4b83a19ce;hp=f95a0fda04400489be297927000accbd1ed3d7b6;hpb=f7ecb11b40e5225ae6fa0284f1a7bbaa5b9edae8;p=ghc-hetmet.git diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index f95a0fd..181071f 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -81,15 +81,10 @@ module CLabel ( mkRtsDataLabel, mkRtsGcPtrLabel, - mkRtsInfoLabelFS, - mkRtsEntryLabelFS, - mkRtsRetInfoLabelFS, - mkRtsRetLabelFS, - mkRtsCodeLabelFS, - mkRtsDataLabelFS, - mkRtsApFastLabel, + mkPrimCallLabel, + mkForeignLabel, addLabelSize, foreignLabelStdcallInfo, @@ -133,6 +128,7 @@ import CostCentre import Outputable import FastString import DynFlags +import UniqSet -- ----------------------------------------------------------------------------- -- The CLabel type @@ -270,22 +266,15 @@ data RtsLabelInfo | RtsPrimOp PrimOp - | RtsInfo LitString -- misc rts info tables - | 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 - | RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure - | RtsCode LitString -- misc rts code - - | RtsInfoFS FastString -- misc rts info tables - | RtsEntryFS FastString -- misc rts entry points - | RtsRetInfoFS FastString -- misc rts ret info tables - | RtsRetFS FastString -- misc rts return points - | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure - | RtsCodeFS FastString -- misc rts code + | 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 LitString -- _fast versions of generic apply + | RtsApFast FastString -- _fast versions of generic apply | RtsSlowTickyCtr String @@ -352,17 +341,17 @@ 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")) +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")) mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) moduleRegdLabel = ModuleRegdLabel @@ -374,6 +363,11 @@ 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 -> FunctionOrData -> CLabel @@ -403,13 +397,6 @@ 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) -mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str) -mkRtsRetLabelFS str = RtsLabel (RtsRetFS str) -mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str) -mkRtsDataLabelFS str = RtsLabel (RtsDataFS str) - mkRtsApFastLabel str = RtsLabel (RtsApFast str) mkRtsSlowTickyCtrLabel :: String -> CLabel @@ -441,25 +428,21 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl -- 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 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 (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s) -infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) +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" 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 (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) -entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s) +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 @@ -522,9 +505,10 @@ 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 = [ +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"), @@ -603,7 +587,6 @@ isMathFun (ForeignLabel fs _ _ _) = fs `elem` math_funs (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl") ] -isMathFun _ = False -- ----------------------------------------------------------------------------- -- Is a CLabel visible outside this object file or not? @@ -661,23 +644,17 @@ labelType (RtsLabel (RtsInfo _)) = DataLabel labelType (RtsLabel (RtsEntry _)) = CodeLabel labelType (RtsLabel (RtsRetInfo _)) = DataLabel labelType (RtsLabel (RtsRet _)) = CodeLabel -labelType (RtsLabel (RtsDataFS _)) = DataLabel -labelType (RtsLabel (RtsCodeFS _)) = CodeLabel -labelType (RtsLabel (RtsInfoFS _)) = DataLabel -labelType (RtsLabel (RtsEntryFS _)) = CodeLabel -labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel -labelType (RtsLabel (RtsRetFS _)) = 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 (IdLabel _ _ info) = idInfoLabelType info -labelType _ = DataLabel +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 (IdLabel _ _ info) = idInfoLabelType info +labelType _ = DataLabel idInfoLabelType info = case info of @@ -828,13 +805,11 @@ 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)) = 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 (RtsCode str)) = ftext str +pprCLbl (RtsLabel (RtsData str)) = ftext str +pprCLbl (RtsLabel (RtsGcPtr str)) = ftext str -pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext (sLit "_fast") +pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) = hcat [ptext (sLit "stg_sel_"), text (show offset), @@ -865,31 +840,19 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) ] pprCLbl (RtsLabel (RtsInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsEntry fs)) - = ptext fs <> ptext (sLit "_entry") - -pprCLbl (RtsLabel (RtsRetInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsRet fs)) - = ptext fs <> ptext (sLit "_ret") - -pprCLbl (RtsLabel (RtsInfoFS fs)) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsEntryFS fs)) +pprCLbl (RtsLabel (RtsEntry fs)) = ftext fs <> ptext (sLit "_entry") -pprCLbl (RtsLabel (RtsRetInfoFS fs)) +pprCLbl (RtsLabel (RtsRetInfo fs)) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsRetFS fs)) +pprCLbl (RtsLabel (RtsRet fs)) = ftext fs <> ptext (sLit "_ret") pprCLbl (RtsLabel (RtsPrimOp primop)) - = ppr primop <> ptext (sLit "_fast") + = ptext (sLit "stg_") <> ppr primop pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") @@ -961,6 +924,10 @@ asmTempLabelPrefix = 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