X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=99befbd4476dd063e1671dd8797fded72eb28669;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=4215354850eaaca80967fd41e5ccab3c9e9f104d;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 4215354..99befbd 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% $Id: CLabel.lhs,v 1.32 2000/03/23 17:45:17 simonpj Exp $ +% (c) The University of Glasgow, 1992-2002 % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -11,9 +9,10 @@ module CLabel ( mkClosureLabel, mkSRTLabel, + mkSRTDescLabel, mkInfoTableLabel, - mkStdEntryLabel, - mkFastEntryLabel, + mkEntryLabel, + mkSlowEntryLabel, mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, @@ -34,9 +33,23 @@ module CLabel ( mkAsmTempLabel, mkModuleInitLabel, + mkPlainModuleInitLabel, mkErrorStdEntryLabel, + + mkStgUpdatePAPLabel, + mkSplitMarkerLabel, mkUpdInfoLabel, + mkSeqInfoLabel, + mkIndInfoLabel, + mkIndStaticInfoLabel, + mkRtsGCEntryLabel, + mkMainCapabilityLabel, + mkCharlikeClosureLabel, + mkIntlikeClosureLabel, + mkMAP_FROZEN_infoLabel, + mkEMPTY_MVAR_infoLabel, + mkTopTickyCtrLabel, mkBlackHoleInfoTableLabel, mkCAFBlackHoleInfoTableLabel, @@ -48,6 +61,11 @@ module CLabel ( mkSelectorInfoLabel, mkSelectorEntryLabel, + mkRtsApplyInfoLabel, + mkRtsApplyEntryLabel, + + mkForeignLabel, + mkCC_Label, mkCCS_Label, needsCDecl, isAsmTemp, externallyVisibleCLabel, @@ -55,9 +73,6 @@ module CLabel ( CLabelType(..), labelType, labelDynamic, pprCLabel -#if ! OMIT_NATIVE_CODEGEN - , pprCLabel_asm -#endif ) where @@ -69,15 +84,16 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) -import DataCon ( ConTag, DataCon ) -import Module ( isDynamicModule, ModuleName, moduleNameString ) -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: @@ -110,10 +126,22 @@ data CLabel | AsmTempLabel Unique - | ModuleInitLabel ModuleName + | ModuleInitLabel + Module -- the module name + String -- its "way" + -- at some point we might want some kind of version number in + -- the module init label, to guard against compiling modules in + -- the wrong order. We can't use the interface file version however, + -- because we don't always recompile modules which depend on a module + -- whose version has changed. + + | PlainModuleInitLabel Module -- without the vesrion & way info | RtsLabel RtsLabelInfo + | ForeignLabel FastString Bool -- a 'C' (or otherwise foreign) label + -- Bool <=> is dynamic + | CC_Label CostCentre | CCS_Label CostCentreStack @@ -123,20 +151,18 @@ data CLabel \begin{code} data IdLabelInfo = Closure -- Label for (static???) closure - | SRT -- Static reference table - - | InfoTbl -- Info table for a closure; always read-only - - | EntryStd -- Thunk, or "slow", code entry point - - | EntryFast Int -- entry pt when no arg satisfaction chk needed; - -- Int is the arity of the function (to be - -- encoded into the name) + | SRTDesc -- Static reference table descriptor + | InfoTbl -- Info tables for closures; always read-only + | Entry -- entry point + | Slow -- slow entry point -- Ticky-ticky counting | RednCounts -- Label of place to keep reduction-count info for -- this Id + + | Bitmap -- A bitmap (function or case return) + deriving (Eq, Ord) data DataConLabelInfo @@ -152,15 +178,20 @@ data CaseLabelInfo | CaseVecTbl | CaseAlt ConTag | CaseDefault - | CaseBitmap deriving (Eq, Ord) data RtsLabelInfo = RtsShouldNeverHappenCode - | RtsBlackHoleInfoTbl FAST_STRING -- black hole with info table name + | RtsBlackHoleInfoTbl LitString -- black hole with info table name - | RtsUpdInfo + | 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-} @@ -174,12 +205,16 @@ data RtsLabelInfo | RtsModuleRegd + | RtsApplyInfoLabel LitString + | RtsApplyEntryLabel LitString + deriving (Eq, Ord) -- Label Type: for generating C declarations. data CLabelType - = InfoTblType + = RetInfoTblType + | InfoTblType | ClosureType | VecTblType | ClosureTblType @@ -190,11 +225,11 @@ data CLabelType \begin{code} mkClosureLabel id = IdLabel id Closure mkSRTLabel id = IdLabel id SRT -mkInfoTableLabel id = IdLabel id InfoTbl -mkStdEntryLabel id = IdLabel id EntryStd -mkFastEntryLabel id arity = ASSERT(arity > 0) - IdLabel id (EntryFast arity) - +mkSRTDescLabel id = IdLabel id SRTDesc +mkInfoTableLabel id = IdLabel id InfoTbl +mkEntryLabel id = IdLabel id Entry +mkSlowEntryLabel id = IdLabel id Slow +mkBitmapLabel id = IdLabel id Bitmap mkRednCountsLabel id = IdLabel id RednCounts mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl @@ -208,23 +243,36 @@ mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) mkDefaultLabel uniq = CaseLabel uniq CaseDefault -mkBitmapLabel uniq = CaseLabel uniq CaseBitmap + mkClosureTblLabel tycon = TyConLabel tycon mkAsmTempLabel = AsmTempLabel mkModuleInitLabel = ModuleInitLabel +mkPlainModuleInitLabel = PlainModuleInitLabel -- Some fixed runtime system labels -mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode +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 SLIT("BLACKHOLE_info")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info")) +mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info")) +mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info")) mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then - RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info")) + RtsLabel (RtsBlackHoleInfoTbl SLIT("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) @@ -237,10 +285,20 @@ 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 mkCCS_Label ccs = CCS_Label ccs + +-- Std RTS application routines + +mkRtsApplyInfoLabel = RtsLabel . RtsApplyInfoLabel +mkRtsApplyEntryLabel = RtsLabel . RtsApplyEntryLabel \end{code} \begin{code} @@ -262,15 +320,22 @@ Declarations for direct return points are needed, because they may be let-no-escapes, which can be recursive. \begin{code} + -- don't bother declaring SRT & Bitmap labels, we always make sure + -- they are defined before use. +needsCDecl (IdLabel _ SRT) = False +needsCDecl (IdLabel _ SRTDesc) = False +needsCDecl (IdLabel _ Bitmap) = False needsCDecl (IdLabel _ _) = True needsCDecl (CaseLabel _ CaseReturnPt) = True needsCDecl (DataConLabel _ _) = True -needsCDecl (CaseLabel _ _) = False needsCDecl (TyConLabel _) = True +needsCDecl (ModuleInitLabel _ _) = True +needsCDecl (PlainModuleInitLabel _) = True +needsCDecl (CaseLabel _ _) = False needsCDecl (AsmTempLabel _) = False -needsCDecl (ModuleInitLabel _) = False needsCDecl (RtsLabel _) = False +needsCDecl (ForeignLabel _ _) = False needsCDecl (CC_Label _) = False needsCDecl (CCS_Label _) = False \end{code} @@ -292,32 +357,46 @@ externallyVisibleCLabel (DataConLabel _ _) = True externallyVisibleCLabel (TyConLabel tc) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _)= True +externallyVisibleCLabel (ModuleInitLabel _ _)= True +externallyVisibleCLabel (PlainModuleInitLabel _)= 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} -For generating correct types in label declarations... +For generating correct types in label declarations, and also for +deciding whether the C compiler would like us to use '&' before the +label to get its address: \begin{code} labelType :: CLabel -> CLabelType labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType -labelType (RtsLabel RtsUpdInfo) = InfoTblType -labelType (CaseLabel _ CaseReturnInfo) = InfoTblType +labelType (RtsLabel RtsUpdInfo) = RetInfoTblType +labelType (RtsLabel RtsSeqInfo) = RetInfoTblType +labelType (RtsLabel RtsTopTickyCtr) = CodeType -- XXX +labelType (RtsLabel (Rts_Info _)) = InfoTblType +labelType (RtsLabel (RtsApplyInfoLabel _)) = RetInfoTblType +labelType (RtsLabel (RtsApplyEntryLabel _)) = CodeType +labelType (CaseLabel _ CaseReturnInfo) = RetInfoTblType labelType (CaseLabel _ CaseReturnPt) = CodeType labelType (CaseLabel _ CaseVecTbl) = VecTblType labelType (TyConLabel _) = ClosureTblType +labelType (ModuleInitLabel _ _) = CodeType +labelType (PlainModuleInitLabel _) = CodeType +labelType (CC_Label _) = CodeType -- hack +labelType (CCS_Label _) = CodeType -- hack labelType (IdLabel _ info) = case info of - InfoTbl -> InfoTblType - Closure -> ClosureType - _ -> CodeType + InfoTbl -> InfoTblType + Closure -> ClosureType + Bitmap -> DataType + _ -> CodeType labelType (DataConLabel _ info) = case info of @@ -337,12 +416,17 @@ 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)) + PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) + _ -> False \end{code} @@ -366,7 +450,9 @@ internal names. is one of the following: info Info table srt Static reference table + srtd Static reference table descriptor entry Entry code + slow Slow entry code (if any) ret Direct return address vtbl Vector table _alt Case alternative (tag n) @@ -383,11 +469,6 @@ internal names. is one of the following: 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 @@ -414,51 +495,66 @@ pprCLbl (CaseLabel u (CaseAlt tag)) = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")] pprCLbl (CaseLabel u CaseDefault) = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")] -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("Upd_frame_info") +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 RtsTopTickyCtr) = ptext SLIT("top_ct") pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext 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 (RtsApplyInfoLabel fs)) + = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_info") + +pprCLbl (RtsLabel (RtsApplyEntryLabel fs)) + = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_ret") + 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")] @@ -468,7 +564,11 @@ 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("__init_") <> ptext mod +pprCLbl (ModuleInitLabel mod way) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) + <> char '_' <> text way +pprCLbl (PlainModuleInitLabel mod) + = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) ppIdFlavor :: IdLabelInfo -> SDoc @@ -476,11 +576,12 @@ ppIdFlavor x = pp_cSEP <> (case x of Closure -> ptext SLIT("closure") SRT -> ptext SLIT("srt") - InfoTbl -> ptext SLIT("info") - EntryStd -> ptext SLIT("entry") - EntryFast arity -> --false:ASSERT (arity > 0) - (<>) (ptext SLIT("fast")) (int arity) + SRTDesc -> ptext SLIT("srtd") + InfoTbl -> ptext SLIT("info") + Entry -> ptext SLIT("entry") + Slow -> ptext SLIT("slow") RednCounts -> ptext SLIT("ct") + Bitmap -> ptext SLIT("btm") ) ppConFlavor x = pp_cSEP <> @@ -491,4 +592,3 @@ ppConFlavor x = pp_cSEP <> StaticInfoTbl -> ptext SLIT("static_info") ) \end{code} -