X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=c8712f5f17a94e7a5ec8680b7def072129eecafb;hb=fb7a723bfd7650a705cb226e07c5b08b7a8e9279;hp=74d214424385e81e87303b2cbe778ae49fd77199;hpb=68afb16743cafd5b7495771d359891c6dfc5a186;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 74d2144..c8712f5 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,78 +1,98 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +% $Id: CLabel.lhs,v 1.47 2001/09/04 18:29:20 ken Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} \begin{code} -#include "HsVersions.h" - module CLabel ( CLabel, -- abstract type mkClosureLabel, + mkSRTLabel, mkInfoTableLabel, mkStdEntryLabel, mkFastEntryLabel, mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, - mkPhantomInfoTableLabel, + mkConInfoTableLabel, mkStaticInfoTableLabel, - mkVapEntryLabel, - mkVapInfoTableLabel, - - mkConUpdCodePtrVecLabel, - mkStdUpdCodePtrVecLabel, - - mkInfoTableVecTblLabel, - mkStdUpdVecTblLabel, + mkApEntryLabel, + mkApInfoTableLabel, mkReturnPtLabel, + mkReturnInfoLabel, mkVecTblLabel, mkAltLabel, mkDefaultLabel, + mkBitmapLabel, + + mkClosureTblLabel, mkAsmTempLabel, + mkModuleInitLabel, + mkErrorStdEntryLabel, + + mkStgUpdatePAPLabel, + mkSplitMarkerLabel, + mkUpdInfoLabel, + mkSeqInfoLabel, + mkIndInfoLabel, + mkIndStaticInfoLabel, + mkRtsGCEntryLabel, + mkMainRegTableLabel, + mkCharlikeClosureLabel, + mkIntlikeClosureLabel, + mkMAP_FROZEN_infoLabel, + mkEMPTY_MVAR_infoLabel, + + mkTopTickyCtrLabel, mkBlackHoleInfoTableLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, + mkRtsPrimOpLabel, + + moduleRegdLabel, + + mkSelectorInfoLabel, + mkSelectorEntryLabel, + + mkForeignLabel, - needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, + mkCC_Label, mkCCS_Label, + + needsCDecl, isAsmTemp, externallyVisibleCLabel, + + CLabelType(..), labelType, labelDynamic, pprCLabel #if ! OMIT_NATIVE_CODEGEN , pprCLabel_asm #endif - -#ifdef GRAN - , isSlowEntryCCodeBlock -#endif ) where -import Ubiq{-uitous-} -import AbsCLoop ( CtrlReturnConvention(..), - ctrlReturnConvAlg - ) + +#include "HsVersions.h" + #if ! OMIT_NATIVE_CODEGEN -import NcgLoop ( underscorePrefix, fmtAsmLbl ) +import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) #endif +import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) -import Id ( externallyVisibleId, cmpId_withSpecDataCon, - isDataCon, isDictFunId, - isConstMethodId_maybe, - isDefaultMethodId_maybe, - isSuperDictSelId_maybe, fIRST_TAG, - ConTag(..), GenId{-instance Outputable-} - ) -import Maybes ( maybeToBool ) -import PprStyle ( PprStyle(..) ) -import PprType ( showTyCon, GenType{-instance Outputable-} ) -import Pretty ( prettyToUn ) -import TyCon ( TyCon{-instance Eq-} ) -import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) -import Unpretty -- NOTE!! ******************** -import Util ( assertPanic ) +import DataCon ( ConTag ) +import Module ( moduleName, moduleNameFS, + Module, isHomeModule ) +import Name ( Name, getName, isDllName, isExternallyVisibleName ) +import TyCon ( TyCon ) +import Unique ( pprUnique, Unique ) +import PrimOp ( PrimOp ) +import CostCentre ( CostCentre, CostCentreStack ) +import Outputable \end{code} things we want to find out: @@ -83,157 +103,189 @@ things we want to find out: * 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 - CLabelId -- definition of a particular Id - IdLabelInfo -- Includes DataCon + Name -- definition of a particular Id + IdLabelInfo - | TyConLabel -- A family of labels related to the - TyCon -- definition of a data type - TyConLabelInfo + | 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 + | RtsLabel RtsLabelInfo - deriving (Eq, Ord) -\end{code} + | ForeignLabel FAST_STRING Bool -- a 'C' (or otherwise foreign) label + -- Bool <=> is dynamic -The CLabelId is simply so we can declare alternative Eq and Ord -instances which use cmpId_SpecDataCon (instead of cmpId). This avoids -comparing the Uniques of two specialised data constructors (which have -the same as the uniques their respective unspecialised data -constructors). Instead, the specialising types and the uniques of the -unspecialised constructors are compared. + | CC_Label CostCentre + | CCS_Label CostCentreStack -\begin{code} -data CLabelId = CLabelId Id - -instance Eq CLabelId where - CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False } - CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True } - -instance Ord CLabelId where - CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> True; GT__ -> False } - CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> False; GT__ -> False } - CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> True; GT__ -> True } - CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b - of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + 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 (requires arg satis check) + | 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) - | ConEntry -- the only kind of entry pt for constructors - | StaticConEntry -- static constructor entry point - - | StaticInfoTbl -- corresponding info table - - | PhantomInfoTbl -- for phantom constructors that only exist in regs - - | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version - | VapEntry Bool - - -- Ticky-ticky counting - | RednCounts -- Label of place to keep reduction-count info for this Id + -- Ticky-ticky counting + | RednCounts -- Label of place to keep reduction-count info for + -- this Id deriving (Eq, Ord) - -data TyConLabelInfo - = UnvecConUpdCode -- Update code for the data type if it's unvectored - - | VecConUpdCode ConTag -- One for each constructor which returns in - -- regs; this code actually performs an update - - | StdUpdCode ConTag -- Update code for all constructors which return - -- in heap. There are a small number of variants, - -- so that the update code returns (vectored/n or - -- unvectored) in the right way. - -- ToDo: maybe replace TyCon/Int with return conv. - - | InfoTblVecTbl -- For tables of info tables - - | StdUpdVecTbl -- Labels the update code, or table of update codes, - -- for a particular type. +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 + | RtsBlackHoleInfoTbl FAST_STRING -- 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 + | RtsMainRegTable -- MainRegTable (??? Capabilities wurble ???) + | 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-} - | RtsSelectorInfoTbl -- Selectors - Bool -- True <=> the update-reqd version; - -- False <=> the no-update-reqd version - Int -- 0-indexed Offset from the "goods" + | RtsPrimOp PrimOp + + | RtsTopTickyCtr + + | RtsModuleRegd - | RtsSelectorEntry -- Ditto entry code - Bool - Int deriving (Eq, Ord) + +-- Label Type: for generating C declarations. + +data CLabelType + = InfoTblType + | ClosureType + | VecTblType + | ClosureTblType + | CodeType + | DataType \end{code} \begin{code} -mkClosureLabel id = IdLabel (CLabelId id) Closure -mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl -mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd +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 (CLabelId id) (EntryFast arity) -mkConEntryLabel id = IdLabel (CLabelId id) ConEntry -mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry -mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts -mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl -mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl -mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) -mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) + IdLabel id (EntryFast arity) + +mkRednCountsLabel id = IdLabel id RednCounts -mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag) -mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag) +mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl +mkConInfoTableLabel con = DataConLabel con ConInfoTbl +mkConEntryLabel con = DataConLabel con ConEntry +mkStaticConEntryLabel con = DataConLabel con StaticConEntry -mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl -mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl 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 + -- Some fixed runtime system labels -mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode -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) +mkMainRegTableLabel = RtsLabel RtsMainRegTable +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("stg_BLACKHOLE_info")) +mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info")) +mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then + 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) + +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 :: FAST_STRING -> 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 -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} @@ -246,160 +298,257 @@ labels. Declarations for (non-prelude) @Id@-based things are needed because of mutual recursion. -\begin{code} -needsCDecl (IdLabel _ _) = True -needsCDecl (CaseLabel _ _) = False - -needsCDecl (TyConLabel _ (StdUpdCode _)) = False -needsCDecl (TyConLabel _ InfoTblVecTbl) = False -needsCDecl (TyConLabel _ other) = True -needsCDecl (AsmTempLabel _) = False -needsCDecl (RtsLabel _) = False - -needsCDecl other = True -\end{code} +Declarations for direct return points are needed, because they may be +let-no-escapes, which can be recursive. -Whether the labelled thing can be put in C "text space": \begin{code} -isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes -isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other -isReadOnly (IdLabel _ PhantomInfoTbl) = True -isReadOnly (IdLabel _ (VapInfoTbl _)) = True -isReadOnly (IdLabel _ other) = False -- others: pessimistically, no - -isReadOnly (TyConLabel _ _) = True -isReadOnly (CaseLabel _ _) = True -isReadOnly (AsmTempLabel _) = True -isReadOnly (RtsLabel _) = True +needsCDecl (IdLabel _ _) = True +needsCDecl (CaseLabel _ CaseReturnPt) = True +needsCDecl (DataConLabel _ _) = True +needsCDecl (TyConLabel _) = True +needsCDecl (ModuleInitLabel _) = 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 (TyConLabel tc _) = True -externallyVisibleCLabel (CaseLabel _ _) = False -externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (IdLabel (CLabelId id) _) - | isDataCon id = True - | is_ConstMethodId id = True -- These are here to ensure splitting works - | isDictFunId id = True -- when these values have not been exported - | is_DefaultMethodId id = True - | is_SuperDictSelId id = True - | otherwise = externallyVisibleId id - where - is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) - is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id) - is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) +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 (ForeignLabel _ _) = True +externallyVisibleCLabel (IdLabel id _) = isExternallyVisibleName id +externallyVisibleCLabel (CC_Label _) = False -- not strictly true +externallyVisibleCLabel (CCS_Label _) = False -- not strictly true \end{code} -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 +For generating correct types in label declarations... \begin{code} -#ifdef GRAN +labelType :: CLabel -> CLabelType +labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType +labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType +labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType +labelType (RtsLabel RtsUpdInfo) = 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 + InfoTbl -> InfoTblType + Closure -> ClosureType + _ -> CodeType + +labelType (DataConLabel _ info) = + case info of + ConInfoTbl -> InfoTblType + StaticInfoTbl -> InfoTblType + _ -> CodeType + +labelType _ = DataType +\end{code} -isSlowEntryCCodeBlock :: CLabel -> Bool -isSlowEntryCCodeBlock _ = False --- Worth keeping? ToDo (WDP) +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. -#endif {-GRAN-} +\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)) + _ -> 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} -- specialised for PprAsm: saves lots of arg passing in NCG #if ! OMIT_NATIVE_CODEGEN -pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) +pprCLabel_asm = pprCLabel #endif -pprCLabel :: PprStyle -> CLabel -> Unpretty - -pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) - = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) - -pprCLabel (PprForAsm prepend_cSEP _) lbl - = if prepend_cSEP - then uppBeside pp_cSEP prLbl - else prLbl - where - prLbl = pprCLabel PprForC lbl - -pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), - pp_cSEP, uppPStr SLIT("upd")] - -pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP, - uppInt tag, pp_cSEP, uppPStr SLIT("upd")] - -pprCLabel sty (TyConLabel tc (StdUpdCode tag)) - = case (ctrlReturnConvAlg tc) of - UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir") - VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) - -pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")] - -pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), - pp_cSEP, uppPStr SLIT("upd")] - -pprCLabel sty (CaseLabel u CaseReturnPt) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u CaseVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u (CaseAlt tag)) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag] -pprCLabel sty (CaseLabel u CaseDefault) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u] - -pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode") - -pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") +pprCLabel :: CLabel -> SDoc -pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), - uppPStr SLIT("__")] - -pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), - uppPStr SLIT("__")] - -pprCLabel sty (IdLabel (CLabelId id) flavor) - = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor) - -ppr_u u = prettyToUn (pprUnique u) - -ppFlavor :: IdLabelInfo -> Unpretty +#if ! OMIT_NATIVE_CODEGEN +pprCLabel (AsmTempLabel u) + = text (fmtAsmLbl (show u)) +#endif -ppFlavor x = uppBeside pp_cSEP - (case x of - Closure -> uppPStr SLIT("closure") - InfoTbl -> uppPStr SLIT("info") - EntryStd -> uppPStr SLIT("entry") +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 RtsMainRegTable) = ptext SLIT("MainRegTable") +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("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 _) + = ptext 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) + = ptext SLIT("__stginit_") <> ptext (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) - uppBeside (uppPStr SLIT("fast")) (uppInt arity) - ConEntry -> uppPStr SLIT("entry") - StaticConEntry -> uppPStr SLIT("static_entry") - StaticInfoTbl -> uppPStr SLIT("static_info") - PhantomInfoTbl -> uppPStr SLIT("inregs_info") - VapInfoTbl True -> uppPStr SLIT("vap_info") - VapInfoTbl False -> uppPStr SLIT("vap_noupd_info") - VapEntry True -> uppPStr SLIT("vap_entry") - VapEntry False -> uppPStr SLIT("vap_noupd_entry") - RednCounts -> uppPStr SLIT("ct") + (<>) (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} +