%
-% (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:
* 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}
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:
+
+ <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+ info Info table
+ srt Static reference table
+ entry Entry code
+ ret Direct return address
+ vtbl Vector table
+ <n>_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}
+
projects / ghc-hetmet.git / blobdiff