summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Cmm')
-rw-r--r--compiler/GHC/Cmm/CLabel.hs63
-rw-r--r--compiler/GHC/Cmm/CLabel.hs-boot2
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs18
-rw-r--r--compiler/GHC/Cmm/Reg.hs5
4 files changed, 55 insertions, 33 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 6d4397e62b..5fd6378678 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -307,12 +307,14 @@ data ModuleLabelKind
| MLK_IPEBuffer
deriving (Eq, Ord)
-instance Outputable ModuleLabelKind where
- ppr MLK_InitializerArray = text "init_arr"
- ppr (MLK_Initializer s) = text ("init__" ++ s)
- ppr MLK_FinalizerArray = text "fini_arr"
- ppr (MLK_Finalizer s) = text ("fini__" ++ s)
- ppr MLK_IPEBuffer = text "ipe_buf"
+pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc
+pprModuleLabelKind MLK_InitializerArray = text "init_arr"
+pprModuleLabelKind (MLK_Initializer s) = text ("init__" ++ s)
+pprModuleLabelKind MLK_FinalizerArray = text "fini_arr"
+pprModuleLabelKind (MLK_Finalizer s) = text ("fini__" ++ s)
+pprModuleLabelKind MLK_IPEBuffer = text "ipe_buf"
+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-}
+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
isIdLabel :: CLabel -> Bool
isIdLabel IdLabel{} = True
@@ -1416,7 +1418,7 @@ allocation. Take care if you want to remove them!
-}
-pprAsmLabel :: Platform -> CLabel -> SDoc
+pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc
pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl
instance OutputableP Platform CLabel where
@@ -1426,19 +1428,19 @@ instance OutputableP Platform CLabel where
PprDump{} -> pprCLabel platform CStyle lbl
_ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc
pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
let
!use_leading_underscores = platformLeadingUnderscore platform
-- some platform (e.g. Darwin) require a leading "_" for exported asm
-- symbols
- maybe_underscore :: SDoc -> SDoc
+ maybe_underscore :: doc -> doc
maybe_underscore doc = case sty of
AsmStyle | use_leading_underscores -> pp_cSEP <> doc
_ -> doc
- tempLabelPrefixOrUnderscore :: SDoc
+ tempLabelPrefixOrUnderscore :: doc
tempLabelPrefixOrUnderscore = case sty of
AsmStyle -> asmTempLabelPrefix platform
CStyle -> char '_'
@@ -1490,14 +1492,14 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
IdLabel name _cafs flavor -> case sty of
- AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor
+ AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor
where
isRandomGenerated = not (isExternalName name)
internalNamePrefix =
if isRandomGenerated
then asmTempLabelPrefix platform
else empty
- CStyle -> ppr name <> ppIdFlavor flavor
+ CStyle -> pprName name <> ppIdFlavor flavor
SRTLabel u
-> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
@@ -1534,7 +1536,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
]
RtsLabel (RtsPrimOp primop)
- -> maybe_underscore $ text "stg_" <> ppr primop
+ -> maybe_underscore $ text "stg_" <> pprPrimOp primop
RtsLabel (RtsSlowFastTickyCtr pat)
-> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"
@@ -1552,12 +1554,12 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
-- with a letter so the label will be legal assembly code.
HpcTicksLabel mod
- -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc"
+ -> maybe_underscore $ text "_hpc_tickboxes_" <> pprModule mod <> text "_hpc"
- CC_Label cc -> maybe_underscore $ ppr cc
- CCS_Label ccs -> maybe_underscore $ ppr ccs
- IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> ppr m <> text "_ipe")
- ModuleLabel mod kind -> maybe_underscore $ ppr mod <> text "_" <> ppr kind
+ CC_Label cc -> maybe_underscore $ pprCostCentre cc
+ CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs
+ IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> pprModule m <> text "_ipe")
+ ModuleLabel mod kind -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind
CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs
CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs
@@ -1567,6 +1569,8 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info"
CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret"
CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure"
+{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- Note [Internal proc labels]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1587,21 +1591,24 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
-- | Generate a label for a procedure internal to a module (if
-- 'Opt_ExposeAllSymbols' is enabled).
-- See Note [Internal proc labels].
-ppInternalProcLabel :: Module -- ^ the current module
+ppInternalProcLabel :: IsLine doc
+ => Module -- ^ the current module
-> CLabel
- -> Maybe SDoc -- ^ the internal proc label
+ -> Maybe doc -- ^ the internal proc label
ppInternalProcLabel this_mod (IdLabel nm _ flavour)
| isInternalName nm
= Just
- $ text "_" <> ppr this_mod
+ $ text "_" <> pprModule this_mod
<> char '_'
<> ztext (zEncodeFS (occNameFS (occName nm)))
<> char '_'
<> pprUniqueAlways (getUnique nm)
<> ppIdFlavor flavour
ppInternalProcLabel _ _ = Nothing
+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-}
+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor :: IsLine doc => IdLabelInfo -> doc
ppIdFlavor x = pp_cSEP <> case x of
Closure -> text "closure"
InfoTable -> text "info"
@@ -1612,22 +1619,22 @@ ppIdFlavor x = pp_cSEP <> case x of
IdTickyInfo TickyRednCounts
-> text "ct"
IdTickyInfo (TickyInferedTag unique)
- -> text "ct_inf_tag" <> char '_' <> ppr unique
+ -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique
ConEntry loc ->
case loc of
DefinitionSite -> text "con_entry"
UsageSite m n ->
- ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"
+ pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry"
ConInfoTable k ->
case k of
DefinitionSite -> text "con_info"
UsageSite m n ->
- ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"
+ pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info"
ClosureTable -> text "closure_tbl"
Bytes -> text "bytes"
BlockInfoTable -> text "info"
-pp_cSEP :: SDoc
+pp_cSEP :: IsLine doc => doc
pp_cSEP = char '_'
@@ -1641,13 +1648,13 @@ instance Outputable ForeignLabelSource where
-- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels.
-asmTempLabelPrefix :: Platform -> SDoc -- for formatting labels
+asmTempLabelPrefix :: IsLine doc => Platform -> doc -- for formatting labels
asmTempLabelPrefix !platform = case platformOS platform of
OSDarwin -> text "L"
OSAIX -> text "__L" -- follow IBM XL C's convention
_ -> text ".L"
-pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc
+pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc
pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
case platformOS platform of
OSDarwin
diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot
index 8fb1b74423..4a5ec3dde3 100644
--- a/compiler/GHC/Cmm/CLabel.hs-boot
+++ b/compiler/GHC/Cmm/CLabel.hs-boot
@@ -5,5 +5,5 @@ import GHC.Platform
data CLabel
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel :: IsLine doc => Platform -> LabelStyle -> CLabel -> doc
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 3a7ceb7746..bfcb16bff9 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -29,7 +29,8 @@ module GHC.Cmm.DebugBlock (
-- * Unwinding information
UnwindTable, UnwindPoint(..),
- UnwindExpr(..), toUnwindExpr
+ UnwindExpr(..), toUnwindExpr,
+ pprUnwindTable
) where
import GHC.Prelude
@@ -38,6 +39,7 @@ import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
+import GHC.Cmm.Reg ( pprGlobalReg )
import GHC.Cmm.Utils
import GHC.Data.FastString ( nilFS, mkFastString )
import GHC.Unit.Module
@@ -522,10 +524,18 @@ data UnwindExpr = UwConst !Int -- ^ literal value
instance OutputableP Platform UnwindExpr where
pdoc = pprUnwindExpr 0
-pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc
+pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc
+pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u))))
+ where print_entry (reg, Nothing) =
+ parens (sep [pprGlobalReg reg, text "Nothing"])
+ print_entry (reg, Just x) =
+ parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x])
+ -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr))
+
+pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr p env = \case
UwConst i -> int i
- UwReg g 0 -> ppr g
+ UwReg g 0 -> pprGlobalReg g
UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))
UwDeref e -> char '*' <> pprUnwindExpr 3 env e
UwLabel l -> pprAsmLabel env l
@@ -536,6 +546,8 @@ pprUnwindExpr p env = \case
UwTimes e0 e1
| p <= 1 -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1
other -> parens (pprUnwindExpr 0 env other)
+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}
+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs
index 6c94ecb2eb..a9b3fce101 100644
--- a/compiler/GHC/Cmm/Reg.hs
+++ b/compiler/GHC/Cmm/Reg.hs
@@ -12,6 +12,7 @@ module GHC.Cmm.Reg
, localRegType
-- * Global registers
, GlobalReg(..), isArgReg, globalRegType
+ , pprGlobalReg
, spReg, hpReg, spLimReg, hpLimReg, nodeReg
, currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
, node, baseReg
@@ -296,7 +297,7 @@ instance Outputable GlobalReg where
instance OutputableP env GlobalReg where
pdoc _ = ppr
-pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg :: IsLine doc => GlobalReg -> doc
pprGlobalReg gr
= case gr of
VanillaReg n _ -> char 'R' <> int n
@@ -324,6 +325,8 @@ pprGlobalReg gr
GCFun -> text "stg_gc_fun"
BaseReg -> text "BaseReg"
PicBaseReg -> text "PicBaseReg"
+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-}
+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- convenient aliases
View Lorry Controller Status