X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=a26d9d7a5101e3d2844b41889058dbddba709d1c;hb=f477a85c5ba20c12e6f229e5b870fddc7e8bacfd;hp=d3f3d65aca8267b4f7dfb11c9d8608f6dfcd6aa8;hpb=be2b723f7927ad7927e9d187fd7efda049d6dc77;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index d3f3d65..a26d9d7 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.24 1999/03/02 16:44:26 sof Exp $ +% $Id: CLabel.lhs,v 1.52 2002/04/29 14:03:39 simonmar Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -18,7 +18,6 @@ module CLabel ( mkStaticConEntryLabel, mkRednCountsLabel, mkConInfoTableLabel, - mkStaticClosureLabel, mkStaticInfoTableLabel, mkApEntryLabel, mkApInfoTableLabel, @@ -34,24 +33,43 @@ module CLabel ( mkAsmTempLabel, + mkModuleInitLabel, + mkErrorStdEntryLabel, - mkUpdEntryLabel, + + mkStgUpdatePAPLabel, + mkSplitMarkerLabel, + mkUpdInfoLabel, + mkSeqInfoLabel, + mkIndInfoLabel, + mkIndStaticInfoLabel, + mkRtsGCEntryLabel, + mkMainCapabilityLabel, + mkCharlikeClosureLabel, + mkIntlikeClosureLabel, + mkMAP_FROZEN_infoLabel, + mkEMPTY_MVAR_infoLabel, + + mkTopTickyCtrLabel, mkBlackHoleInfoTableLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, + moduleRegdLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, + mkForeignLabel, + mkCC_Label, mkCCS_Label, - needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, + needsCDecl, isAsmTemp, externallyVisibleCLabel, CLabelType(..), labelType, labelDynamic, pprCLabel -#if ! OMIT_NATIVE_CODEGEN - , pprCLabel_asm -#endif ) where @@ -61,17 +79,18 @@ module CLabel ( import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) #endif -import CmdLineOpts ( opt_Static ) +import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) -import DataCon ( ConTag, DataCon ) -import Module ( isDynamicModule ) -import Name ( Name, getName, isExternallyVisibleName, nameModule, isLocallyDefinedName ) +import DataCon ( ConTag ) +import Module ( moduleName, moduleNameFS, + Module, isHomeModule ) +import Name ( Name, getName, isDllName, isExternalName ) import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) -import PrimOp ( PrimOp, pprPrimOp ) +import PrimOp ( PrimOp ) import CostCentre ( CostCentre, CostCentreStack ) -import Util import Outputable +import FastString \end{code} things we want to find out: @@ -104,8 +123,13 @@ data CLabel | AsmTempLabel Unique + | ModuleInitLabel Module + | RtsLabel RtsLabelInfo + | ForeignLabel FastString Bool -- a 'C' (or otherwise foreign) label + -- Bool <=> is dynamic + | CC_Label CostCentre | CCS_Label CostCentreStack @@ -134,9 +158,6 @@ data IdLabelInfo data DataConLabelInfo = ConEntry -- the only kind of entry pt for constructors | ConInfoTbl -- corresponding info table - - | StaticClosure -- Static constructor closure - -- e.g., nullary constructor | StaticConEntry -- static constructor entry point | StaticInfoTbl -- corresponding info table deriving (Eq, Ord) @@ -153,9 +174,15 @@ data CaseLabelInfo data RtsLabelInfo = RtsShouldNeverHappenCode - | RtsBlackHoleInfoTbl + | RtsBlackHoleInfoTbl FastString -- black hole with info table name - | RtsUpdEntry + | RtsUpdInfo -- upd_frame_info + | RtsSeqInfo -- seq_frame_info + | RtsGCEntryLabel String -- a heap check fail handler, eg stg_chk_2 + | RtsMainCapability -- MainCapability + | Rts_Closure String -- misc rts closures, eg CHARLIKE_closure + | Rts_Info String -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info + | Rts_Code String -- misc rts code | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks | RtsSelectorEntry Bool{-updatable-} Int{-offset-} @@ -165,6 +192,10 @@ data RtsLabelInfo | RtsPrimOp PrimOp + | RtsTopTickyCtr + + | RtsModuleRegd + deriving (Eq, Ord) -- Label Type: for generating C declarations. @@ -173,6 +204,7 @@ data CLabelType = InfoTblType | ClosureType | VecTblType + | ClosureTblType | CodeType | DataType \end{code} @@ -187,7 +219,6 @@ mkFastEntryLabel id arity = ASSERT(arity > 0) mkRednCountsLabel id = IdLabel id RednCounts -mkStaticClosureLabel con = DataConLabel con StaticClosure mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl mkConInfoTableLabel con = DataConLabel con ConInfoTbl mkConEntryLabel con = DataConLabel con ConEntry @@ -205,19 +236,46 @@ mkClosureTblLabel tycon = TyConLabel tycon mkAsmTempLabel = AsmTempLabel +mkModuleInitLabel = ModuleInitLabel + -- Some fixed runtime system labels -mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode -mkUpdEntryLabel = RtsLabel RtsUpdEntry -mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl +mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode +mkStgUpdatePAPLabel = RtsLabel (Rts_Code "stg_update_PAP") +mkSplitMarkerLabel = RtsLabel (Rts_Code "__stg_split_marker") +mkUpdInfoLabel = RtsLabel RtsUpdInfo +mkSeqInfoLabel = RtsLabel RtsSeqInfo +mkIndInfoLabel = RtsLabel (Rts_Info "stg_IND_info") +mkIndStaticInfoLabel = RtsLabel (Rts_Info "stg_IND_STATIC_info") +mkRtsGCEntryLabel str = RtsLabel (RtsGCEntryLabel str) +mkMainCapabilityLabel = RtsLabel RtsMainCapability +mkCharlikeClosureLabel = RtsLabel (Rts_Closure "stg_CHARLIKE_closure") +mkIntlikeClosureLabel = RtsLabel (Rts_Closure "stg_INTLIKE_closure") +mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info") +mkEMPTY_MVAR_infoLabel = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info") + +mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr +mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_BLACKHOLE_info")) +mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_CAF_BLACKHOLE_info")) +mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then + RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_SE_CAF_BLACKHOLE_info")) + else -- RTS won't have info table unless -ticky is on + panic "mkSECAFBlackHoleInfoTableLabel requires -ticky" mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) +moduleRegdLabel = RtsLabel RtsModuleRegd + mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off) mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) + -- Foreign labels + +mkForeignLabel :: FastString -> Bool -> CLabel +mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic + -- Cost centres etc. mkCC_Label cc = CC_Label cc @@ -226,7 +284,6 @@ mkCCS_Label ccs = CCS_Label ccs \begin{code} needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -isReadOnly :: CLabel -> Bool -- lives in C "text space" isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation externallyVisibleCLabel :: CLabel -> Bool -- not C "static" \end{code} @@ -247,30 +304,17 @@ let-no-escapes, which can be recursive. needsCDecl (IdLabel _ _) = True needsCDecl (CaseLabel _ CaseReturnPt) = True needsCDecl (DataConLabel _ _) = True -needsCDecl (CaseLabel _ _) = False +needsCDecl (TyConLabel _) = True +needsCDecl (ModuleInitLabel _) = True +needsCDecl (CaseLabel _ _) = False needsCDecl (AsmTempLabel _) = False -needsCDecl (TyConLabel _) = False needsCDecl (RtsLabel _) = False +needsCDecl (ForeignLabel _ _) = False needsCDecl (CC_Label _) = False needsCDecl (CCS_Label _) = False \end{code} -Whether the labelled thing can be put in C "text space": - -\begin{code} -isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes -isReadOnly (IdLabel _ other) = False -- others: pessimistically, no - -isReadOnly (DataConLabel _ _) = True -- and so on, for other -isReadOnly (TyConLabel _) = True -isReadOnly (CaseLabel _ _) = True -isReadOnly (AsmTempLabel _) = True -isReadOnly (RtsLabel _) = True -isReadOnly (CC_Label _) = True -isReadOnly (CCS_Label _) = True -\end{code} - Whether the label is an assembler temporary: \begin{code} @@ -288,8 +332,11 @@ externallyVisibleCLabel (DataConLabel _ _) = True externallyVisibleCLabel (TyConLabel tc) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (ModuleInitLabel _)= True +externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (IdLabel id _) = isExternallyVisibleName id +externallyVisibleCLabel (ForeignLabel _ _) = True +externallyVisibleCLabel (IdLabel id _) = isExternalName id externallyVisibleCLabel (CC_Label _) = False -- not strictly true externallyVisibleCLabel (CCS_Label _) = False -- not strictly true \end{code} @@ -298,12 +345,16 @@ For generating correct types in label declarations... \begin{code} labelType :: CLabel -> CLabelType -labelType (RtsLabel RtsBlackHoleInfoTbl) = InfoTblType +labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType +labelType (RtsLabel RtsUpdInfo) = InfoTblType +labelType (RtsLabel (Rts_Info _)) = InfoTblType labelType (CaseLabel _ CaseReturnInfo) = InfoTblType labelType (CaseLabel _ CaseReturnPt) = CodeType labelType (CaseLabel _ CaseVecTbl) = VecTblType +labelType (TyConLabel _) = ClosureTblType +labelType (ModuleInitLabel _ ) = CodeType labelType (IdLabel _ info) = case info of @@ -315,7 +366,6 @@ labelType (DataConLabel _ info) = case info of ConInfoTbl -> InfoTblType StaticInfoTbl -> InfoTblType - StaticClosure -> ClosureType _ -> CodeType labelType _ = DataType @@ -330,12 +380,16 @@ in a DLL, be it a data reference or not. labelDynamic :: CLabel -> Bool labelDynamic lbl = case lbl of - RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? - IdLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n) - DataConLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n) - TyConLabel tc | not (isLocallyDefinedName (getName tc)) -> isDynamicModule (nameModule (getName tc)) - _ -> False - + -- The special case for RtsShouldNeverHappenCode is because the associated address is + -- NULL, i.e. not a DLL entry point + RtsLabel RtsShouldNeverHappenCode -> False + RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? + IdLabel n k -> isDllName n + DataConLabel n k -> isDllName n + TyConLabel tc -> isDllName (getName tc) + ForeignLabel _ d -> d + ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) + _ -> False \end{code} @@ -366,20 +420,16 @@ internal names. is one of the following: dflt Default case alternative btm Large bitmap vector closure Static closure - static_closure Static closure (???) con_entry Dynamic Constructor entry code con_info Dynamic Constructor info table static_entry Static Constructor entry code static_info Static Constructor info table sel_info Selector info table sel_entry Selector entry code + cc Cost centre + ccs Cost centre stack \begin{code} --- specialised for PprAsm: saves lots of arg passing in NCG -#if ! OMIT_NATIVE_CODEGEN -pprCLabel_asm = pprCLabel -#endif - pprCLabel :: CLabel -> SDoc #if ! OMIT_NATIVE_CODEGEN @@ -409,42 +459,58 @@ pprCLbl (CaseLabel u CaseDefault) pprCLbl (CaseLabel u CaseBitmap) = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")] -pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry") +pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL") +-- used to be stg_error_entry but Windows can't have DLL entry points as static +-- initialisers, and besides, this ShouldNeverHappen, right? + +pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("stg_upd_frame_info") +pprCLbl (RtsLabel RtsSeqInfo) = ptext SLIT("stg_seq_frame_info") +pprCLbl (RtsLabel RtsMainCapability) = ptext SLIT("MainCapability") +pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str +pprCLbl (RtsLabel (Rts_Closure str)) = text str +pprCLbl (RtsLabel (Rts_Info str)) = text str +pprCLbl (RtsLabel (Rts_Code str)) = text str -pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry") +pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct") -pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("CAF_BLACKHOLE_info") +pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ftext info pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) - = hcat [ptext SLIT("__sel_"), text (show offset), + = hcat [ptext SLIT("stg_sel_"), text (show offset), ptext (if upd_reqd then SLIT("_upd_info") else SLIT("_noupd_info")) ] pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = hcat [ptext SLIT("__sel_"), text (show offset), + = hcat [ptext SLIT("stg_sel_"), text (show offset), ptext (if upd_reqd then SLIT("_upd_entry") else SLIT("_noupd_entry")) ] pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity)) - = hcat [ptext SLIT("__ap_"), text (show arity), + = hcat [ptext SLIT("stg_ap_"), text (show arity), ptext (if upd_reqd then SLIT("_upd_info") else SLIT("_noupd_info")) ] pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = hcat [ptext SLIT("__ap_"), text (show arity), + = hcat [ptext SLIT("stg_ap_"), text (show arity), ptext (if upd_reqd then SLIT("_upd_entry") else SLIT("_noupd_entry")) ] pprCLbl (RtsLabel (RtsPrimOp primop)) - = pprPrimOp primop <> ptext SLIT("_fast") + = ppr primop <> ptext SLIT("_fast") + +pprCLbl (RtsLabel RtsModuleRegd) + = ptext SLIT("module_registered") + +pprCLbl (ForeignLabel str _) + = ftext str pprCLbl (TyConLabel tc) = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")] @@ -455,6 +521,9 @@ pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs +pprCLbl (ModuleInitLabel mod) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) + ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> @@ -470,7 +539,6 @@ ppIdFlavor x = pp_cSEP <> ppConFlavor x = pp_cSEP <> (case x of - StaticClosure -> ptext SLIT("static_closure") ConEntry -> ptext SLIT("con_entry") ConInfoTbl -> ptext SLIT("con_info") StaticConEntry -> ptext SLIT("static_entry")