% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % % $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} \begin{code} module CLabel ( CLabel, -- abstract type mkClosureLabel, mkSRTLabel, mkInfoTableLabel, mkStdEntryLabel, mkFastEntryLabel, mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, mkConInfoTableLabel, mkStaticInfoTableLabel, mkApEntryLabel, mkApInfoTableLabel, mkReturnPtLabel, mkReturnInfoLabel, mkVecTblLabel, mkAltLabel, mkDefaultLabel, mkBitmapLabel, mkClosureTblLabel, mkAsmTempLabel, mkModuleInitLabel, mkPlainModuleInitLabel, mkErrorStdEntryLabel, 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, isAsmTemp, externallyVisibleCLabel, CLabelType(..), labelType, labelDynamic, pprCLabel ) where #include "HsVersions.h" #if ! OMIT_NATIVE_CODEGEN import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) #endif import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) 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 ) import CostCentre ( CostCentre, CostCentreStack ) import Outputable import FastString \end{code} things we want to find out: * should the labelled things be declared "static" (visible only in this file)? * should it be declared "const" (read-only text space)? * does it need declarations at all? (v common Prelude things are pre-declared) * what type does it have? (for generating accurate enough C declarations so that the C compiler won't complain). \begin{code} data CLabel = IdLabel -- A family of labels related to the Name -- definition of a particular Id IdLabelInfo | DataConLabel -- Ditto data constructors Name DataConLabelInfo | CaseLabel -- A family of labels related to a particular case expression Unique -- Unique says which case expression CaseLabelInfo | TyConLabel TyCon -- currently only one kind of TyconLabel, -- a 'Closure Table'. | AsmTempLabel Unique | 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 deriving (Eq, Ord) \end{code} \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) -- Ticky-ticky counting | RednCounts -- Label of place to keep reduction-count info for -- this Id deriving (Eq, Ord) data DataConLabelInfo = ConEntry -- the only kind of entry pt for constructors | ConInfoTbl -- corresponding info table | StaticConEntry -- static constructor entry point | StaticInfoTbl -- corresponding info table deriving (Eq, Ord) data CaseLabelInfo = CaseReturnPt | CaseReturnInfo | CaseVecTbl | CaseAlt ConTag | CaseDefault | CaseBitmap deriving (Eq, Ord) data RtsLabelInfo = RtsShouldNeverHappenCode | RtsBlackHoleInfoTbl FastString -- black hole with info table name | 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-} | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks | RtsApEntry Bool{-updatable-} Int{-arity-} | RtsPrimOp PrimOp | RtsTopTickyCtr | RtsModuleRegd deriving (Eq, Ord) -- Label Type: for generating C declarations. data CLabelType = InfoTblType | ClosureType | VecTblType | ClosureTblType | CodeType | DataType \end{code} \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) mkRednCountsLabel id = IdLabel id RednCounts mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl mkConInfoTableLabel con = DataConLabel con ConInfoTbl mkConEntryLabel con = DataConLabel con ConEntry mkStaticConEntryLabel con = DataConLabel con StaticConEntry mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt 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 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 mkCCS_Label ccs = CCS_Label ccs \end{code} \begin{code} needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation externallyVisibleCLabel :: CLabel -> Bool -- not C "static" \end{code} @needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish object. {\em Also:} No need to spit out labels for things generated by the flattener (in @AbsCUtils@)---it is careful to ensure references to them are always backwards. These are return-point and vector-table labels. Declarations for (non-prelude) @Id@-based things are needed because of mutual recursion. Declarations for direct return points are needed, because they may be let-no-escapes, which can be recursive. \begin{code} needsCDecl (IdLabel _ _) = True needsCDecl (CaseLabel _ CaseReturnPt) = True needsCDecl (DataConLabel _ _) = True needsCDecl (TyConLabel _) = True needsCDecl (ModuleInitLabel _ _) = True needsCDecl (PlainModuleInitLabel _) = True needsCDecl (CaseLabel _ _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False needsCDecl (ForeignLabel _ _) = False needsCDecl (CC_Label _) = False needsCDecl (CCS_Label _) = False \end{code} Whether the label is an assembler temporary: \begin{code} isAsmTemp (AsmTempLabel _) = True isAsmTemp _ = False \end{code} C ``static'' 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. \begin{code} externallyVisibleCLabel (DataConLabel _ _) = True externallyVisibleCLabel (TyConLabel tc) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (ModuleInitLabel _ _)= True externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack externallyVisibleCLabel (RtsLabel _) = True 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... \begin{code} labelType :: CLabel -> CLabelType 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 (PlainModuleInitLabel _) = CodeType labelType (IdLabel _ info) = case info of InfoTbl -> InfoTblType Closure -> ClosureType _ -> CodeType labelType (DataConLabel _ info) = case info of ConInfoTbl -> InfoTblType StaticInfoTbl -> InfoTblType _ -> CodeType labelType _ = DataType \end{code} When referring to data in code, we need to know whether that data resides in a DLL or not. [Win32 only.] @labelDynamic@ returns @True@ if the label is located in a DLL, be it a data reference or not. \begin{code} labelDynamic :: CLabel -> Bool labelDynamic lbl = case lbl of -- 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} OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the right places. It is used to detect when the abstractC statement of an CCodeBlock actually contains the code for a slow entry point. -- HWL We need at least @Eq@ for @CLabels@, because we want to avoid duplicate declarations in generating C (see @labelSeenTE@ in @PprAbsC@). ----------------------------------------------------------------------------- Printing out CLabels. Convention: _ where is _ for external names and for internal names. is one of the following: info Info table srt Static reference table entry Entry code ret Direct return address vtbl Vector table _alt Case alternative (tag n) dflt Default case alternative btm Large bitmap vector 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} pprCLabel :: CLabel -> SDoc #if ! OMIT_NATIVE_CODEGEN pprCLabel (AsmTempLabel u) = text (fmtAsmLbl (show u)) #endif pprCLabel lbl = #if ! OMIT_NATIVE_CODEGEN getPprStyle $ \ sty -> if asmStyle sty && underscorePrefix then pp_cSEP <> pprCLbl lbl else #endif pprCLbl lbl pprCLbl (CaseLabel u CaseReturnPt) = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")] pprCLbl (CaseLabel u CaseReturnInfo) = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")] pprCLbl (CaseLabel u CaseVecTbl) = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")] 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("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 RtsTopTickyCtr) = ptext SLIT("top_ct") pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ftext info pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd 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("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("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("stg_ap_"), text (show arity), ptext (if upd_reqd then SLIT("_upd_entry") else SLIT("_noupd_entry")) ] pprCLbl (RtsLabel (RtsPrimOp primop)) = 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")] pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs 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 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) RednCounts -> ptext SLIT("ct") ) ppConFlavor x = pp_cSEP <> (case x of ConEntry -> ptext SLIT("con_entry") ConInfoTbl -> ptext SLIT("con_info") StaticConEntry -> ptext SLIT("static_entry") StaticInfoTbl -> ptext SLIT("static_info") ) \end{code}