summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2022-10-13 19:47:27 -0500
committerKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2022-11-11 19:18:39 +0100
commit3c37d30b07fc85fe09452f4ce250aec42cb1d2e4 (patch)
treea5e36e0e66d1c221ed2d018b5c5c7fd82943f38c /compiler
parentd0c691b6110b11a43d5ea2685d17bc001d2298da (diff)
downloadhaskell-3c37d30b07fc85fe09452f4ce250aec42cb1d2e4.tar.gz
Use a more efficient printer for code generation (#21853)
The changes in `GHC.Utils.Outputable` are the bulk of the patch and drive the rest. The types `HLine` and `HDoc` in Outputable can be used instead of `SDoc` and support printing directly to a handle with `bPutHDoc`. See Note [SDoc versus HDoc] and Note [HLine versus HDoc]. The classes `IsLine` and `IsDoc` are used to make the existing code polymorphic over `HLine`/`HDoc` and `SDoc`. This is done for X86, PPC, AArch64, DWARF and dependencies (printing module names, labels etc.). Co-authored-by: Alexis King <lexi.lambda@gmail.com> Metric Decrease: CoOpt_Read ManyAlternatives ManyConstructors T10421 T12425 T12707 T13035 T13056 T13253 T13379 T18140 T18282 T18698a T18698b T1969 T20049 T21839c T21839r T3064 T3294 T4801 T5321FD T5321Fun T5631 T6048 T783 T9198 T9233
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs5
-rw-r--r--compiler/GHC/ByteCode/Types.hs3
-rw-r--r--compiler/GHC/Cmm/CLabel.hs69
-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
-rw-r--r--compiler/GHC/CmmToAsm.hs57
-rw-r--r--compiler/GHC/CmmToAsm/AArch64.hs6
-rw-r--r--compiler/GHC/CmmToAsm/AArch64/Ppr.hs156
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf.hs63
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf/Constants.hs31
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf/Types.hs149
-rw-r--r--compiler/GHC/CmmToAsm/Instr.hs3
-rw-r--r--compiler/GHC/CmmToAsm/Monad.hs38
-rw-r--r--compiler/GHC/CmmToAsm/PIC.hs34
-rw-r--r--compiler/GHC/CmmToAsm/PPC.hs3
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs2
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Instr.hs4
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Ppr.hs256
-rw-r--r--compiler/GHC/CmmToAsm/Ppr.hs52
-rw-r--r--compiler/GHC/CmmToAsm/X86.hs3
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs2
-rw-r--r--compiler/GHC/CmmToAsm/X86/Instr.hs2
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs232
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Iteration.hs1
-rw-r--r--compiler/GHC/Linker/Types.hs4
-rw-r--r--compiler/GHC/Types/CostCentre.hs43
-rw-r--r--compiler/GHC/Types/ForeignStubs.hs5
-rw-r--r--compiler/GHC/Types/Name.hs46
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs8
-rw-r--r--compiler/GHC/Types/Unique.hs4
-rw-r--r--compiler/GHC/Unit/Types.hs39
-rw-r--r--compiler/GHC/Utils/Asm.hs5
-rw-r--r--compiler/GHC/Utils/BufHandle.hs21
-rw-r--r--compiler/GHC/Utils/Outputable.hs540
35 files changed, 1213 insertions, 698 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index ecd9da0ac2..8b4fc099cd 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -11,6 +11,7 @@ module GHC.Builtin.PrimOps (
primOpType, primOpSig, primOpResultType,
primOpTag, maxPrimOpTag, primOpOcc,
primOpWrapperId,
+ pprPrimOp,
tagToEnumKey,
@@ -788,8 +789,10 @@ compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy
-- Output stuff:
-pprPrimOp :: PrimOp -> SDoc
+pprPrimOp :: IsLine doc => PrimOp -> doc
pprPrimOp other_op = pprOccName (primOpOcc other_op)
+{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-}
+{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
{-
************************************************************************
diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs
index 6eb661ac18..830b60a4ca 100644
--- a/compiler/GHC/ByteCode/Types.hs
+++ b/compiler/GHC/ByteCode/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -115,7 +116,7 @@ instance Outputable TupleInfo where
ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>
text "stack" <+> ppr tupleNativeStackSize <+>
text "regs" <+>
- ppr (map (text.show) $ regSetToList tupleRegs) <>
+ ppr (map (text @SDoc . show) $ regSetToList tupleRegs) <>
char '>'
voidTupleInfo :: TupleInfo
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 83555e9227..96f78b6789 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 (LexicalFastString s)) = text "init__" <> ftext s
- ppr MLK_FinalizerArray = text "fini_arr"
- ppr (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s
- ppr MLK_IPEBuffer = text "ipe_buf"
+pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc
+pprModuleLabelKind MLK_InitializerArray = text "init_arr"
+pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s
+pprModuleLabelKind MLK_FinalizerArray = text "fini_arr"
+pprModuleLabelKind (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext 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
@@ -1431,11 +1433,15 @@ data LabelStyle
= CStyle -- ^ C label style (used by C and LLVM backends)
| AsmStyle -- ^ Asm label style (used by NCG backend)
-pprAsmLabel :: Platform -> CLabel -> SDoc
+pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc
pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl
+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprCLabel :: Platform -> CLabel -> SDoc
+pprCLabel :: IsLine doc => Platform -> CLabel -> doc
pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl
+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
instance OutputableP Platform CLabel where
{-# INLINE pdoc #-} -- see Note [Bangs in CLabel]
@@ -1444,19 +1450,19 @@ instance OutputableP Platform CLabel where
PprDump{} -> pprCLabel platform lbl
_ -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl)
-pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc
pprCLabelStyle !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 '_'
@@ -1508,14 +1514,14 @@ pprCLabelStyle !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"
@@ -1552,7 +1558,7 @@ pprCLabelStyle !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"
@@ -1570,12 +1576,12 @@ pprCLabelStyle !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 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 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
@@ -1585,6 +1591,8 @@ pprCLabelStyle !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 pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- Note [Internal proc labels]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1605,21 +1613,24 @@ pprCLabelStyle !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"
@@ -1630,22 +1641,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 '_'
@@ -1659,13 +1670,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 cca3ce684e..028e0a63fb 100644
--- a/compiler/GHC/Cmm/CLabel.hs-boot
+++ b/compiler/GHC/Cmm/CLabel.hs-boot
@@ -5,4 +5,4 @@ import GHC.Platform
data CLabel
-pprCLabel :: Platform -> CLabel -> SDoc
+pprCLabel :: IsLine doc => Platform -> 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
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 37d77900ba..5de914fcc9 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -126,7 +126,6 @@ import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Utils.Logger
-import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.BufHandle
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
@@ -146,6 +145,7 @@ import Data.Maybe
import Data.Ord ( comparing )
import Control.Monad
import System.IO
+import System.Directory ( getCurrentDirectory )
--------------------
nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply
@@ -244,16 +244,17 @@ finishNativeGen :: Instruction instr
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
-finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs
+finishNativeGen logger config modLoc bufh us ngs
= withTimingSilent logger (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
us' <- if not (ncgDwarfEnabled config)
then return us
else do
- (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)
- emitNativeCode logger config bufh dwarf
+ compPath <- getCurrentDirectory
+ let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)
+ (dwarf_s, _) = dwarfGen compPath config modLoc us (ngs_debug ngs)
+ emitNativeCode logger config bufh dwarf_h dwarf_s
return us'
- bFlush bufh
-- dump global NCG stats for graph coloring allocator
let stats = concat (ngs_colorStats ngs)
@@ -286,8 +287,9 @@ finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs
-- write out the imports
let ctx = ncgAsmContext config
- printSDocLn ctx Pretty.LeftMode h
- $ makeImportsDoc config (concat (ngs_imports ngs))
+ bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))
+ bFlush bufh
+
return us'
where
dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)
@@ -389,12 +391,17 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
let newFileIds = sortBy (comparing snd) $
nonDetEltsUFM $ fileIds' `minusUFM` fileIds
-- See Note [Unique Determinism and code generation]
- pprDecl (f,n) = text "\t.file " <> int n <+>
- pprFilePathString (unpackFS f)
-
- emitNativeCode logger config h $ vcat $
- map pprDecl newFileIds ++
- map (pprNatCmmDecl ncgImpl) native
+ pprDecl (f,n) = line $ text "\t.file " <> int n <+>
+ pprFilePathString (unpackFS f)
+
+ -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
+ emitNativeCode logger config h
+ (vcat $
+ map pprDecl newFileIds ++
+ map (pprNatCmmDeclH ncgImpl) native)
+ (vcat $
+ map pprDecl newFileIds ++
+ map (pprNatCmmDeclS ncgImpl) native)
-- force evaluation all this stuff to avoid space leaks
let platform = ncgPlatform config
@@ -417,11 +424,11 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
go us' cmms ngs' (count + 1)
-emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()
-emitNativeCode logger config h sdoc = do
-
+-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
+emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
+emitNativeCode logger config h hdoc sdoc = do
let ctx = ncgAsmContext config
- {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
+ {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc
-- dump native code
putDumpFileMaybe logger
@@ -485,7 +492,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
putDumpFileMaybe logger
Opt_D_dump_asm_native "Native code" FormatASM
- (vcat $ map (pprNatCmmDecl ncgImpl) native)
+ (vcat $ map (pprNatCmmDeclS ncgImpl) native)
maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name
@@ -542,7 +549,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
putDumpFileMaybe logger
Opt_D_dump_asm_regalloc "Registers allocated"
FormatCMM
- (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+ (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)
putDumpFileMaybe logger
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
@@ -586,7 +593,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
putDumpFileMaybe logger
Opt_D_dump_asm_regalloc "Registers allocated"
FormatCMM
- (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+ (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)
let mPprStats =
if logHasDumpFlag logger Opt_D_dump_asm_stats
@@ -738,7 +745,7 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-- | Build a doc for all the imports.
--
-makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
+makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc
makeImportsDoc config imports
= dyld_stubs imports
$$
@@ -746,7 +753,7 @@ makeImportsDoc config imports
-- dead-stripping of code and data on a per-symbol basis.
-- There's a hack to make this work in PprMach.pprNatCmmDecl.
(if platformHasSubsectionsViaSymbols platform
- then text ".subsections_via_symbols"
+ then line $ text ".subsections_via_symbols"
else Outputable.empty)
$$
-- On recent GNU ELF systems one can mark an object file
@@ -756,14 +763,14 @@ makeImportsDoc config imports
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack platform
- then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
+ then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
else Outputable.empty)
$$
-- And just because every other compiler does, let's stick in
-- an identifier directive: .ident "GHC x.y.z"
(if platformHasIdentDirective platform
then let compilerIdent = text "GHC" <+> text cProjectVersion
- in text ".ident" <+> doubleQuotes compilerIdent
+ in line $ text ".ident" <+> doubleQuotes compilerIdent
else Outputable.empty)
where
@@ -771,7 +778,7 @@ makeImportsDoc config imports
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
- dyld_stubs :: [CLabel] -> SDoc
+ dyld_stubs :: [CLabel] -> HDoc
-- (Hack) sometimes two Labels pretty-print the same, but have
-- different uniques; so we compare their text versions...
dyld_stubs imps
diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs
index 8b85b12ff6..d814764b2d 100644
--- a/compiler/GHC/CmmToAsm/AArch64.hs
+++ b/compiler/GHC/CmmToAsm/AArch64.hs
@@ -11,6 +11,7 @@ import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
+import GHC.Utils.Outputable (ftext)
import qualified GHC.CmmToAsm.AArch64.Instr as AArch64
import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64
@@ -28,7 +29,8 @@ ncgAArch64 config
,canShortcut = AArch64.canShortcut
,shortcutStatics = AArch64.shortcutStatics
,shortcutJump = AArch64.shortcutJump
- ,pprNatCmmDecl = AArch64.pprNatCmmDecl config
+ ,pprNatCmmDeclS = AArch64.pprNatCmmDecl config
+ ,pprNatCmmDeclH = AArch64.pprNatCmmDecl config
,maxSpillSlots = AArch64.maxSpillSlots config
,allocatableRegs = AArch64.allocatableRegs platform
,ncgAllocMoreStack = AArch64.allocMoreStack platform
@@ -55,5 +57,5 @@ instance Instruction AArch64.Instr where
mkJumpInstr = AArch64.mkJumpInstr
mkStackAllocInstr = AArch64.mkStackAllocInstr
mkStackDeallocInstr = AArch64.mkStackDeallocInstr
- mkComment = pure . AArch64.COMMENT
+ mkComment = pure . AArch64.COMMENT . ftext
pprInstr = AArch64.pprInstr
diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
index 9997b8fb52..e34dcfeae9 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
@@ -29,12 +29,12 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
-pprProcAlignment :: NCGConfig -> SDoc
+pprProcAlignment :: IsDoc doc => NCGConfig -> doc
pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
where
platform = ncgPlatform config
-pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc
+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
pprSectionAlign config section $$ pprDatas config dats
@@ -50,42 +50,45 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
(if ncgDwarfEnabled config
- then pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+ then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$
pprSizeDecl platform lbl
Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
-- pprProcAlignment config $$
(if platformHasSubsectionsViaSymbols platform
- then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':'
+ then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
else empty) $$
vcat (map (pprBasicBlock config top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
- text "\t.long "
+ line
+ $ text "\t.long "
<+> pprAsmLabel platform info_lbl
<+> char '-'
<+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprLabel :: Platform -> CLabel -> SDoc
+pprLabel :: IsDoc doc => Platform -> CLabel -> doc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeDecl platform lbl
- $$ (pprAsmLabel platform lbl <> char ':')
+ $$ line (pprAsmLabel platform lbl <> char ':')
-pprAlign :: Platform -> Alignment -> SDoc
+pprAlign :: IsDoc doc => Platform -> Alignment -> doc
pprAlign _platform alignment
- = text "\t.balign " <> int (alignmentBytes alignment)
+ = line $ text "\t.balign " <> int (alignmentBytes alignment)
-- | Print appropriate alignment for the given section type.
-pprAlignForSection :: Platform -> SectionType -> SDoc
+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
pprAlignForSection _platform _seg
-- .balign is stable, whereas .align is platform dependent.
- = text "\t.balign 8" -- always 8
+ = line (text "\t.balign 8") -- always 8
-- | Print section header and appropriate alignment for that section.
--
@@ -94,28 +97,28 @@ pprAlignForSection _platform _seg
-- .section .text
-- .balign 8
--
-pprSectionAlign :: NCGConfig -> Section -> SDoc
+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
pprSectionAlign _config (Section (OtherSection _) _) =
panic "AArch64.Ppr.pprSectionAlign: unknown section"
pprSectionAlign config sec@(Section seg _) =
- pprSectionHeader config sec
+ line (pprSectionHeader config sec)
$$ pprAlignForSection (ncgPlatform config) seg
-- | Output the ELF .size directive.
-pprSizeDecl :: Platform -> CLabel -> SDoc
+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl
+ then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
else empty
-pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
- -> SDoc
+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
+ -> doc
pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
(if ncgDwarfEnabled config
- then pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
+ then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')
else empty
)
where
@@ -135,7 +138,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform info_lbl $$
c $$
(if ncgDwarfEnabled config
- then pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':'
+ then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':')
else empty)
-- Make sure the info table has the right .loc for the block
-- coming right after it. See Note [Info Offset]
@@ -143,7 +146,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
(l@LOCATION{} : _) -> pprInstr platform l
_other -> empty
-pprDatas :: NCGConfig -> RawCmmStatics -> SDoc
+pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
@@ -153,29 +156,29 @@ pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl (ncgPlatform config) alias
- $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind'
+ $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
pprDatas config (CmmStaticsRaw lbl dats)
= vcat (pprLabel platform lbl : map (pprData config) dats)
where
platform = ncgPlatform config
-pprData :: NCGConfig -> CmmStatic -> SDoc
-pprData _config (CmmString str) = pprString str
-pprData _config (CmmFileEmbed path _) = pprFileEmbed path
+pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
+pprData _config (CmmString str) = line (pprString str)
+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
pprData config (CmmUninitialised bytes)
- = let platform = ncgPlatform config
- in if platformOS platform == OSDarwin
- then text ".space " <> int bytes
- else text ".skip " <> int bytes
+ = line $ let platform = ncgPlatform config
+ in if platformOS platform == OSDarwin
+ then text ".space " <> int bytes
+ else text ".skip " <> int bytes
pprData config (CmmStaticLit lit) = pprDataItem config lit
-pprGloblDecl :: Platform -> CLabel -> SDoc
+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text "\t.globl " <> pprAsmLabel platform lbl
+ | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)
-- Note [Always use objects for info tables]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -187,7 +190,7 @@ pprGloblDecl platform lbl
--
-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as
-- well.
-pprLabelType' :: Platform -> CLabel -> SDoc
+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc
pprLabelType' platform lbl =
if isCFunctionLabel lbl || functionOkInfoTable then
text "@function"
@@ -198,15 +201,15 @@ pprLabelType' platform lbl =
isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
-- this is called pprTypeAndSizeDecl in PPC.Ppr
-pprTypeDecl :: Platform -> CLabel -> SDoc
+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
- then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl
+ then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
else empty
-pprDataItem :: NCGConfig -> CmmLit -> SDoc
+pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc
pprDataItem config lit
- = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
+ = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
platform = ncgPlatform config
@@ -227,7 +230,7 @@ pprDataItem config lit
ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)
-pprImm :: Platform -> Imm -> SDoc
+pprImm :: IsLine doc => Platform -> Imm -> doc
pprImm _ (ImmInt i) = int i
pprImm _ (ImmInteger i) = integer i
pprImm p (ImmCLbl l) = pprAsmLabel p l
@@ -257,7 +260,7 @@ asmDoubleslashComment c = whenPprDebug $ text "//" <+> c
asmMultilineComment :: SDoc -> SDoc
asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"
-pprIm :: Platform -> Imm -> SDoc
+pprIm :: IsLine doc => Platform -> Imm -> doc
pprIm platform im = case im of
ImmInt i -> char '#' <> int i
ImmInteger i -> char '#' <> integer i
@@ -283,7 +286,7 @@ pprIm platform im = case im of
ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'
_ -> panic "AArch64.pprIm"
-pprExt :: ExtMode -> SDoc
+pprExt :: IsLine doc => ExtMode -> doc
pprExt EUXTB = text "uxtb"
pprExt EUXTH = text "uxth"
pprExt EUXTW = text "uxtw"
@@ -293,13 +296,13 @@ pprExt ESXTH = text "sxth"
pprExt ESXTW = text "sxtw"
pprExt ESXTX = text "sxtx"
-pprShift :: ShiftMode -> SDoc
+pprShift :: IsLine doc => ShiftMode -> doc
pprShift SLSL = text "lsl"
pprShift SLSR = text "lsr"
pprShift SASR = text "asr"
pprShift SROR = text "ror"
-pprOp :: Platform -> Operand -> SDoc
+pprOp :: IsLine doc => Platform -> Operand -> doc
pprOp plat op = case op of
OpReg w r -> pprReg w r
OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x
@@ -312,7 +315,7 @@ pprOp plat op = case op of
OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']'
OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']'
-pprReg :: Width -> Reg -> SDoc
+pprReg :: forall doc. IsLine doc => Width -> Reg -> doc
pprReg w r = case r of
RegReal (RealRegSingle i) -> ppr_reg_no w i
-- virtual regs should not show up, but this is helpful for debugging.
@@ -322,7 +325,7 @@ pprReg w r = case r of
_ -> pprPanic "AArch64.pprReg" (text $ show r)
where
- ppr_reg_no :: Width -> Int -> SDoc
+ ppr_reg_no :: Width -> Int -> doc
ppr_reg_no w 31
| w == W64 = text "sp"
| w == W32 = text "wsp"
@@ -351,24 +354,27 @@ isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True
isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True
isFloatOp _ = False
-pprInstr :: Platform -> Instr -> SDoc
+pprInstr :: IsDoc doc => Platform -> Instr -> doc
pprInstr platform instr = case instr of
-- Meta Instructions ---------------------------------------------------------
- COMMENT s -> asmComment s
- MULTILINE_COMMENT s -> asmMultilineComment s
- ANN d i -> pprInstr platform i <+> asmDoubleslashComment d
- LOCATION file line col _name
- -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col
- DELTA d -> asmComment $ text ("\tdelta = " ++ show d)
+ -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
+ COMMENT s -> dualDoc (asmComment s) empty
+ MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty
+ ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)
+
+ LOCATION file line' col _name
+ -> line (text "\t.loc" <+> int file <+> int line' <+> int col)
+ DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
+ -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"
LDATA _ _ -> panic "pprInstr: LDATA"
-- Pseudo Instructions -------------------------------------------------------
- PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!"
- $$ text "\tmov x29, sp"
+ PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!",
+ text "\tmov x29, sp"]
- POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16"
+ POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16"
-- ===========================================================================
-- AArch64 Instruction Set
-- 1. Arithmetic Instructions ------------------------------------------------
@@ -430,28 +436,28 @@ pprInstr platform instr = case instr of
-- 4. Branch Instructions ----------------------------------------------------
J t -> pprInstr platform (B t)
- B (TBlock bid) -> text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- B (TLabel lbl) -> text "\tb" <+> pprAsmLabel platform lbl
- B (TReg r) -> text "\tbr" <+> pprReg W64 r
+ B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl
+ B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r
- BL (TBlock bid) _ _ -> text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- BL (TLabel lbl) _ _ -> text "\tbl" <+> pprAsmLabel platform lbl
- BL (TReg r) _ _ -> text "\tblr" <+> pprReg W64 r
+ BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl
+ BL (TReg r) _ _ -> line $ text "\tblr" <+> pprReg W64 r
- BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pprAsmLabel platform lbl
+ BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl
BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!"
-- 5. Atomic Instructions ----------------------------------------------------
-- 6. Conditional Instructions -----------------------------------------------
- CSET o c -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c
+ CSET o c -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c
- CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
+ CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!"
- CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
- CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
+ CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
+ CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"
-- 7. Load and Store Instructions --------------------------------------------
@@ -532,23 +538,23 @@ pprInstr platform instr = case instr of
LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3
-- 8. Synchronization Instructions -------------------------------------------
- DMBSY -> text "\tdmb sy"
+ DMBSY -> line $ text "\tdmb sy"
-- 9. Floating Point Instructions --------------------------------------------
FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2
SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2
FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2
FABS o1 o2 -> op2 (text "\tfabs") o1 o2
- where op2 op o1 o2 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2
- op3 op o1 o2 o3 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
- op4 op o1 o2 o3 o4 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
- op_ldr o1 rest = text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"
- op_adrp o1 rest = text "\tadrp" <+> pprOp platform o1 <> comma <+> rest
- op_add o1 rest = text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest
-
-pprBcond :: Cond -> SDoc
+ where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2
+ op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
+ op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
+ op_ldr o1 rest = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"
+ op_adrp o1 rest = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest
+ op_add o1 rest = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest
+
+pprBcond :: IsLine doc => Cond -> doc
pprBcond c = text "b." <> pprCond c
-pprCond :: Cond -> SDoc
+pprCond :: IsLine doc => Cond -> doc
pprCond c = case c of
ALWAYS -> text "al" -- Always
EQ -> text "eq" -- Equal
diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs
index 407050d045..0eef6ecb49 100644
--- a/compiler/GHC/CmmToAsm/Dwarf.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf.hs
@@ -26,50 +26,47 @@ import Data.List ( sortBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
import System.FilePath
-import System.Directory ( getCurrentDirectory )
import qualified GHC.Cmm.Dataflow.Label as H
import qualified GHC.Cmm.Dataflow.Collections as H
-- | Generate DWARF/debug information
-dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
- -> IO (SDoc, UniqSupply)
-dwarfGen _ _ us [] = return (empty, us)
-dwarfGen config modLoc us blocks = do
+dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
+ -> (doc, UniqSupply)
+dwarfGen _ _ _ us [] = (empty, us)
+dwarfGen compPath config modLoc us blocks =
let platform = ncgPlatform config
- -- Convert debug data structures to DWARF info records
- let procs = debugSplitProcs blocks
+ -- Convert debug data structures to DWARF info records
+ procs = debugSplitProcs blocks
stripBlocks dbg
| ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
| otherwise = dbg
- compPath <- getCurrentDirectory
- let lowLabel = dblCLabel $ head procs
+ lowLabel = dblCLabel $ head procs
highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs
dwarfUnit = DwarfCompileUnit
{ dwChildren = map (procToDwarf config) (map stripBlocks procs)
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
- , dwLowLabel = pprAsmLabel platform lowLabel
- , dwHighLabel = pprAsmLabel platform highLabel
- , dwLineLabel = dwarfLineLabel
+ , dwLowLabel = lowLabel
+ , dwHighLabel = highLabel
}
- -- Check whether we have any source code information, so we do not
- -- end up writing a pointer to an empty .debug_line section
- -- (dsymutil on Mac Os gets confused by this).
- let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
+ -- Check whether we have any source code information, so we do not
+ -- end up writing a pointer to an empty .debug_line section
+ -- (dsymutil on Mac Os gets confused by this).
+ haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
|| any haveSrcIn (dblBlocks blk)
haveSrc = any haveSrcIn procs
-- .debug_abbrev section: Declare the format we're using
- let abbrevSct = pprAbbrevDecls platform haveSrc
+ abbrevSct = pprAbbrevDecls platform haveSrc
-- .debug_info section: Information records on procedures and blocks
- let -- unique to identify start and end compilation unit .debug_inf
+ -- unique to identify start and end compilation unit .debug_inf
(unitU, us') = takeUniqFromSupply us
- infoSct = vcat [ dwarfInfoLabel <> colon
+ infoSct = vcat [ line (dwarfInfoLabel <> colon)
, dwarfInfoSection platform
, compileUnitHeader platform unitU
, pprDwarfInfo platform haveSrc dwarfUnit
@@ -78,21 +75,23 @@ dwarfGen config modLoc us blocks = do
-- .debug_line section: Generated mainly by the assembler, but we
-- need to label it
- let lineSct = dwarfLineSection platform $$
- dwarfLineLabel <> colon
+ lineSct = dwarfLineSection platform $$
+ line (dwarfLineLabel <> colon)
-- .debug_frame section: Information about the layout of the GHC stack
- let (framesU, us'') = takeUniqFromSupply us'
+ (framesU, us'') = takeUniqFromSupply us'
frameSct = dwarfFrameSection platform $$
- dwarfFrameLabel <> colon $$
+ line (dwarfFrameLabel <> colon) $$
pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
- let aranges' | ncgSplitSections config = map mkDwarfARange procs
+ aranges' | ncgSplitSections config = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
- let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
+ aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
- return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
+ in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-}
+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Build an address range entry for one proc.
-- With split sections, each proc needs its own entry, since they may get
@@ -106,24 +105,24 @@ mkDwarfARange proc = DwarfARange lbl end
-- | Header for a compilation unit, establishing global format
-- parameters
-compileUnitHeader :: Platform -> Unique -> SDoc
+compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc
compileUnitHeader platform unitU =
let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel
<> text "-4" -- length of initialLength field
- in vcat [ pprAsmLabel platform cuLabel <> colon
- , text "\t.long " <> length -- compilation unit size
+ in vcat [ line (pprAsmLabel platform cuLabel <> colon)
+ , line (text "\t.long " <> length) -- compilation unit size
, pprHalf 3 -- DWARF version
, sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel
-- abbrevs offset
- , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
+ , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size
]
-- | Compilation unit footer, mainly establishing size of debug sections
-compileUnitFooter :: Platform -> Unique -> SDoc
+compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc
compileUnitFooter platform unitU =
let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
- in pprAsmLabel platform cuEndLabel <> colon
+ in line (pprAsmLabel platform cuEndLabel <> colon)
-- | Splits the blocks by procedures. In the result all nested blocks
-- will come from the same procedure as the top-level block. See
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
index b8fb5706cb..58e123176e 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
@@ -144,17 +144,29 @@ dW_OP_call_frame_cfa = 0x9c
-- * Dwarf section declarations
dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
- dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc
+ dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc
dwarfInfoSection platform = dwarfSection platform "info"
dwarfAbbrevSection platform = dwarfSection platform "abbrev"
dwarfLineSection platform = dwarfSection platform "line"
dwarfFrameSection platform = dwarfSection platform "frame"
dwarfGhcSection platform = dwarfSection platform "ghc"
dwarfARangesSection platform = dwarfSection platform "aranges"
+{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-}
+{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-dwarfSection :: Platform -> String -> SDoc
+dwarfSection :: IsDoc doc => Platform -> String -> doc
dwarfSection platform name =
- case platformOS platform of
+ line $ case platformOS platform of
os | osElfTarget os
-> text "\t.section .debug_" <> text name <> text ",\"\","
<> sectionType platform "progbits"
@@ -162,13 +174,24 @@ dwarfSection platform name =
-> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
| otherwise
-> text "\t.section .debug_" <> text name <> text ",\"dr\""
+{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-}
+{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+
-- * Dwarf section labels
-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc
+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc
dwarfInfoLabel = text ".Lsection_info"
dwarfAbbrevLabel = text ".Lsection_abbrev"
dwarfLineLabel = text ".Lsection_line"
dwarfFrameLabel = text ".Lsection_frame"
+{-# SPECIALIZE dwarfInfoLabel :: SDoc #-}
+{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-}
+{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfLineLabel :: SDoc #-}
+{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE dwarfFrameLabel :: SDoc #-}
+{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Mapping of registers to DWARF register numbers
dwarfRegNo :: Platform -> Reg -> Word8
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
index 55eb0246bf..94593508c3 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
@@ -59,9 +59,8 @@ data DwarfInfo
, dwName :: String
, dwProducer :: String
, dwCompDir :: String
- , dwLowLabel :: SDoc
- , dwHighLabel :: SDoc
- , dwLineLabel :: SDoc }
+ , dwLowLabel :: CLabel
+ , dwHighLabel :: CLabel }
| DwarfSubprogram { dwChildren :: [DwarfInfo]
, dwName :: String
, dwLabel :: CLabel
@@ -88,13 +87,13 @@ data DwarfAbbrev
deriving (Eq, Enum)
-- | Generate assembly for the given abbreviation code
-pprAbbrev :: DwarfAbbrev -> SDoc
+pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc
pprAbbrev = pprLEBWord . fromIntegral . fromEnum
-- | Abbreviation declaration. This explains the binary encoding we
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
-pprAbbrevDecls :: Platform -> Bool -> SDoc
+pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc
pprAbbrevDecls platform haveDebugLine =
let mkAbbrev abbr tag chld flds =
let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
@@ -111,7 +110,7 @@ pprAbbrevDecls platform haveDebugLine =
, (dW_AT_frame_base, dW_FORM_block1)
]
in dwarfAbbrevSection platform $$
- dwarfAbbrevLabel <> colon $$
+ line (dwarfAbbrevLabel <> colon) $$
mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
([(dW_AT_name, dW_FORM_string)
, (dW_AT_producer, dW_FORM_string)
@@ -144,9 +143,11 @@ pprAbbrevDecls platform haveDebugLine =
, (dW_AT_ghc_span_end_col, dW_FORM_data2)
] $$
pprByte 0
+{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-}
+{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Generate assembly for DWARF data
-pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc
+pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
pprDwarfInfo platform haveSrc d
= case d of
DwarfCompileUnit {} -> hasChildren
@@ -159,9 +160,11 @@ pprDwarfInfo platform haveSrc d
vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen platform haveSrc d
+{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-}
+{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print a CLabel name in a ".stringz \"LABEL\""
-pprLabelString :: Platform -> CLabel -> SDoc
+pprLabelString :: IsDoc doc => Platform -> CLabel -> doc
pprLabelString platform label =
pprString' -- we don't need to escape the string as labels don't contain exotic characters
$ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm)
@@ -169,22 +172,22 @@ pprLabelString platform label =
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
-pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
+pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
- highLabel lineLbl) =
+ highLabel) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
-- Offset due to Note [Info Offset]
- $$ pprWord platform (lowLabel <> text "-1")
- $$ pprWord platform highLabel
+ $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1")
+ $$ pprWord platform (pprAsmLabel platform highLabel)
$$ if haveSrc
- then sectionOffset platform lineLbl dwarfLineLabel
+ then sectionOffset platform dwarfLineLabel dwarfLineLabel
else empty
pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
- pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
+ line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
$$ pprAbbrev abbrev
$$ pprString name
$$ pprLabelString platform label
@@ -201,11 +204,11 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
parentValue = maybe empty pprParentDie parent
pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel
pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
- pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
+ line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
$$ pprAbbrev DwAbbrBlockWithoutCode
$$ pprLabelString platform label
pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
- pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
+ line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
$$ pprAbbrev DwAbbrBlock
$$ pprLabelString platform label
$$ pprWord platform (pprAsmLabel platform marker)
@@ -219,7 +222,7 @@ pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
$$ pprHalf (fromIntegral $ srcSpanEndCol ss)
-- | Close a DWARF info record with children
-pprDwarfInfoClose :: SDoc
+pprDwarfInfoClose :: IsDoc doc => doc
pprDwarfInfoClose = pprAbbrev DwAbbrNull
-- | A DWARF address range. This is used by the debugger to quickly locate
@@ -233,7 +236,7 @@ data DwarfARange
-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
-pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc
+pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc
pprDwarfARanges platform arngs unitU =
let wordSize = platformWordSizeInBytes platform
paddingSize = 4 :: Int
@@ -243,7 +246,7 @@ pprDwarfARanges platform arngs unitU =
pad n = vcat $ replicate n $ pprByte 0
-- Fix for #17428
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
- in pprDwWord (ppr initialLength)
+ in pprDwWord (int initialLength)
$$ pprHalf 2
$$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel
$$ pprByte (fromIntegral wordSize)
@@ -254,8 +257,10 @@ pprDwarfARanges platform arngs unitU =
-- terminus
$$ pprWord platform (char '0')
$$ pprWord platform (char '0')
+{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-}
+{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprDwarfARange :: Platform -> DwarfARange -> SDoc
+pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc
pprDwarfARange platform arng =
-- Offset due to Note [Info Offset].
pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1")
@@ -299,7 +304,7 @@ instance OutputableP Platform DwarfFrameBlock where
-- | Header for the @.debug_frame@ section. Here we emit the "Common
-- Information Entry" record that establishes general call frame
-- parameters and the default stack layout.
-pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
+pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc
pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
cieEndLabel = mkAsmTempEndLabel cieLabel
@@ -307,7 +312,7 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro
spReg = dwarfGlobalRegNo platform Sp
retReg = dwarfReturnRegNo platform
wordSize = platformWordSizeInBytes platform
- pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
+ pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc
pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
-- Preserve C stack pointer: This necessary to override that default
@@ -316,9 +321,9 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro
ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4
ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
_ -> empty
- in vcat [ pprAsmLabel platform cieLabel <> colon
+ in vcat [ line (pprAsmLabel platform cieLabel <> colon)
, pprData4' length -- Length of CIE
- , pprAsmLabel platform cieStartLabel <> colon
+ , line (pprAsmLabel platform cieStartLabel <> colon)
, pprData4' (text "-1")
-- Common Information Entry marker (-1 = 0xf..f)
, pprByte 3 -- CIE version (we require DWARF 3)
@@ -346,23 +351,25 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro
, pprLEBWord 0
] $$
wordAlign platform $$
- pprAsmLabel platform cieEndLabel <> colon $$
+ line (pprAsmLabel platform cieEndLabel <> colon) $$
-- Procedure unwind tables
vcat (map (pprFrameProc platform cieLabel cieInit) procs)
+{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-}
+{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Writes a "Frame Description Entry" for a procedure. This consists
-- mainly of referencing the CIE and writing state machine
-- instructions to describe how the frame base (CFA) changes.
-pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
+pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc
pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
= let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
procEnd = mkAsmTempProcEndLabel procLbl
ifInfo str = if hasInfo then text str else empty
-- see Note [Info Offset]
- in vcat [ whenPprDebug $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon
+ in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon
, pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel)
- , pprAsmLabel platform fdeLabel <> colon
+ , line (pprAsmLabel platform fdeLabel <> colon)
, pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE
, pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer
, pprWord platform (pprAsmLabel platform procEnd <> char '-' <>
@@ -370,17 +377,17 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
] $$
vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
wordAlign platform $$
- pprAsmLabel platform fdeEndLabel <> colon
+ line (pprAsmLabel platform fdeEndLabel <> colon)
-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
-pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc
+pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc
pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =
vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
where
- pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
+ pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc
pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
let -- Did a register's unwind expression change?
isChanged :: GlobalReg -> Maybe UnwindExpr
@@ -450,12 +457,12 @@ dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
-- | Generate code for setting the unwind information for a register,
-- optimized using its known old value in the table. Note that "Sp" is
-- special: We see it as synonym for the CFA.
-pprSetUnwind :: Platform
+pprSetUnwind :: IsDoc doc => Platform
-> GlobalReg
-- ^ the register to produce an unwinding table entry for
-> (Maybe UnwindExpr, Maybe UnwindExpr)
-- ^ the old and new values of the register
- -> SDoc
+ -> doc
pprSetUnwind plat g (_, Nothing)
= pprUndefUnwind plat g
pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
@@ -495,13 +502,13 @@ pprSetUnwind plat g (_, Just uw)
-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
-- encoded number.
-pprLEBRegNo :: Platform -> GlobalReg -> SDoc
+pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc
pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
-- | Generates a DWARF expression for the given unwind expression. If
-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
-- mentioned.
-pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc
+pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc
pprUnwindExpr platform spIsCFA expr
= let pprE (UwConst i)
| i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
@@ -517,84 +524,100 @@ pprUnwindExpr platform spIsCFA expr
pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
- in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
+ in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length
-- computed as the difference of the following local labels 2: and 1:
- text "1:" $$
+ line (text "1:") $$
pprE expr $$
- text "2:"
+ line (text "2:")
-- | Generate code for re-setting the unwind information for a
-- register to @undefined@
-pprUndefUnwind :: Platform -> GlobalReg -> SDoc
+pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc
pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
pprLEBRegNo plat g
-- | Align assembly at (machine) word boundary
-wordAlign :: Platform -> SDoc
+wordAlign :: IsDoc doc => Platform -> doc
wordAlign plat =
- text "\t.align " <> case platformOS plat of
+ line $ text "\t.align " <> case platformOS plat of
OSDarwin -> case platformWordSize plat of
PW8 -> char '3'
PW4 -> char '2'
- _other -> ppr (platformWordSizeInBytes plat)
+ _other -> int (platformWordSizeInBytes plat)
+{-# SPECIALIZE wordAlign :: Platform -> SDoc #-}
+{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Assembly for a single byte of constant DWARF data
-pprByte :: Word8 -> SDoc
-pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
+pprByte :: IsDoc doc => Word8 -> doc
+pprByte x = line $ text "\t.byte " <> integer (fromIntegral x)
+{-# SPECIALIZE pprByte :: Word8 -> SDoc #-}
+{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Assembly for a two-byte constant integer
-pprHalf :: Word16 -> SDoc
-pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
+pprHalf :: IsDoc doc => Word16 -> doc
+pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x)
+{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-}
+{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Assembly for a constant DWARF flag
-pprFlag :: Bool -> SDoc
+pprFlag :: IsDoc doc => Bool -> doc
pprFlag f = pprByte (if f then 0xff else 0x00)
-- | Assembly for 4 bytes of dynamic DWARF data
-pprData4' :: SDoc -> SDoc
-pprData4' x = text "\t.long " <> x
+pprData4' :: IsDoc doc => Line doc -> doc
+pprData4' x = line (text "\t.long " <> x)
+{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-}
+{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Assembly for 4 bytes of constant DWARF data
-pprData4 :: Word -> SDoc
-pprData4 = pprData4' . ppr
+pprData4 :: IsDoc doc => Word -> doc
+pprData4 = pprData4' . integer . fromIntegral
-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
-- we are generating 32 bit DWARF.
-pprDwWord :: SDoc -> SDoc
+pprDwWord :: IsDoc doc => Line doc -> doc
pprDwWord = pprData4'
+{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-}
+{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Assembly for a machine word of dynamic data. Depends on the
-- architecture we are currently generating code for.
-pprWord :: Platform -> SDoc -> SDoc
+pprWord :: IsDoc doc => Platform -> Line doc -> doc
pprWord plat s =
- case platformWordSize plat of
+ line $ case platformWordSize plat of
PW4 -> text "\t.long " <> s
PW8 -> text "\t.quad " <> s
+{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-}
+{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Prints a number in "little endian base 128" format. The idea is
-- to optimize for small numbers by stopping once all further bytes
-- would be 0. The highest bit in every byte signals whether there
-- are further bytes to read.
-pprLEBWord :: Word -> SDoc
+pprLEBWord :: IsDoc doc => Word -> doc
pprLEBWord x | x < 128 = pprByte (fromIntegral x)
| otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
pprLEBWord (x `shiftR` 7)
+{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-}
+{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Same as @pprLEBWord@, but for a signed number
-pprLEBInt :: Int -> SDoc
+pprLEBInt :: IsDoc doc => Int -> doc
pprLEBInt x | x >= -64 && x < 64
= pprByte (fromIntegral (x .&. 127))
| otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
pprLEBInt (x `shiftR` 7)
+{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-}
+{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Generates a dynamic null-terminated string. If required the
-- caller needs to make sure that the string is escaped properly.
-pprString' :: SDoc -> SDoc
-pprString' str = text "\t.asciz \"" <> str <> char '"'
+pprString' :: IsDoc doc => Line doc -> doc
+pprString' str = line (text "\t.asciz \"" <> str <> char '"')
-- | Generate a string constant. We take care to escape the string.
-pprString :: String -> SDoc
+pprString :: IsDoc doc => String -> doc
pprString str
= pprString' $ hcat $ map escapeChar $
if str `lengthIs` utf8EncodedLength str
@@ -602,7 +625,7 @@ pprString str
else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str
-- | Escape a single non-unicode character
-escapeChar :: Char -> SDoc
+escapeChar :: IsLine doc => Char -> doc
escapeChar '\\' = text "\\\\"
escapeChar '\"' = text "\\\""
escapeChar '\n' = text "\\n"
@@ -621,9 +644,11 @@ escapeChar c
-- us to just reference the target directly, and will figure out on
-- their own that we actually need an offset. Finally, Windows has
-- a special directive to refer to relative offsets. Fun.
-sectionOffset :: Platform -> SDoc -> SDoc -> SDoc
+sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc
sectionOffset plat target section =
case platformOS plat of
OSDarwin -> pprDwWord (target <> char '-' <> section)
- OSMinGW32 -> text "\t.secrel32 " <> target
+ OSMinGW32 -> line (text "\t.secrel32 " <> target)
_other -> pprDwWord target
+{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-}
+{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs
index bc2e2969e6..aa8f538e07 100644
--- a/compiler/GHC/CmmToAsm/Instr.hs
+++ b/compiler/GHC/CmmToAsm/Instr.hs
@@ -15,6 +15,7 @@ import GHC.Utils.Outputable (SDoc)
import GHC.Cmm.BlockId
import GHC.CmmToAsm.Config
+import GHC.Data.FastString
-- | Holds a list of source and destination registers used by a
-- particular instruction.
@@ -160,4 +161,4 @@ class Instruction instr where
pprInstr :: Platform -> instr -> SDoc
-- Create a comment instruction
- mkComment :: SDoc -> [instr]
+ mkComment :: FastString -> [instr]
diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs
index eb445649c3..2a61ff0314 100644
--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ b/compiler/GHC/CmmToAsm/Monad.hs
@@ -67,7 +67,7 @@ import GHC.Types.Unique.Supply
import GHC.Types.Unique ( Unique )
import GHC.Unit.Module
-import GHC.Utils.Outputable (SDoc, ppr)
+import GHC.Utils.Outputable (SDoc, HDoc, ppr)
import GHC.Utils.Panic (pprPanic)
import GHC.Utils.Monad.State.Strict (State (..), runState, state)
import GHC.Utils.Misc
@@ -84,7 +84,9 @@ data NcgImpl statics instr jumpDest = NcgImpl {
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
-- | 'Module' is only for printing internal labels. See Note [Internal proc
-- labels] in CLabel.
- pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
+ pprNatCmmDeclS :: NatCmmDecl statics instr -> SDoc,
+ pprNatCmmDeclH :: NatCmmDecl statics instr -> HDoc,
+ -- see Note [pprNatCmmDeclS and pprNatCmmDeclH]
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr
@@ -103,6 +105,38 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-- when possible.
}
+{- Note [pprNatCmmDeclS and pprNatCmmDeclH]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS
+and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively
+(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally
+implemented as a single, polymorphic function, but they need to be stored using
+monomorphic types to ensure the specialized versions are used, which is
+essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable).
+
+One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we
+have a perfectly serviceable HDoc-based implementation that is more efficient.
+However, it turns out we benefit from keeping both, for two (related) reasons:
+
+ 1. Although we absolutely want to take care to use pprNatCmmDeclH for actual
+ code generation (the improved performance there is why we have HDoc at
+ all!), we also sometimes print assembly for debug dumps, when requested via
+ -ddump-asm. In this case, it’s more convenient to produce an SDoc, which
+ can be concatenated with other SDocs for consistency with the general-
+ purpose dump file infrastructure.
+
+ 2. Some debug information is sometimes useful to include in -ddump-asm that is
+ neither necessary nor useful in normal code generation, and it turns out to
+ be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc.
+
+Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes
+include additional information in the SDoc variant using dualDoc
+(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is
+absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm
+is provided, as that would rather defeat the whole point. (Fortunately, the
+difference in allocations between the two implementations is so vast that such a
+mistake would readily show up in performance tests). -}
+
data NatM_State
= NatM_State {
natm_us :: UniqSupply,
diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs
index 0b92afbfe6..d388d5b328 100644
--- a/compiler/GHC/CmmToAsm/PIC.hs
+++ b/compiler/GHC/CmmToAsm/PIC.hs
@@ -532,11 +532,11 @@ gotLabel
--
-- We don't need to declare any offset tables.
-- However, for PIC on x86, we need a small helper function.
-pprGotDeclaration :: NCGConfig -> SDoc
+pprGotDeclaration :: NCGConfig -> HDoc
pprGotDeclaration config = case (arch,os) of
(ArchX86, OSDarwin)
| ncgPIC config
- -> vcat [
+ -> lines_ [
text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
text ".weak_definition ___i686.get_pc_thunk.ax",
text ".private_extern ___i686.get_pc_thunk.ax",
@@ -548,7 +548,7 @@ pprGotDeclaration config = case (arch,os) of
-- Emit XCOFF TOC section
(_, OSAIX)
- -> vcat $ [ text ".toc"
+ -> lines_ [ text ".toc"
, text ".tc ghc_toc_table[TC],.LCTOC1"
, text ".csect ghc_toc_table[RW]"
-- See Note [.LCTOC1 in PPC PIC code]
@@ -558,16 +558,16 @@ pprGotDeclaration config = case (arch,os) of
-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
(ArchPPC_64 ELF_V1, _)
- -> text ".section \".toc\",\"aw\""
+ -> line $ text ".section \".toc\",\"aw\""
-- In ELF v2 we also need to tell the assembler that we want ABI
-- version 2. This would normally be done at the top of the file
-- right after a file directive, but I could not figure out how
-- to do that.
(ArchPPC_64 ELF_V2, _)
- -> vcat [ text ".abiversion 2",
- text ".section \".toc\",\"aw\""
- ]
+ -> lines_ [ text ".abiversion 2",
+ text ".section \".toc\",\"aw\""
+ ]
(arch, os)
| osElfTarget os
@@ -577,7 +577,7 @@ pprGotDeclaration config = case (arch,os) of
| osElfTarget os
, arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
- -> vcat [
+ -> lines_ [
-- See Note [.LCTOC1 in PPC PIC code]
text ".section \".got2\",\"aw\"",
text ".LCTOC1 = .+32768" ]
@@ -595,13 +595,13 @@ pprGotDeclaration config = case (arch,os) of
-- and one for non-PIC.
--
-pprImportedSymbol :: NCGConfig -> CLabel -> SDoc
+pprImportedSymbol :: NCGConfig -> CLabel -> HDoc
pprImportedSymbol config importedLbl = case (arch,os) of
(ArchX86, OSDarwin)
| Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-> if not pic
then
- vcat [
+ lines_ [
text ".symbol_stub",
text "L" <> ppr_lbl lbl <> text "$stub:",
text "\t.indirect_symbol" <+> ppr_lbl lbl,
@@ -614,7 +614,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
text "\tjmp dyld_stub_binding_helper"
]
else
- vcat [
+ lines_ [
text ".section __TEXT,__picsymbolstub2,"
<> text "symbol_stubs,pure_instructions,25",
text "L" <> ppr_lbl lbl <> text "$stub:",
@@ -631,7 +631,8 @@ pprImportedSymbol config importedLbl = case (arch,os) of
text "\tpushl %eax",
text "\tjmp dyld_stub_binding_helper"
]
- $+$ vcat [ text ".section __DATA, __la_sym_ptr"
+ $$ lines_ [
+ text ".section __DATA, __la_sym_ptr"
<> (if pic then int 2 else int 3)
<> text ",lazy_symbol_pointers",
text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",
@@ -640,7 +641,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
<> text "$stub_binder"]
| Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
- -> vcat [
+ -> lines_ [
text ".non_lazy_symbol_pointer",
char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",
text "\t.indirect_symbol" <+> ppr_lbl lbl,
@@ -667,7 +668,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
(_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
- -> vcat [
+ -> lines_ [
text "LC.." <> ppr_lbl lbl <> char ':',
text "\t.long" <+> ppr_lbl lbl ]
_ -> empty
@@ -705,7 +706,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
| osElfTarget os
-> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
- -> vcat [
+ -> lines_ [
text ".LC_" <> ppr_lbl lbl <> char ':',
text "\t.quad" <+> ppr_lbl lbl ]
_ -> empty
@@ -718,7 +719,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
W64 -> text "\t.quad"
_ -> panic "Unknown wordRep in pprImportedSymbol"
- in vcat [
+ in lines_ [
text ".section \".got2\", \"aw\"",
text ".LC_" <> ppr_lbl lbl <> char ':',
symbolSize <+> ppr_lbl lbl ]
@@ -729,6 +730,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
_ -> panic "PIC.pprImportedSymbol: no match"
where
platform = ncgPlatform config
+ ppr_lbl :: CLabel -> HLine
ppr_lbl = pprAsmLabel platform
arch = platformArch platform
os = platformOS platform
diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs
index cbfbdb539c..40a629907f 100644
--- a/compiler/GHC/CmmToAsm/PPC.hs
+++ b/compiler/GHC/CmmToAsm/PPC.hs
@@ -28,7 +28,8 @@ ncgPPC config = NcgImpl
, canShortcut = PPC.canShortcut
, shortcutStatics = PPC.shortcutStatics
, shortcutJump = PPC.shortcutJump
- , pprNatCmmDecl = PPC.pprNatCmmDecl config
+ , pprNatCmmDeclH = PPC.pprNatCmmDecl config
+ , pprNatCmmDeclS = PPC.pprNatCmmDecl config
, maxSpillSlots = PPC.maxSpillSlots config
, allocatableRegs = PPC.allocatableRegs platform
, ncgAllocMoreStack = PPC.allocMoreStack platform
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index abad5d0427..3b448041e3 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -162,7 +162,7 @@ stmtToInstrs stmt = do
config <- getConfig
platform <- getPlatform
case stmt of
- CmmComment s -> return (unitOL (COMMENT $ ftext s))
+ CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmUnwind {} -> return nilOL
diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs
index c852789bbe..639ae979f8 100644
--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs
@@ -52,7 +52,6 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.CLabel
-import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique.FM (listToUFM, lookupUFM)
@@ -60,6 +59,7 @@ import GHC.Types.Unique.Supply
import Data.Foldable (toList)
import qualified Data.List.NonEmpty as NE
+import GHC.Data.FastString (FastString)
import Data.Maybe (fromMaybe)
@@ -179,7 +179,7 @@ data RI
data Instr
-- comment pseudo-op
- = COMMENT SDoc
+ = COMMENT FastString
-- location pseudo-op (file, line, col, name)
| LOCATION Int Int Int String
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index e16006bcd2..051fc0b7dc 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -46,7 +46,7 @@ import Data.Int
-- -----------------------------------------------------------------------------
-- Printing this stuff out
-pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc
+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
pprSectionAlign config section
$$ pprDatas (ncgPlatform config) dats
@@ -63,15 +63,15 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
_ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
-- so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel lbl)
- <> char ':' $$
- pprProcEndLabel platform lbl) $$
+ ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl)
+ <> char ':') $$
+ line (pprProcEndLabel platform lbl)) $$
pprSizeDecl platform lbl
Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
(if platformHasSubsectionsViaSymbols platform
- then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':'
+ then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
else empty) $$
vcat (map (pprBasicBlock config top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
@@ -79,18 +79,20 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
(if platformHasSubsectionsViaSymbols platform
then
-- See Note [Subsections Via Symbols] in X86/Ppr.hs
- text "\t.long "
- <+> pprAsmLabel platform info_lbl
- <+> char '-'
- <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
+ line (text "\t.long "
+ <+> pprAsmLabel platform info_lbl
+ <+> char '-'
+ <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl))
else empty) $$
pprSizeDecl platform info_lbl
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Output the ELF .size directive.
-pprSizeDecl :: Platform -> CLabel -> SDoc
+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl
+ then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl)
else empty
where
prettyLbl = pprAsmLabel platform lbl
@@ -98,47 +100,45 @@ pprSizeDecl platform lbl
| platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl
| otherwise = prettyLbl
-pprFunctionDescriptor :: Platform -> CLabel -> SDoc
-pprFunctionDescriptor platform lab = pprGloblDecl platform lab
- $$ text "\t.section \".opd\", \"aw\""
- $$ text "\t.align 3"
- $$ pprAsmLabel platform lab <> char ':'
- $$ text "\t.quad ."
- <> pprAsmLabel platform lab
- <> text ",.TOC.@tocbase,0"
- $$ text "\t.previous"
- $$ text "\t.type"
- <+> pprAsmLabel platform lab
- <> text ", @function"
- $$ char '.' <> pprAsmLabel platform lab <> char ':'
-
-pprFunctionPrologue :: Platform -> CLabel ->SDoc
-pprFunctionPrologue platform lab = pprGloblDecl platform lab
- $$ text ".type "
- <> pprAsmLabel platform lab
- <> text ", @function"
- $$ pprAsmLabel platform lab <> char ':'
- $$ text "0:\taddis\t" <> pprReg toc
- <> text ",12,.TOC.-0b@ha"
- $$ text "\taddi\t" <> pprReg toc
- <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"
- $$ text "\t.localentry\t" <> pprAsmLabel platform lab
- <> text ",.-" <> pprAsmLabel platform lab
-
-pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name
- -> SDoc
+pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc
+pprFunctionDescriptor platform lab =
+ vcat [pprGloblDecl platform lab,
+ line (text "\t.section \".opd\", \"aw\""),
+ line (text "\t.align 3"),
+ line (pprAsmLabel platform lab <> char ':'),
+ line (text "\t.quad ."
+ <> pprAsmLabel platform lab
+ <> text ",.TOC.@tocbase,0"),
+ line (text "\t.previous"),
+ line (text "\t.type"
+ <+> pprAsmLabel platform lab
+ <> text ", @function"),
+ line (char '.' <> pprAsmLabel platform lab <> char ':')]
+
+pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc
+pprFunctionPrologue platform lab =
+ vcat [pprGloblDecl platform lab,
+ line (text ".type " <> pprAsmLabel platform lab <> text ", @function"),
+ line (pprAsmLabel platform lab <> char ':'),
+ line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"),
+ line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"),
+ line (text "\t.localentry\t" <> pprAsmLabel platform lab <>
+ text ",.-" <> pprAsmLabel platform lab)]
+
+pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
+ -> doc
pprProcEndLabel platform lbl =
pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':'
-pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
- -> SDoc
+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
+ -> doc
pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $$
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
ppWhen (ncgDwarfEnabled config) (
- pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
- <> pprProcEndLabel platform asmLbl
+ line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
+ <> pprProcEndLabel platform asmLbl)
)
where
asmLbl = blockLbl blockid
@@ -152,7 +152,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
-pprDatas :: Platform -> RawCmmStatics -> SDoc
+pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
@@ -162,38 +162,38 @@ pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLi
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl platform alias
- $$ text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind'
+ $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind')
pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
-pprData :: Platform -> CmmStatic -> SDoc
+pprData :: IsDoc doc => Platform -> CmmStatic -> doc
pprData platform d = case d of
- CmmString str -> pprString str
- CmmFileEmbed path _ -> pprFileEmbed path
- CmmUninitialised bytes -> text ".space " <> int bytes
+ CmmString str -> line (pprString str)
+ CmmFileEmbed path _ -> line (pprFileEmbed path)
+ CmmUninitialised bytes -> line (text ".space " <> int bytes)
CmmStaticLit lit -> pprDataItem platform lit
-pprGloblDecl :: Platform -> CLabel -> SDoc
+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text ".globl " <> pprAsmLabel platform lbl
+ | otherwise = line (text ".globl " <> pprAsmLabel platform lbl)
-pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc
+pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc
pprTypeAndSizeDecl platform lbl
= if platformOS platform == OSLinux && externallyVisibleCLabel lbl
then text ".type " <>
pprAsmLabel platform lbl <> text ", @object"
else empty
-pprLabel :: Platform -> CLabel -> SDoc
+pprLabel :: IsDoc doc => Platform -> CLabel -> doc
pprLabel platform lbl =
pprGloblDecl platform lbl
- $$ pprTypeAndSizeDecl platform lbl
- $$ (pprAsmLabel platform lbl <> char ':')
+ $$ line (pprTypeAndSizeDecl platform lbl)
+ $$ line (pprAsmLabel platform lbl <> char ':')
-- -----------------------------------------------------------------------------
-- pprInstr: print an 'Instr'
-pprReg :: Reg -> SDoc
+pprReg :: forall doc. IsLine doc => Reg -> doc
pprReg r
= case r of
@@ -204,7 +204,7 @@ pprReg r
RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u
where
- ppr_reg_no :: Int -> SDoc
+ ppr_reg_no :: Int -> doc
ppr_reg_no i
| i <= 31 = int i -- GPRs
| i <= 63 = int (i-32) -- FPRs
@@ -212,7 +212,7 @@ pprReg r
-pprFormat :: Format -> SDoc
+pprFormat :: IsLine doc => Format -> doc
pprFormat x
= case x of
II8 -> text "b"
@@ -223,7 +223,7 @@ pprFormat x
FF64 -> text "fd"
-pprCond :: Cond -> SDoc
+pprCond :: IsLine doc => Cond -> doc
pprCond c
= case c of {
ALWAYS -> text "";
@@ -234,7 +234,7 @@ pprCond c
GU -> text "gt"; LEU -> text "le"; }
-pprImm :: Platform -> Imm -> SDoc
+pprImm :: IsLine doc => Platform -> Imm -> doc
pprImm platform = \case
ImmInt i -> int i
ImmInteger i -> integer i
@@ -264,7 +264,7 @@ pprImm platform = \case
HIGHESTA i -> pprImm platform i <> text "@highesta"
-pprAddr :: Platform -> AddrMode -> SDoc
+pprAddr :: IsLine doc => Platform -> AddrMode -> doc
pprAddr platform = \case
AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2
AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ]
@@ -272,14 +272,14 @@ pprAddr platform = \case
AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ]
-pprSectionAlign :: NCGConfig -> Section -> SDoc
+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
pprSectionAlign config sec@(Section seg _) =
- pprSectionHeader config sec $$
+ line (pprSectionHeader config sec) $$
pprAlignForSection (ncgPlatform config) seg
-- | Print appropriate alignment for the given section type.
-pprAlignForSection :: Platform -> SectionType -> SDoc
-pprAlignForSection platform seg =
+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
+pprAlignForSection platform seg = line $
let ppc64 = not $ target32Bit platform
in case seg of
Text -> text ".align 2"
@@ -304,9 +304,9 @@ pprAlignForSection platform seg =
| otherwise -> text ".align 2"
OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section"
-pprDataItem :: Platform -> CmmLit -> SDoc
+pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc
pprDataItem platform lit
- = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
+ = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
imm = litToImm lit
archPPC_64 = not $ target32Bit platform
@@ -333,21 +333,21 @@ pprDataItem platform lit
= panic "PPC.Ppr.pprDataItem: no match"
-asmComment :: SDoc -> SDoc
+asmComment :: IsLine doc => doc -> doc
asmComment c = whenPprDebug $ text "#" <+> c
-pprInstr :: Platform -> Instr -> SDoc
+pprInstr :: IsDoc doc => Platform -> Instr -> doc
pprInstr platform instr = case instr of
COMMENT s
- -> asmComment s
+ -> line (asmComment (ftext s))
- LOCATION file line col _name
- -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col
+ LOCATION file line' col _name
+ -> line (text "\t.loc" <+> int file <+> int line' <+> int col)
DELTA d
- -> asmComment $ text ("\tdelta = " ++ show d)
+ -> line (asmComment $ text ("\tdelta = " ++ show d))
NEWBLOCK _
-> panic "PprMach.pprInstr: NEWBLOCK"
@@ -374,7 +374,7 @@ pprInstr platform instr = case instr of
-}
LD fmt reg addr
- -> hcat [
+ -> line $ hcat [
char '\t',
text "l",
(case fmt of
@@ -403,7 +403,7 @@ pprInstr platform instr = case instr of
-> panic "PPC.Ppr.pprInstr LDFAR: no match"
LDR fmt reg1 addr
- -> hcat [
+ -> line $ hcat [
text "\tl",
case fmt of
II32 -> char 'w'
@@ -416,7 +416,7 @@ pprInstr platform instr = case instr of
]
LA fmt reg addr
- -> hcat [
+ -> line $ hcat [
char '\t',
text "l",
(case fmt of
@@ -436,7 +436,7 @@ pprInstr platform instr = case instr of
]
ST fmt reg addr
- -> hcat [
+ -> line $ hcat [
char '\t',
text "st",
pprFormat fmt,
@@ -457,7 +457,7 @@ pprInstr platform instr = case instr of
-> panic "PPC.Ppr.pprInstr STFAR: no match"
STU fmt reg addr
- -> hcat [
+ -> line $ hcat [
char '\t',
text "st",
pprFormat fmt,
@@ -471,7 +471,7 @@ pprInstr platform instr = case instr of
]
STC fmt reg1 addr
- -> hcat [
+ -> line $ hcat [
text "\tst",
case fmt of
II32 -> char 'w'
@@ -484,7 +484,7 @@ pprInstr platform instr = case instr of
]
LIS reg imm
- -> hcat [
+ -> line $ hcat [
char '\t',
text "lis",
char '\t',
@@ -494,7 +494,7 @@ pprInstr platform instr = case instr of
]
LI reg imm
- -> hcat [
+ -> line $ hcat [
char '\t',
text "li",
char '\t',
@@ -505,7 +505,7 @@ pprInstr platform instr = case instr of
MR reg1 reg2
| reg1 == reg2 -> empty
- | otherwise -> hcat [
+ | otherwise -> line $ hcat [
char '\t',
case targetClassOfReg platform reg1 of
RcInteger -> text "mr"
@@ -517,7 +517,7 @@ pprInstr platform instr = case instr of
]
CMP fmt reg ri
- -> hcat [
+ -> line $ hcat [
char '\t',
op,
char '\t',
@@ -535,7 +535,7 @@ pprInstr platform instr = case instr of
]
CMPL fmt reg ri
- -> hcat [
+ -> line $ hcat [
char '\t',
op,
char '\t',
@@ -553,7 +553,7 @@ pprInstr platform instr = case instr of
]
BCC cond blockid prediction
- -> hcat [
+ -> line $ hcat [
char '\t',
text "b",
pprCond cond,
@@ -568,7 +568,7 @@ pprInstr platform instr = case instr of
Just False -> char '-'
BCCFAR cond blockid prediction
- -> vcat [
+ -> lines_ [
hcat [
text "\tb",
pprCond (condNegate cond),
@@ -590,7 +590,7 @@ pprInstr platform instr = case instr of
-- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
| isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"
| otherwise ->
- hcat [ -- an alias for b that takes a CLabel
+ lines_ [ -- an alias for b that takes a CLabel
char '\t',
text "b",
char '\t',
@@ -598,7 +598,7 @@ pprInstr platform instr = case instr of
]
MTCTR reg
- -> hcat [
+ -> line $ hcat [
char '\t',
text "mtctr",
char '\t',
@@ -606,7 +606,7 @@ pprInstr platform instr = case instr of
]
BCTR _ _ _
- -> hcat [
+ -> line $ hcat [
char '\t',
text "bctr"
]
@@ -623,18 +623,18 @@ pprInstr platform instr = case instr of
-- but when profiling the codegen inserts calls via
-- 'emitRtsCallGen' which are 'CmmLabel's even though
-- they'd technically be more like 'ForeignLabel's.
- hcat [
+ line $ hcat [
text "\tbl\t.",
pprAsmLabel platform lbl
]
_ ->
- hcat [
+ line $ hcat [
text "\tbl\t",
pprAsmLabel platform lbl
]
BCTRL _
- -> hcat [
+ -> line $ hcat [
char '\t',
text "bctrl"
]
@@ -643,7 +643,7 @@ pprInstr platform instr = case instr of
-> pprLogic platform (text "add") reg1 reg2 ri
ADDIS reg1 reg2 imm
- -> hcat [
+ -> line $ hcat [
char '\t',
text "addis",
char '\t',
@@ -673,7 +673,7 @@ pprInstr platform instr = case instr of
-> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)
SUBFC reg1 reg2 ri
- -> hcat [
+ -> line $ hcat [
char '\t',
text "subf",
case ri of
@@ -694,7 +694,7 @@ pprInstr platform instr = case instr of
-> pprMul platform fmt reg1 reg2 ri
MULLO fmt reg1 reg2 reg3
- -> hcat [
+ -> line $ hcat [
char '\t',
text "mull",
case fmt of
@@ -711,13 +711,13 @@ pprInstr platform instr = case instr of
MFOV fmt reg
-> vcat [
- hcat [
+ lines_ [
char '\t',
text "mfxer",
char '\t',
pprReg reg
],
- hcat [
+ lines_ [
char '\t',
text "extr",
case fmt of
@@ -737,7 +737,7 @@ pprInstr platform instr = case instr of
]
MULHU fmt reg1 reg2 reg3
- -> hcat [
+ -> line $ hcat [
char '\t',
text "mulh",
case fmt of
@@ -758,7 +758,7 @@ pprInstr platform instr = case instr of
-- for some reason, "andi" doesn't exist.
-- we'll use "andi." instead.
AND reg1 reg2 (RIImm imm)
- -> hcat [
+ -> line $ hcat [
char '\t',
text "andi.",
char '\t',
@@ -785,7 +785,7 @@ pprInstr platform instr = case instr of
-> pprLogic platform (text "xor") reg1 reg2 ri
ORIS reg1 reg2 imm
- -> hcat [
+ -> line $ hcat [
char '\t',
text "oris",
char '\t',
@@ -797,7 +797,7 @@ pprInstr platform instr = case instr of
]
XORIS reg1 reg2 imm
- -> hcat [
+ -> line $ hcat [
char '\t',
text "xoris",
char '\t',
@@ -809,7 +809,7 @@ pprInstr platform instr = case instr of
]
EXTS fmt reg1 reg2
- -> hcat [
+ -> line $ hcat [
char '\t',
text "exts",
pprFormat fmt,
@@ -820,7 +820,7 @@ pprInstr platform instr = case instr of
]
CNTLZ fmt reg1 reg2
- -> hcat [
+ -> line $ hcat [
char '\t',
text "cntlz",
case fmt of
@@ -881,7 +881,7 @@ pprInstr platform instr = case instr of
in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)
RLWINM reg1 reg2 sh mb me
- -> hcat [
+ -> line $ hcat [
text "\trlwinm\t",
pprReg reg1,
text ", ",
@@ -895,7 +895,7 @@ pprInstr platform instr = case instr of
]
CLRLI fmt reg1 reg2 n
- -> hcat [
+ -> line $ hcat [
text "\tclrl",
pprFormat fmt,
text "i ",
@@ -907,7 +907,7 @@ pprInstr platform instr = case instr of
]
CLRRI fmt reg1 reg2 n
- -> hcat [
+ -> line $ hcat [
text "\tclrr",
pprFormat fmt,
text "i ",
@@ -937,7 +937,7 @@ pprInstr platform instr = case instr of
-> pprUnary (text "fneg") reg1 reg2
FCMP reg1 reg2
- -> hcat [
+ -> line $ hcat [
char '\t',
text "fcmpu\t0, ",
-- Note: we're using fcmpu, not fcmpo
@@ -965,7 +965,7 @@ pprInstr platform instr = case instr of
-> pprUnary (text "frsp") reg1 reg2
CRNOR dst src1 src2
- -> hcat [
+ -> line $ hcat [
text "\tcrnor\t",
int dst,
text ", ",
@@ -975,7 +975,7 @@ pprInstr platform instr = case instr of
]
MFCR reg
- -> hcat [
+ -> line $ hcat [
char '\t',
text "mfcr",
char '\t',
@@ -983,7 +983,7 @@ pprInstr platform instr = case instr of
]
MFLR reg
- -> hcat [
+ -> line $ hcat [
char '\t',
text "mflr",
char '\t',
@@ -991,25 +991,25 @@ pprInstr platform instr = case instr of
]
FETCHPC reg
- -> vcat [
+ -> lines_ [
text "\tbcl\t20,31,1f",
hcat [ text "1:\tmflr\t", pprReg reg ]
]
HWSYNC
- -> text "\tsync"
+ -> line $ text "\tsync"
ISYNC
- -> text "\tisync"
+ -> line $ text "\tisync"
LWSYNC
- -> text "\tlwsync"
+ -> line $ text "\tlwsync"
NOP
- -> text "\tnop"
+ -> line $ text "\tnop"
-pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc
-pprLogic platform op reg1 reg2 ri = hcat [
+pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc
+pprLogic platform op reg1 reg2 ri = line $ hcat [
char '\t',
op,
case ri of
@@ -1024,8 +1024,8 @@ pprLogic platform op reg1 reg2 ri = hcat [
]
-pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc
-pprMul platform fmt reg1 reg2 ri = hcat [
+pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc
+pprMul platform fmt reg1 reg2 ri = line $ hcat [
char '\t',
text "mull",
case ri of
@@ -1043,8 +1043,8 @@ pprMul platform fmt reg1 reg2 ri = hcat [
]
-pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc
-pprDiv fmt sgn reg1 reg2 reg3 = hcat [
+pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc
+pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [
char '\t',
text "div",
case fmt of
@@ -1061,8 +1061,8 @@ pprDiv fmt sgn reg1 reg2 reg3 = hcat [
]
-pprUnary :: SDoc -> Reg -> Reg -> SDoc
-pprUnary op reg1 reg2 = hcat [
+pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc
+pprUnary op reg1 reg2 = line $ hcat [
char '\t',
op,
char '\t',
@@ -1072,8 +1072,8 @@ pprUnary op reg1 reg2 = hcat [
]
-pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc
-pprBinaryF op fmt reg1 reg2 reg3 = hcat [
+pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc
+pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [
char '\t',
op,
pprFFormat fmt,
@@ -1085,12 +1085,12 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [
pprReg reg3
]
-pprRI :: Platform -> RI -> SDoc
+pprRI :: IsLine doc => Platform -> RI -> doc
pprRI _ (RIReg r) = pprReg r
pprRI platform (RIImm r) = pprImm platform r
-pprFFormat :: Format -> SDoc
+pprFFormat :: IsLine doc => Format -> doc
pprFFormat FF64 = empty
pprFFormat FF32 = char 's'
pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match"
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
index c54ce8f906..7959db8d69 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -27,7 +27,6 @@ import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.CmmToAsm.Config
import GHC.Utils.Outputable as SDoc
-import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Panic
import GHC.Platform
@@ -89,7 +88,7 @@ doubleToBytes d = runST $ do
-- Print as a string and escape non-printable characters.
-- This is similar to charToC in GHC.Utils.Misc
-pprASCII :: ByteString -> SDoc
+pprASCII :: forall doc. IsLine doc => ByteString -> doc
pprASCII str
-- Transform this given literal bytestring to escaped string and construct
-- the literal SDoc directly.
@@ -98,19 +97,19 @@ pprASCII str
--
-- We work with a `Doc` instead of an `SDoc` because there is no need to carry
-- an `SDocContext` that we don't use. It leads to nicer (STG) code.
- = docToSDoc (BS.foldr f Pretty.empty str)
+ = BS.foldr f empty str
where
- f :: Word8 -> Pretty.Doc -> Pretty.Doc
- f w s = do1 w Pretty.<> s
-
- do1 :: Word8 -> Pretty.Doc
- do1 w | 0x09 == w = Pretty.text "\\t"
- | 0x0A == w = Pretty.text "\\n"
- | 0x22 == w = Pretty.text "\\\""
- | 0x5C == w = Pretty.text "\\\\"
+ f :: Word8 -> doc -> doc
+ f w s = do1 w <> s
+
+ do1 :: Word8 -> doc
+ do1 w | 0x09 == w = text "\\t"
+ | 0x0A == w = text "\\n"
+ | 0x22 == w = text "\\\""
+ | 0x5C == w = text "\\\\"
-- ASCII printable characters range
- | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)
- | otherwise = Pretty.sizedText 4 xs
+ | w >= 0x20 && w <= 0x7E = char (chr' w)
+ | otherwise = text xs
where
!xs = [ '\\', x0, x1, x2] -- octal
!x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
@@ -122,20 +121,25 @@ pprASCII str
-- so we bypass the check in "chr"
chr' :: Word8 -> Char
chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))
-
+{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-}
+{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Emit a ".string" directive
-pprString :: ByteString -> SDoc
+pprString :: IsLine doc => ByteString -> doc
pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs)
+{-# SPECIALIZE pprString :: ByteString -> SDoc #-}
+{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Emit a ".incbin" directive
--
-- A NULL byte is added after the binary data.
-pprFileEmbed :: FilePath -> SDoc
+pprFileEmbed :: IsLine doc => FilePath -> doc
pprFileEmbed path
= text "\t.incbin "
<> pprFilePathString path -- proper escape (see #16389)
<> text "\n\t.byte 0"
+{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-}
+{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
{-
Note [Embedding large binary blobs]
@@ -193,14 +197,16 @@ string in source code. See #14741 for profiling results.
-- identical strings in the linker. With -split-sections each string also gets
-- a unique section to allow strings from unused code to be GC'd.
-pprSectionHeader :: NCGConfig -> Section -> SDoc
+pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc
pprSectionHeader config (Section t suffix) =
case platformOS (ncgPlatform config) of
OSAIX -> pprXcoffSectionHeader t
OSDarwin -> pprDarwinSectionHeader t
_ -> pprGNUSectionHeader config t suffix
+{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-}
+{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc
+pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc
pprGNUSectionHeader config t suffix =
hcat [text ".section ", header, subsection, flags]
where
@@ -244,10 +250,12 @@ pprGNUSectionHeader config t suffix =
-> empty
| otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"
_ -> empty
+{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- XCOFF doesn't support relocating label-differences, so we place all
-- RO sections into .text[PR] sections
-pprXcoffSectionHeader :: SectionType -> SDoc
+pprXcoffSectionHeader :: IsLine doc => SectionType -> doc
pprXcoffSectionHeader t = case t of
Text -> text ".csect .text[PR]"
Data -> text ".csect .data[RW]"
@@ -256,8 +264,10 @@ pprXcoffSectionHeader t = case t of
CString -> text ".csect .text[PR] # CString"
UninitialisedData -> text ".csect .data[BS]"
_ -> panic "pprXcoffSectionHeader: unknown section type"
+{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-}
+{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprDarwinSectionHeader :: SectionType -> SDoc
+pprDarwinSectionHeader :: IsLine doc => SectionType -> doc
pprDarwinSectionHeader t = case t of
Text -> text ".text"
Data -> text ".data"
@@ -268,3 +278,5 @@ pprDarwinSectionHeader t = case t of
FiniArray -> panic "pprDarwinSectionHeader: fini not supported"
CString -> text ".section\t__TEXT,__cstring,cstring_literals"
OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type"
+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}
+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs
index 91b571f4de..a82674afe8 100644
--- a/compiler/GHC/CmmToAsm/X86.hs
+++ b/compiler/GHC/CmmToAsm/X86.hs
@@ -33,7 +33,8 @@ ncgX86_64 config = NcgImpl
, canShortcut = X86.canShortcut
, shortcutStatics = X86.shortcutStatics
, shortcutJump = X86.shortcutJump
- , pprNatCmmDecl = X86.pprNatCmmDecl config
+ , pprNatCmmDeclS = X86.pprNatCmmDecl config
+ , pprNatCmmDeclH = X86.pprNatCmmDecl config
, maxSpillSlots = X86.maxSpillSlots config
, allocatableRegs = X86.allocatableRegs platform
, ncgAllocMoreStack = X86.allocMoreStack platform
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 564822e3e3..6fe264572a 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -326,7 +326,7 @@ stmtToInstrs bid stmt = do
-> genForeignCall target result_regs args bid
_ -> (,Nothing) <$> case stmt of
- CmmComment s -> return (unitOL (COMMENT $ ftext s))
+ CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmUnwind regs -> do
diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs
index 06fc3f6c7e..ccb3ce09ba 100644
--- a/compiler/GHC/CmmToAsm/X86/Instr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Instr.hs
@@ -171,7 +171,7 @@ bit precision.
data Instr
-- comment pseudo-op
- = COMMENT SDoc
+ = COMMENT FastString
-- location pseudo-op (file, line, col, name)
| LOCATION Int Int Int String
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 4e029902b8..4a8f55fdf0 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
@@ -11,11 +12,7 @@
module GHC.CmmToAsm.X86.Ppr (
pprNatCmmDecl,
- pprData,
pprInstr,
- pprFormat,
- pprImm,
- pprDataItem,
)
where
@@ -39,6 +36,7 @@ import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
+import GHC.Cmm.DebugBlock (pprUnwindTable)
import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)
import GHC.Types.Unique ( pprUniqueAlways )
@@ -65,12 +63,12 @@ import Data.Word
-- .subsections_via_symbols and -dead_strip can be found at
-- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>
-pprProcAlignment :: NCGConfig -> SDoc
+pprProcAlignment :: IsDoc doc => NCGConfig -> doc
pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
where
platform = ncgPlatform config
-pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc
+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
pprSectionAlign config section $$ pprDatas config dats
@@ -85,7 +83,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprProcLabel config lbl $$
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$
+ ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$
pprSizeDecl platform lbl
Just (CmmStaticsRaw info_lbl _) ->
@@ -93,48 +91,51 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprProcAlignment config $$
pprProcLabel config lbl $$
(if platformHasSubsectionsViaSymbols platform
- then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon
+ then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon)
else empty) $$
vcat (map (pprBasicBlock config top_info) blocks) $$
- ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$
+ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
- text "\t.long "
+ line
+ $ text "\t.long "
<+> pprAsmLabel platform info_lbl
<+> char '-'
<+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-}
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Output an internal proc label. See Note [Internal proc labels] in CLabel.
-pprProcLabel :: NCGConfig -> CLabel -> SDoc
+pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc
pprProcLabel config lbl
| ncgExposeInternalSymbols config
, Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl
- = lbl' <> colon
+ = line (lbl' <> colon)
| otherwise
= empty
-pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name
- -> SDoc
+pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
+ -> doc
pprProcEndLabel platform lbl =
pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
-pprBlockEndLabel :: Platform -> CLabel -- ^ Block name
- -> SDoc
+pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name
+ -> doc
pprBlockEndLabel platform lbl =
pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon
-- | Output the ELF .size directive.
-pprSizeDecl :: Platform -> CLabel -> SDoc
+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl
+ then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
else empty
-pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc
pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
@@ -142,8 +143,8 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
ppWhen (ncgDwarfEnabled config) (
-- Emit both end labels since this may end up being a standalone
-- top-level block
- pprBlockEndLabel platform asmLbl
- <> pprProcEndLabel platform asmLbl
+ line (pprBlockEndLabel platform asmLbl
+ <> pprProcEndLabel platform asmLbl)
)
where
asmLbl = blockLbl blockid
@@ -156,7 +157,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
vcat (map (pprData config) info) $$
pprLabel platform infoLbl $$
c $$
- ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon)
+ ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon))
-- Make sure the info table has the right .loc for the block
-- coming right after it. See Note [Info Offset]
@@ -165,7 +166,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
_other -> empty
-pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc
+pprDatas :: IsDoc doc => NCGConfig -> (Alignment, RawCmmStatics) -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
@@ -175,31 +176,32 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl (ncgPlatform config) alias
- $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind'
+ $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
pprDatas config (align, (CmmStaticsRaw lbl dats))
= vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)
where
platform = ncgPlatform config
-pprData :: NCGConfig -> CmmStatic -> SDoc
-pprData _config (CmmString str) = pprString str
-pprData _config (CmmFileEmbed path _) = pprFileEmbed path
+pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
+pprData _config (CmmString str) = line (pprString str)
+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
pprData config (CmmUninitialised bytes)
- = let platform = ncgPlatform config
+ = line
+ $ let platform = ncgPlatform config
in if platformOS platform == OSDarwin
then text ".space " <> int bytes
else text ".skip " <> int bytes
pprData config (CmmStaticLit lit) = pprDataItem config lit
-pprGloblDecl :: Platform -> CLabel -> SDoc
+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text ".globl " <> pprAsmLabel platform lbl
+ | otherwise = line (text ".globl " <> pprAsmLabel platform lbl)
-pprLabelType' :: Platform -> CLabel -> SDoc
+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc
pprLabelType' platform lbl =
if isCFunctionLabel lbl || functionOkInfoTable then
text "@function"
@@ -257,21 +259,21 @@ pprLabelType' platform lbl =
isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
-pprTypeDecl :: Platform -> CLabel -> SDoc
+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
- then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl
+ then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
else empty
-pprLabel :: Platform -> CLabel -> SDoc
+pprLabel :: IsDoc doc => Platform -> CLabel -> doc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeDecl platform lbl
- $$ (pprAsmLabel platform lbl <> colon)
+ $$ line (pprAsmLabel platform lbl <> colon)
-pprAlign :: Platform -> Alignment -> SDoc
+pprAlign :: IsDoc doc => Platform -> Alignment -> doc
pprAlign platform alignment
- = text ".align " <> int (alignmentOn platform)
+ = line $ text ".align " <> int (alignmentOn platform)
where
bytes = alignmentBytes alignment
alignmentOn platform = if platformOS platform == OSDarwin
@@ -285,7 +287,7 @@ pprAlign platform alignment
log2 8 = 3
log2 n = 1 + log2 (n `quot` 2)
-pprReg :: Platform -> Format -> Reg -> SDoc
+pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc
pprReg platform f r
= case r of
RegReal (RealRegSingle i) ->
@@ -297,7 +299,7 @@ pprReg platform f r
RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u
where
- ppr32_reg_no :: Format -> Int -> SDoc
+ ppr32_reg_no :: Format -> Int -> doc
ppr32_reg_no II8 = ppr32_reg_byte
ppr32_reg_no II16 = ppr32_reg_word
ppr32_reg_no _ = ppr32_reg_long
@@ -327,7 +329,7 @@ pprReg platform f r
_ -> ppr_reg_float i
}
- ppr64_reg_no :: Format -> Int -> SDoc
+ ppr64_reg_no :: Format -> Int -> doc
ppr64_reg_no II8 = ppr64_reg_byte
ppr64_reg_no II16 = ppr64_reg_word
ppr64_reg_no II32 = ppr64_reg_long
@@ -385,7 +387,7 @@ pprReg platform f r
_ -> ppr_reg_float i
}
-ppr_reg_float :: Int -> SDoc
+ppr_reg_float :: IsLine doc => Int -> doc
ppr_reg_float i = case i of
16 -> text "%xmm0" ; 17 -> text "%xmm1"
18 -> text "%xmm2" ; 19 -> text "%xmm3"
@@ -397,7 +399,7 @@ ppr_reg_float i = case i of
30 -> text "%xmm14"; 31 -> text "%xmm15"
_ -> text "very naughty x86 register"
-pprFormat :: Format -> SDoc
+pprFormat :: IsLine doc => Format -> doc
pprFormat x = case x of
II8 -> text "b"
II16 -> text "w"
@@ -406,14 +408,14 @@ pprFormat x = case x of
FF32 -> text "ss" -- "scalar single-precision float" (SSE2)
FF64 -> text "sd" -- "scalar double-precision float" (SSE2)
-pprFormat_x87 :: Format -> SDoc
+pprFormat_x87 :: IsLine doc => Format -> doc
pprFormat_x87 x = case x of
FF32 -> text "s"
FF64 -> text "l"
_ -> panic "X86.Ppr.pprFormat_x87"
-pprCond :: Cond -> SDoc
+pprCond :: IsLine doc => Cond -> doc
pprCond c = case c of {
GEU -> text "ae"; LU -> text "b";
EQQ -> text "e"; GTT -> text "g";
@@ -426,7 +428,7 @@ pprCond c = case c of {
ALWAYS -> text "mp"}
-pprImm :: Platform -> Imm -> SDoc
+pprImm :: IsLine doc => Platform -> Imm -> doc
pprImm platform = \case
ImmInt i -> int i
ImmInteger i -> integer i
@@ -440,7 +442,7 @@ pprImm platform = \case
-pprAddr :: Platform -> AddrMode -> SDoc
+pprAddr :: IsLine doc => Platform -> AddrMode -> doc
pprAddr platform (ImmAddr imm off)
= let pp_imm = pprImm platform imm
in
@@ -471,16 +473,16 @@ pprAddr platform (AddrBaseIndex base index displacement)
ppr_disp imm = pprImm platform imm
-- | Print section header and appropriate alignment for that section.
-pprSectionAlign :: NCGConfig -> Section -> SDoc
+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
pprSectionAlign _config (Section (OtherSection _) _) =
panic "X86.Ppr.pprSectionAlign: unknown section"
pprSectionAlign config sec@(Section seg _) =
- pprSectionHeader config sec $$
+ line (pprSectionHeader config sec) $$
pprAlignForSection (ncgPlatform config) seg
-- | Print appropriate alignment for the given section type.
-pprAlignForSection :: Platform -> SectionType -> SDoc
-pprAlignForSection platform seg =
+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
+pprAlignForSection platform seg = line $
text ".align " <>
case platformOS platform of
-- Darwin: alignments are given as shifts.
@@ -505,9 +507,9 @@ pprAlignForSection platform seg =
CString -> int 1
_ -> int 8
-pprDataItem :: NCGConfig -> CmmLit -> SDoc
+pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc
pprDataItem config lit
- = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
+ = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
platform = ncgPlatform config
imm = litToImm lit
@@ -535,26 +537,26 @@ pprDataItem config lit
_ -> [text "\t.quad\t" <> pprImm platform imm]
-asmComment :: SDoc -> SDoc
+asmComment :: IsLine doc => doc -> doc
asmComment c = whenPprDebug $ text "# " <> c
-pprInstr :: Platform -> Instr -> SDoc
+pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc
pprInstr platform i = case i of
COMMENT s
- -> asmComment s
+ -> line (asmComment (ftext s))
- LOCATION file line col _name
- -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col
+ LOCATION file line' col _name
+ -> line (text "\t.loc " <> int file <+> int line' <+> int col)
DELTA d
- -> asmComment $ text ("\tdelta = " ++ show d)
+ -> line (asmComment $ text ("\tdelta = " ++ show d))
NEWBLOCK _
-> panic "pprInstr: NEWBLOCK"
UNWIND lbl d
- -> asmComment (text "\tunwind = " <> pdoc platform d)
- $$ pprAsmLabel platform lbl <> colon
+ -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d))
+ $$ line (pprAsmLabel platform lbl <> colon)
LDATA _ _
-> panic "pprInstr: LDATA"
@@ -772,19 +774,19 @@ pprInstr platform i = case i of
-- POPA -> text "\tpopal"
NOP
- -> text "\tnop"
+ -> line $ text "\tnop"
CLTD II8
- -> text "\tcbtw"
+ -> line $ text "\tcbtw"
CLTD II16
- -> text "\tcwtd"
+ -> line $ text "\tcwtd"
CLTD II32
- -> text "\tcltd"
+ -> line $ text "\tcltd"
CLTD II64
- -> text "\tcqto"
+ -> line $ text "\tcqto"
CLTD x
-> panic $ "pprInstr: CLTD " ++ show x
@@ -803,19 +805,19 @@ pprInstr platform i = case i of
-> pprCondInstr (text "j") cond (pprImm platform imm)
JMP (OpImm imm) _
- -> text "\tjmp " <> pprImm platform imm
+ -> line $ text "\tjmp " <> pprImm platform imm
JMP op _
- -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op
+ -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op
JMP_TBL op _ _ _
-> pprInstr platform (JMP op [])
CALL (Left imm) _
- -> text "\tcall " <> pprImm platform imm
+ -> line $ text "\tcall " <> pprImm platform imm
CALL (Right reg) _
- -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg
+ -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg
IDIV fmt op
-> pprFormatOp (text "idiv") fmt op
@@ -859,20 +861,20 @@ pprInstr platform i = case i of
-- FETCHGOT for PIC on ELF platforms
FETCHGOT reg
- -> vcat [ text "\tcall 1f",
- hcat [ text "1:\tpopl\t", pprReg platform II32 reg ],
- hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",
- pprReg platform II32 reg ]
- ]
+ -> lines_ [ text "\tcall 1f",
+ hcat [ text "1:\tpopl\t", pprReg platform II32 reg ],
+ hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",
+ pprReg platform II32 reg ]
+ ]
-- FETCHPC for PIC on Darwin/x86
-- get the instruction pointer into a register
-- (Terminology note: the IP is called Program Counter on PPC,
-- and it's a good thing to use the same name on both platforms)
FETCHPC reg
- -> vcat [ text "\tcall 1f",
- hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]
- ]
+ -> lines_ [ text "\tcall 1f",
+ hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]
+ ]
-- the
-- GST fmt src addr ==> FLD dst ; FSTPsz addr
@@ -881,10 +883,10 @@ pprInstr platform i = case i of
-- Atomics
LOCK i
- -> text "\tlock" $$ pprInstr platform i
+ -> line (text "\tlock") $$ pprInstr platform i
MFENCE
- -> text "\tmfence"
+ -> line $ text "\tmfence"
XADD format src dst
-> pprFormatOpOp (text "xadd") format src dst
@@ -894,46 +896,46 @@ pprInstr platform i = case i of
where
- gtab :: SDoc
+ gtab :: Line doc
gtab = char '\t'
- gsp :: SDoc
+ gsp :: Line doc
gsp = char ' '
- pprX87 :: Instr -> SDoc -> SDoc
+ pprX87 :: Instr -> Line doc -> doc
pprX87 fake actual
- = (char '#' <> pprX87Instr fake) $$ actual
+ = line (char '#' <> pprX87Instr fake) $$ line actual
- pprX87Instr :: Instr -> SDoc
+ pprX87Instr :: Instr -> Line doc
pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst
pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"
- pprDollImm :: Imm -> SDoc
+ pprDollImm :: Imm -> Line doc
pprDollImm i = text "$" <> pprImm platform i
- pprOperand :: Platform -> Format -> Operand -> SDoc
+ pprOperand :: Platform -> Format -> Operand -> Line doc
pprOperand platform f op = case op of
OpReg r -> pprReg platform f r
OpImm i -> pprDollImm i
OpAddr ea -> pprAddr platform ea
- pprMnemonic_ :: SDoc -> SDoc
+ pprMnemonic_ :: Line doc -> Line doc
pprMnemonic_ name =
char '\t' <> name <> space
- pprMnemonic :: SDoc -> Format -> SDoc
+ pprMnemonic :: Line doc -> Format -> Line doc
pprMnemonic name format =
char '\t' <> name <> pprFormat format <> space
- pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc
+ pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc
pprFormatImmOp name format imm op1
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
char '$',
pprImm platform imm,
@@ -942,24 +944,24 @@ pprInstr platform i = case i of
]
- pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc
+ pprFormatOp_ :: Line doc -> Format -> Operand -> doc
pprFormatOp_ name format op1
- = hcat [
+ = line $ hcat [
pprMnemonic_ name ,
pprOperand platform format op1
]
- pprFormatOp :: SDoc -> Format -> Operand -> SDoc
+ pprFormatOp :: Line doc -> Format -> Operand -> doc
pprFormatOp name format op1
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
pprOperand platform format op1
]
- pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc
+ pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc
pprFormatOpOp name format op1 op2
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
pprOperand platform format op1,
comma,
@@ -967,18 +969,18 @@ pprInstr platform i = case i of
]
- pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc
+ pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc
pprOpOp name format op1 op2
- = hcat [
+ = line $ hcat [
pprMnemonic_ name,
pprOperand platform format op1,
comma,
pprOperand platform format op2
]
- pprRegReg :: SDoc -> Reg -> Reg -> SDoc
+ pprRegReg :: Line doc -> Reg -> Reg -> doc
pprRegReg name reg1 reg2
- = hcat [
+ = line $ hcat [
pprMnemonic_ name,
pprReg platform (archWordFormat (target32Bit platform)) reg1,
comma,
@@ -986,18 +988,18 @@ pprInstr platform i = case i of
]
- pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc
+ pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc
pprFormatOpReg name format op1 reg2
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
pprOperand platform format op1,
comma,
pprReg platform (archWordFormat (target32Bit platform)) reg2
]
- pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc
+ pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc
pprCondOpReg name format cond op1 reg2
- = hcat [
+ = line $ hcat [
char '\t',
name,
pprCond cond,
@@ -1007,18 +1009,18 @@ pprInstr platform i = case i of
pprReg platform format reg2
]
- pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc
+ pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc
pprFormatFormatOpReg name format1 format2 op1 reg2
- = hcat [
+ = line $ hcat [
pprMnemonic name format2,
pprOperand platform format1 op1,
comma,
pprReg platform format2 reg2
]
- pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc
+ pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc
pprFormatOpOpReg name format op1 op2 reg3
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
pprOperand platform format op1,
comma,
@@ -1029,7 +1031,7 @@ pprInstr platform i = case i of
- pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc
+ pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc
pprFormatAddr name format op
= hcat [
pprMnemonic name format,
@@ -1037,9 +1039,9 @@ pprInstr platform i = case i of
pprAddr platform op
]
- pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc
+ pprShift :: Line doc -> Format -> Operand -> Operand -> doc
pprShift name format src dest
- = hcat [
+ = line $ hcat [
pprMnemonic name format,
pprOperand platform II8 src, -- src is 8-bit sized
comma,
@@ -1047,15 +1049,15 @@ pprInstr platform i = case i of
]
- pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc
+ pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc
pprFormatOpOpCoerce name format1 format2 op1 op2
- = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,
+ = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,
pprOperand platform format1 op1,
comma,
pprOperand platform format2 op2
]
- pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc
+ pprCondInstr :: Line doc -> Cond -> Line doc -> doc
pprCondInstr name cond arg
- = hcat [ char '\t', name, pprCond cond, space, arg]
+ = line $ hcat [ char '\t', name, pprCond cond, space, arg]
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 1b7e30dfec..7acf31ef0d 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -3299,6 +3299,7 @@ addEvals _scrut con vs = go vs the_strs
where
ppr_with_length list
= ppr list <+> parens (text "length =" <+> ppr (length list))
+ strdisp :: StrictnessMark -> SDoc
strdisp MarkedStrict = text "MarkedStrict"
strdisp NotMarkedStrict = text "NotMarkedStrict"
diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs
index 605754b0ae..c26cdb0dad 100644
--- a/compiler/GHC/Linker/Types.hs
+++ b/compiler/GHC/Linker/Types.hs
@@ -5,7 +5,7 @@
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
-
+{-# LANGUAGE TypeApplications #-}
module GHC.Linker.Types
( Loader (..)
, LoaderState (..)
@@ -254,7 +254,7 @@ data LibrarySpec
| Framework String -- Only used for darwin, but does no harm
instance Outputable LibrarySpec where
- ppr (Objects objs) = text "Objects" <+> ppr (map text objs)
+ ppr (Objects objs) = text "Objects" <+> ppr (map (text @SDoc) objs)
ppr (Archive a) = text "Archive" <+> text a
ppr (DLL s) = text "DLL" <+> text s
ppr (DLLPath f) = text "DLLPath" <+> text f
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs
index cbfe4637a3..75b500694e 100644
--- a/compiler/GHC/Types/CostCentre.hs
+++ b/compiler/GHC/Types/CostCentre.hs
@@ -3,7 +3,9 @@ module GHC.Types.CostCentre (
CostCentre(..), CcName, CCFlavour(..),
-- All abstract except to friend: ParseIface.y
+ pprCostCentre,
CostCentreStack,
+ pprCostCentreStack,
CollectedCCs, emptyCollectedCCs, collectCC,
currentCCS, dontCareCCS,
isCurrentCCS,
@@ -236,10 +238,14 @@ mkSingletonCCS cc = SingletonCCS cc
-- expression.
instance Outputable CostCentreStack where
- ppr CurrentCCS = text "CCCS"
- ppr DontCareCCS = text "CCS_DONT_CARE"
- ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
+ ppr = pprCostCentreStack
+pprCostCentreStack :: IsLine doc => CostCentreStack -> doc
+pprCostCentreStack CurrentCCS = text "CCCS"
+pprCostCentreStack DontCareCCS = text "CCS_DONT_CARE"
+pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs"
+{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-}
+{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-----------------------------------------------------------------------------
-- Printing Cost Centres
@@ -256,10 +262,15 @@ instance Outputable CostCentreStack where
-- by costCentreName.
instance Outputable CostCentre where
- ppr cc = getPprStyle $ \ sty ->
- if codeStyle sty
- then ppCostCentreLbl cc
- else ftext (costCentreUserNameFS cc)
+ ppr = pprCostCentre
+
+pprCostCentre :: IsLine doc => CostCentre -> doc
+pprCostCentre cc = docWithContext $ \ sty ->
+ if codeStyle (sdocStyle sty)
+ then ppCostCentreLbl cc
+ else ftext (costCentreUserNameFS cc)
+{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-}
+{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- Printing in Core
pprCostCentreCore :: CostCentre -> SDoc
@@ -284,26 +295,32 @@ pprIdxCore 0 = empty
pprIdxCore idx = whenPprDebug $ ppr idx
-- Printing as a C label
-ppCostCentreLbl :: CostCentre -> SDoc
-ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
+ppCostCentreLbl :: IsLine doc => CostCentre -> doc
+ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModule m <> text "_CAFs_cc"
ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
- = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
+ = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
ppFlavourLblComponent f <> text "_cc"
+{-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-}
+{-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- ^ Print the flavour component of a C label
-ppFlavourLblComponent :: CCFlavour -> SDoc
+ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc
ppFlavourLblComponent CafCC = text "CAF"
ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i
+{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-}
+{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- ^ Print the flavour index component of a C label
-ppIdxLblComponent :: CostCentreIndex -> SDoc
+ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc
ppIdxLblComponent n =
case unCostCentreIndex n of
0 -> empty
- n -> ppr n
+ n -> int n
+{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-}
+{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- This is the name to go in the user-displayed string,
-- recorded in the cost centre declaration
diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs
index f366ddbf4a..949b750d38 100644
--- a/compiler/GHC/Types/ForeignStubs.hs
+++ b/compiler/GHC/Types/ForeignStubs.hs
@@ -1,5 +1,6 @@
-- | Foreign export stubs
{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Types.ForeignStubs
( ForeignStubs (..)
, CHeader(..)
@@ -68,10 +69,10 @@ newtype CHeader = CHeader { getCHeader :: SDoc }
instance Monoid CHeader where
mempty = CHeader empty
- mconcat = coerce vcat
+ mconcat = coerce (vcat @SDoc)
instance Semigroup CHeader where
- (<>) = coerce ($$)
+ (<>) = coerce (($$) @SDoc)
-- | Foreign export stubs
data ForeignStubs
diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs
index 8176bec011..1b70c4d910 100644
--- a/compiler/GHC/Types/Name.hs
+++ b/compiler/GHC/Types/Name.hs
@@ -56,6 +56,7 @@ module GHC.Types.Name (
localiseName,
namePun_maybe,
+ pprName,
nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
pprFullName, pprTickyName,
@@ -624,12 +625,13 @@ instance OutputableBndr Name where
pprInfixOcc = pprInfixName
pprPrefixOcc = pprPrefixName
-pprName :: Name -> SDoc
+pprName :: forall doc. IsLine doc => Name -> doc
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
- = getPprStyle $ \sty ->
- getPprDebug $ \debug ->
- sdocOption sdocListTuplePuns $ \listTuplePuns ->
- handlePuns listTuplePuns (namePun_maybe name) $
+ = docWithContext $ \ctx ->
+ let sty = sdocStyle ctx
+ debug = sdocPprDebug ctx
+ listTuplePuns = sdocListTuplePuns ctx
+ in handlePuns listTuplePuns (namePun_maybe name) $
case sort of
WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin
External mod -> pprExternal debug sty uniq mod occ False UserSyntax
@@ -637,9 +639,11 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
Internal -> pprInternal debug sty uniq occ
where
-- Print GHC.Types.List as [], etc.
- handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc
+ handlePuns :: Bool -> Maybe FastString -> doc -> doc
handlePuns True (Just pun) _ = ftext pun
handlePuns _ _ r = r
+{-# SPECIALISE pprName :: Name -> SDoc #-}
+{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print fully qualified name (with unit-id, module and unique)
pprFullName :: Module -> Name -> SDoc
@@ -670,9 +674,9 @@ pprTickyName this_mod name
pprNameUnqualified :: Name -> SDoc
pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
-pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
+pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc
pprExternal debug sty uniq mod occ is_wired is_builtin
- | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
+ | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ
-- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified
-- in code style, to reduce symbol table bloat?
@@ -685,13 +689,13 @@ pprExternal debug sty uniq mod occ is_wired is_builtin
if isHoleModule mod
then case qualName sty mod occ of
NameUnqual -> ppr_occ_name occ
- _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)
+ _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ)
else pprModulePrefix sty mod occ <> ppr_occ_name occ
where
pp_mod = ppUnlessOption sdocSuppressModulePrefixes
- (ppr mod <> dot)
+ (pprModule mod <> dot)
-pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc
+pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
pprInternal debug sty uniq occ
| codeStyle sty = pprUniqueAlways uniq
| debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),
@@ -702,7 +706,7 @@ pprInternal debug sty uniq occ
| otherwise = ppr_occ_name occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
-pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc
+pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
pprSystem debug sty uniq occ
| codeStyle sty = pprUniqueAlways uniq
| debug = ppr_occ_name occ <> ppr_underscore_unique uniq
@@ -713,38 +717,38 @@ pprSystem debug sty uniq occ
-- so print the unique
-pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
+pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc
-- Print the "M." part of a name, based on whether it's in scope or not
-- See Note [Printing original names] in GHC.Types.Name.Ppr
pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
case qualName sty mod occ of -- See Outputable.QualifyName:
- NameQual modname -> ppr modname <> dot -- Name is in scope
- NameNotInScope1 -> ppr mod <> dot -- Not in scope
- NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in
- <> ppr (moduleName mod) <> dot -- scope either
+ NameQual modname -> pprModuleName modname <> dot -- Name is in scope
+ NameNotInScope1 -> pprModule mod <> dot -- Not in scope
+ NameNotInScope2 -> pprUnit (moduleUnit mod) <> colon -- Module not in
+ <> pprModuleName (moduleName mod) <> dot -- scope either
NameUnqual -> empty -- In scope unqualified
-pprUnique :: Unique -> SDoc
+pprUnique :: IsLine doc => Unique -> doc
-- Print a unique unless we are suppressing them
pprUnique uniq
= ppUnlessOption sdocSuppressUniques $
pprUniqueAlways uniq
-ppr_underscore_unique :: Unique -> SDoc
+ppr_underscore_unique :: IsLine doc => Unique -> doc
-- Print an underscore separating the name from its unique
-- But suppress it if we aren't printing the uniques anyway
ppr_underscore_unique uniq
= ppUnlessOption sdocSuppressUniques $
char '_' <> pprUniqueAlways uniq
-ppr_occ_name :: OccName -> SDoc
+ppr_occ_name :: IsLine doc => OccName -> doc
ppr_occ_name occ = ftext (occNameFS occ)
-- Don't use pprOccName; instead, just print the string of the OccName;
-- we print the namespace in the debug stuff above
-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are
-- cached behind the scenes in the FastString implementation.
-ppr_z_occ_name :: OccName -> SDoc
+ppr_z_occ_name :: IsLine doc => OccName -> doc
ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))
-- Prints (if mod information is available) "Defined at <loc>" or
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index 38eefebc59..0faf042b4e 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/compiler/GHC/Types/Name/Occurrence.hs
@@ -200,7 +200,7 @@ pprNonVarNameSpace :: NameSpace -> SDoc
pprNonVarNameSpace VarName = empty
pprNonVarNameSpace ns = pprNameSpace ns
-pprNameSpaceBrief :: NameSpace -> SDoc
+pprNameSpaceBrief :: IsLine doc => NameSpace -> doc
pprNameSpaceBrief DataName = char 'd'
pprNameSpaceBrief VarName = char 'v'
pprNameSpaceBrief TvName = text "tv"
@@ -276,10 +276,10 @@ instance OutputableBndr OccName where
pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)
pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)
-pprOccName :: OccName -> SDoc
+pprOccName :: IsLine doc => OccName -> doc
pprOccName (OccName sp occ)
- = getPprStyle $ \ sty ->
- if codeStyle sty
+ = docWithContext $ \ sty ->
+ if codeStyle (sdocStyle sty)
then ztext (zEncodeFS occ)
else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs
index 60d1c452e2..c17d080f6f 100644
--- a/compiler/GHC/Types/Unique.hs
+++ b/compiler/GHC/Types/Unique.hs
@@ -281,13 +281,15 @@ showUnique uniq
= case unpkUnique uniq of
(tag, u) -> tag : iToBase62 u
-pprUniqueAlways :: Unique -> SDoc
+pprUniqueAlways :: IsLine doc => Unique -> doc
-- The "always" means regardless of -dsuppress-uniques
-- It replaces the old pprUnique to remind callers that
-- they should consider whether they want to consult
-- Opt_SuppressUniques
pprUniqueAlways u
= text (showUnique u)
+{-# SPECIALIZE pprUniqueAlways :: Unique -> SDoc #-}
+{-# SPECIALIZE pprUniqueAlways :: Unique -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
instance Outputable Unique where
ppr = pprUniqueAlways
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index 0e08f6860b..4fe2b932f6 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -50,6 +50,7 @@ module GHC.Unit.Types
, stableUnitCmp
, unitIsDefinite
, isHoleUnit
+ , pprUnit
-- * Unit Ids
, unitIdString
@@ -163,19 +164,24 @@ instance Outputable InstantiatedModule where
ppr = pprInstantiatedModule
instance Outputable InstantiatedUnit where
- ppr uid =
+ ppr = pprInstantiatedUnit
+
+pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc
+pprInstantiatedUnit uid =
-- getPprStyle $ \sty ->
- ppr cid <>
+ pprUnitId cid <>
(if not (null insts) -- pprIf
then
brackets (hcat
(punctuate comma $
- [ ppr modname <> text "=" <> pprModule m
+ [ pprModuleName modname <> text "=" <> pprModule m
| (modname, m) <- insts]))
else empty)
where
cid = instUnitInstanceOf uid
insts = instUnitInsts uid
+{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-}
+{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit)
--
@@ -196,8 +202,8 @@ instance IsUnitId u => IsUnitId (GenUnit u) where
unitFS (RealUnit (Definite x)) = unitFS x
unitFS HoleUnit = holeFS
-pprModule :: Module -> SDoc
-pprModule mod@(Module p n) = getPprStyle doc
+pprModule :: IsLine doc => Module -> doc
+pprModule mod@(Module p n) = docWithContext (doc . sdocStyle)
where
doc sty
| codeStyle sty =
@@ -208,10 +214,11 @@ pprModule mod@(Module p n) = getPprStyle doc
| qualModule sty mod =
case p of
HoleUnit -> angleBrackets (pprModuleName n)
- _ -> ppr p <> char ':' <> pprModuleName n
+ _ -> pprUnit p <> char ':' <> pprModuleName n
| otherwise =
pprModuleName n
-
+{-# SPECIALIZE pprModule :: Module -> SDoc #-}
+{-# SPECIALIZE pprModule :: Module -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
pprInstantiatedModule :: InstantiatedModule -> SDoc
pprInstantiatedModule (Module uid m) =
@@ -345,10 +352,12 @@ stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2
instance Outputable Unit where
ppr pk = pprUnit pk
-pprUnit :: Unit -> SDoc
-pprUnit (RealUnit uid) = ppr uid
-pprUnit (VirtUnit uid) = ppr uid
+pprUnit :: IsLine doc => Unit -> doc
+pprUnit (RealUnit (Definite d)) = pprUnitId d
+pprUnit (VirtUnit uid) = pprInstantiatedUnit uid
pprUnit HoleUnit = ftext holeFS
+{-# SPECIALIZE pprUnit :: Unit -> SDoc #-}
+{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
instance Show Unit where
show = unitString
@@ -524,8 +533,14 @@ instance Uniquable UnitId where
getUnique = getUnique . unitIdFS
instance Outputable UnitId where
- ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId]
- -- in "GHC.Unit"
+ ppr = pprUnitId
+
+pprUnitId :: IsLine doc => UnitId -> doc
+pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs)
+ -- see Note [Pretty-printing UnitId] in GHC.Unit
+ -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable
+{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-}
+{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | A 'DefUnitId' is an 'UnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
diff --git a/compiler/GHC/Utils/Asm.hs b/compiler/GHC/Utils/Asm.hs
index 2841ad3efa..237e482661 100644
--- a/compiler/GHC/Utils/Asm.hs
+++ b/compiler/GHC/Utils/Asm.hs
@@ -12,9 +12,10 @@ import GHC.Platform
import GHC.Utils.Outputable
-- | Generate a section type (e.g. @\@progbits@). See #13937.
-sectionType :: Platform -- ^ Target platform
+sectionType :: IsLine doc
+ => Platform -- ^ Target platform
-> String -- ^ section type
- -> SDoc -- ^ pretty assembler fragment
+ -> doc -- ^ pretty assembler fragment
sectionType platform ty =
case platformArch platform of
ArchARM{} -> char '%' <> text ty
diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs
index b7b0981117..79d2dbed60 100644
--- a/compiler/GHC/Utils/BufHandle.hs
+++ b/compiler/GHC/Utils/BufHandle.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
-----------------------------------------------------------------------------
--
@@ -37,6 +38,10 @@ import Foreign
import Foreign.C.String
import System.IO
+-- for RULES
+import GHC.Exts (unpackCString#, unpackNBytes#, Int(..))
+import GHC.Ptr (Ptr(..))
+
-- -----------------------------------------------------------------------------
data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
@@ -62,6 +67,22 @@ bPutChar b@(BufHandle buf r hdl) !c = do
else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
writeFastMutInt r (i+1)
+-- Equivalent of the text/str, text/unpackNBytes#, text/[] rules
+-- in GHC.Utils.Ppr.
+{-# RULES "hdoc/str"
+ forall a h. bPutStr h (unpackCString# a) = bPutPtrString h (mkPtrString# a)
+ #-}
+{-# RULES "hdoc/unpackNBytes#"
+ forall p n h. bPutStr h (unpackNBytes# p n) = bPutPtrString h (PtrString (Ptr p) (I# n))
+ #-}
+{-# RULES "hdoc/[]#"
+ forall h. bPutStr h [] = return ()
+ #-}
+
+{-# NOINLINE [0] bPutStr #-} -- Give the RULE a chance to fire
+ -- It must wait till after phase 1 when
+ -- the unpackCString first is manifested
+
bPutStr :: BufHandle -> String -> IO ()
bPutStr (BufHandle buf r hdl) !str = do
i <- readFastMutInt r
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index d7300242bd..87bfd89909 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -5,6 +5,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
{-
(c) The University of Glasgow 2006-2012
@@ -21,15 +23,17 @@ module GHC.Utils.Outputable (
-- * Type classes
Outputable(..), OutputableBndr(..), OutputableP(..),
+ IsOutput(..), IsLine(..), IsDoc(..),
+ HLine, HDoc,
+
-- * Pretty printing combinators
SDoc, runSDoc, PDoc(..),
docToSDoc,
interppSP, interpp'SP, interpp'SP',
pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
pprWithBars,
- empty, isEmpty, nest,
- char,
- text, ftext, ptext, ztext,
+ isEmpty, nest,
+ ptext,
int, intWithCommas, integer, word, float, double, rational, doublePrec,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets,
@@ -38,10 +42,8 @@ module GHC.Utils.Outputable (
lambda,
lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
blankLine, forAllLit, bullet,
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
+ ($+$),
+ cat, fcat,
hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
ppWhenOption, ppUnlessOption,
speakNth, speakN, speakNOf, plural, singular,
@@ -104,6 +106,7 @@ module GHC.Utils.Outputable (
ifPprDebug, whenPprDebug, getPprDebug,
+ bPutHDoc
) where
import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
@@ -113,7 +116,7 @@ import GHC.Prelude.Basic
import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName )
import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName )
-import GHC.Utils.BufHandle (BufHandle)
+import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS)
import GHC.Data.FastString
import qualified GHC.Utils.Ppr as Pretty
import qualified GHC.Utils.Ppr.Colour as Col
@@ -548,17 +551,17 @@ userStyle (PprUser {}) = True
userStyle _other = False
-- | Indicate if -dppr-debug mode is enabled
-getPprDebug :: (Bool -> SDoc) -> SDoc
+getPprDebug :: IsOutput doc => (Bool -> doc) -> doc
{-# INLINE CONLIKE getPprDebug #-}
-getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx)
+getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx)
-- | Says what to do with and without -dppr-debug
-ifPprDebug :: SDoc -> SDoc -> SDoc
+ifPprDebug :: IsOutput doc => doc -> doc -> doc
{-# INLINE CONLIKE ifPprDebug #-}
ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no
-- | Says what to do with -dppr-debug; without, return empty
-whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style
+whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style
{-# INLINE CONLIKE whenPprDebug #-}
whenPprDebug d = ifPprDebug d empty
@@ -625,43 +628,26 @@ isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True})
docToSDoc :: Doc -> SDoc
docToSDoc d = SDoc (\_ -> d)
-empty :: SDoc
-char :: Char -> SDoc
-text :: String -> SDoc
-ftext :: FastString -> SDoc
-ptext :: PtrString -> SDoc
-ztext :: FastZString -> SDoc
-int :: Int -> SDoc
-integer :: Integer -> SDoc
-word :: Integer -> SDoc
-float :: Float -> SDoc
-double :: Double -> SDoc
-rational :: Rational -> SDoc
-
-{-# INLINE CONLIKE empty #-}
-empty = docToSDoc $ Pretty.empty
-{-# INLINE CONLIKE char #-}
-char c = docToSDoc $ Pretty.char c
-
-{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire
-text s = docToSDoc $ Pretty.text s
-
-{-# INLINE CONLIKE ftext #-}
-ftext s = docToSDoc $ Pretty.ftext s
+ptext :: PtrString -> SDoc
+int :: IsLine doc => Int -> doc
+integer :: IsLine doc => Integer -> doc
+word :: Integer -> SDoc
+float :: IsLine doc => Float -> doc
+double :: IsLine doc => Double -> doc
+rational :: Rational -> SDoc
+
{-# INLINE CONLIKE ptext #-}
ptext s = docToSDoc $ Pretty.ptext s
-{-# INLINE CONLIKE ztext #-}
-ztext s = docToSDoc $ Pretty.ztext s
{-# INLINE CONLIKE int #-}
-int n = docToSDoc $ Pretty.int n
+int n = text $ show n
{-# INLINE CONLIKE integer #-}
-integer n = docToSDoc $ Pretty.integer n
+integer n = text $ show n
{-# INLINE CONLIKE float #-}
-float n = docToSDoc $ Pretty.float n
+float n = text $ show n
{-# INLINE CONLIKE double #-}
-double n = docToSDoc $ Pretty.double n
+double n = text $ show n
{-# INLINE CONLIKE rational #-}
-rational n = docToSDoc $ Pretty.rational n
+rational n = text $ show n
-- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr
{-# INLINE CONLIKE word #-}
word n = sdocOption sdocHexWordLiterals $ \case
@@ -673,19 +659,19 @@ word n = sdocOption sdocHexWordLiterals $ \case
doublePrec :: Int -> Double -> SDoc
doublePrec p n = text (showFFloat (Just p) n "")
-parens, braces, brackets, quotes, quote,
- doubleQuotes, angleBrackets :: SDoc -> SDoc
+quotes, quote :: SDoc -> SDoc
+parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc
{-# INLINE CONLIKE parens #-}
-parens d = SDoc $ Pretty.parens . runSDoc d
+parens d = char '(' <> d <> char ')'
{-# INLINE CONLIKE braces #-}
-braces d = SDoc $ Pretty.braces . runSDoc d
+braces d = char '{' <> d <> char '}'
{-# INLINE CONLIKE brackets #-}
-brackets d = SDoc $ Pretty.brackets . runSDoc d
+brackets d = char '[' <> d <> char ']'
{-# INLINE CONLIKE quote #-}
quote d = SDoc $ Pretty.quote . runSDoc d
{-# INLINE CONLIKE doubleQuotes #-}
-doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+doubleQuotes d = char '"' <> d <> char '"'
{-# INLINE CONLIKE angleBrackets #-}
angleBrackets d = char '<' <> d <> char '>'
@@ -707,35 +693,37 @@ quotes d = sdocOption sdocCanUseUnicode $ \case
_ | Just '\'' <- lastMaybe str -> pp_d
| otherwise -> Pretty.quotes pp_d
-semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
-arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
+blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt,
+ larrowtt, lambda :: SDoc
blankLine = docToSDoc Pretty.emptyText
-dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::")
-arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->")
-lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->")
-larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-")
-darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>")
-arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-")
-larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<")
-arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")
-larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")
+dcolon = unicodeSyntax (char '∷') (text "::")
+arrow = unicodeSyntax (char '→') (text "->")
+lollipop = unicodeSyntax (char '⊸') (text "%1 ->")
+larrow = unicodeSyntax (char '←') (text "<-")
+darrow = unicodeSyntax (char '⇒') (text "=>")
+arrowt = unicodeSyntax (char '⤚') (text ">-")
+larrowt = unicodeSyntax (char '⤙') (text "-<")
+arrowtt = unicodeSyntax (char '⤜') (text ">>-")
+larrowtt = unicodeSyntax (char '⤛') (text "-<<")
lambda = unicodeSyntax (char 'λ') (char '\\')
-semi = docToSDoc $ Pretty.semi
-comma = docToSDoc $ Pretty.comma
-colon = docToSDoc $ Pretty.colon
-equals = docToSDoc $ Pretty.equals
-space = docToSDoc $ Pretty.space
+
+semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc
+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc
+semi = char ';'
+comma = char ','
+colon = char ':'
+equals = char '='
+space = char ' '
underscore = char '_'
dot = char '.'
vbar = char '|'
-lparen = docToSDoc $ Pretty.lparen
-rparen = docToSDoc $ Pretty.rparen
-lbrack = docToSDoc $ Pretty.lbrack
-rbrack = docToSDoc $ Pretty.rbrack
-lbrace = docToSDoc $ Pretty.lbrace
-rbrace = docToSDoc $ Pretty.rbrace
+lparen = char '('
+rparen = char ')'
+lbrack = char '['
+rbrack = char ']'
+lbrace = char '{'
+rbrace = char '}'
forAllLit :: SDoc
forAllLit = unicodeSyntax (char '∀') (text "forall")
@@ -758,38 +746,15 @@ unicode unicode plain = sdocOption sdocCanUseUnicode $ \case
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
-(<>) :: SDoc -> SDoc -> SDoc
--- ^ Join two 'SDoc' together horizontally without a gap
-(<+>) :: SDoc -> SDoc -> SDoc
--- ^ Join two 'SDoc' together horizontally with a gap between them
-($$) :: SDoc -> SDoc -> SDoc
--- ^ Join two 'SDoc' together vertically; if there is
--- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
{-# INLINE CONLIKE nest #-}
nest n d = SDoc $ Pretty.nest n . runSDoc d
-{-# INLINE CONLIKE (<>) #-}
-(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx)
-{-# INLINE CONLIKE (<+>) #-}
-(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx)
-{-# INLINE CONLIKE ($$) #-}
-($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx)
{-# INLINE CONLIKE ($+$) #-}
($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx)
-hcat :: [SDoc] -> SDoc
--- ^ Concatenate 'SDoc' horizontally
-hsep :: [SDoc] -> SDoc
--- ^ Concatenate 'SDoc' horizontally with a space between each one
-vcat :: [SDoc] -> SDoc
--- ^ Concatenate 'SDoc' vertically with dovetailing
-sep :: [SDoc] -> SDoc
--- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
cat :: [SDoc] -> SDoc
--- ^ Concatenate: is either like 'hcat' or like 'vcat', depending on what fits
-fsep :: [SDoc] -> SDoc
-- ^ A paragraph-fill combinator. It's much like sep, only it
-- keeps fitting things on one line until it can't fit any more.
fcat :: [SDoc] -> SDoc
@@ -799,18 +764,8 @@ fcat :: [SDoc] -> SDoc
-- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc
-- later applied to the same SDocContext. It helps the worker/wrapper
-- transformation extracting only the required fields from the SDocContext.
-{-# INLINE CONLIKE hcat #-}
-hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds]
-{-# INLINE CONLIKE hsep #-}
-hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds]
-{-# INLINE CONLIKE vcat #-}
-vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds]
-{-# INLINE CONLIKE sep #-}
-sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds]
{-# INLINE CONLIKE cat #-}
cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds]
-{-# INLINE CONLIKE fsep #-}
-fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds]
{-# INLINE CONLIKE fcat #-}
fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds]
@@ -828,16 +783,17 @@ hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
hangNotEmpty d1 n d2 =
SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx)
-punctuate :: SDoc -- ^ The punctuation
- -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
- -> [SDoc] -- ^ Punctuated list
+punctuate :: IsLine doc
+ => doc -- ^ The punctuation
+ -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements
+ -> [doc] -- ^ Punctuated list
punctuate _ [] = []
punctuate p (d:ds) = go d ds
where
go d [] = [d]
go d (e:es) = (d <> p) : go e es
-ppWhen, ppUnless :: Bool -> SDoc -> SDoc
+ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc
{-# INLINE CONLIKE ppWhen #-}
ppWhen True doc = doc
ppWhen False _ = empty
@@ -853,10 +809,9 @@ ppWhenOption f doc = sdocOption f $ \case
False -> empty
{-# INLINE CONLIKE ppUnlessOption #-}
-ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
-ppUnlessOption f doc = sdocOption f $ \case
- True -> empty
- False -> doc
+ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc
+ppUnlessOption f doc = docWithContext $
+ \ctx -> if f ctx then empty else doc
-- | Apply the given colour\/style for the argument.
--
@@ -1028,12 +983,14 @@ instance Outputable Extension where
instance Outputable ModuleName where
ppr = pprModuleName
-pprModuleName :: ModuleName -> SDoc
+pprModuleName :: IsLine doc => ModuleName -> doc
pprModuleName (ModuleName nm) =
- getPprStyle $ \ sty ->
- if codeStyle sty
+ docWithContext $ \ctx ->
+ if codeStyle (sdocStyle ctx)
then ztext (zEncodeFS nm)
else ftext nm
+{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-}
+{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc]
-----------------------------------------------------------------------
-- The @OutputableP@ class
@@ -1301,12 +1258,14 @@ pprFastFilePath path = text $ normalise $ unpackFS path
-- | Normalise, escape and render a string representing a path
--
-- e.g. "c:\\whatever"
-pprFilePathString :: FilePath -> SDoc
+pprFilePathString :: IsLine doc => FilePath -> doc
pprFilePathString path = doubleQuotes $ text (escape (normalise path))
where
escape [] = []
escape ('\\':xs) = '\\':'\\':escape xs
escape (x:xs) = x:escape xs
+{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-}
+{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc]
{-
************************************************************************
@@ -1485,3 +1444,352 @@ thisOrThese _ = text "These"
hasOrHave :: [a] -> SDoc
hasOrHave [_] = text "has"
hasOrHave _ = text "have"
+
+{- Note [SDoc versus HDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The SDoc type is used pervasively throughout the compiler to represent pretty-
+printable output. Almost all text written by GHC, from the Haskell types and
+expressions included in error messages to debug dumps, is assembled using SDoc.
+SDoc is nice because it handles multiline layout in a semi-automatic fashion,
+enabling printed expressions to wrap to fit a given line width while correctly
+indenting the following lines to preserve alignment.
+
+SDoc’s niceties necessarily have some performance cost, but this is normally
+okay, as printing output is rarely a performance bottleneck. However, one
+notable exception to this is code generation: GHC must sometimes write
+megabytes’ worth of generated assembly when compiling a single module, in which
+case the overhead of SDoc has a significant cost (see #21853 for some numbers).
+Moreover, generated assembly does not have the complex layout requirements of
+pretty-printed Haskell code, so using SDoc does not buy us much, anyway.
+
+Nevertheless, we do still want to be able to share some logic between writing
+assembly and pretty-printing. For example, the logic for printing basic block
+labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single
+implementation that can be used both when generating code and when generating
+Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc
+interface, but it is implemented in a far more efficient way, writing directly
+to a `Handle` (via a `BufHandle`) without building any intermediate structures.
+We can then use typeclasses to parameterize functions like `pprCLabel` over the
+printing implementation.
+
+One might imagine this would result in one IsDoc typeclass, and two instances,
+one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc,
+as described in Note [HLine versus HDoc], and this gives rise to a small
+typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc;
+see Note [The outputable class hierarchy] for details.
+
+Note [HLine versus HDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~
+As described in Note [SDoc versus HDoc], HDoc does not support any of the layout
+niceties of SDoc for efficiency. However, this presents a small problem if we
+want to be compatible with the SDoc API, as expressions like
+
+ text "foo" <+> (text "bar" $$ text "baz")
+
+are expected to produce
+
+ foo bar
+ baz
+
+which requires tracking line widths to know how far to indent the second line.
+We can’t throw out vertical composition altogether, as we need to be able to
+construct multiline HDocs, but we *can* restrict vertical composition to
+concatenating whole lines at a time, as this is all that is necessary to
+generate assembly in the code generator.
+
+To implement this restriction, we provide two distinct types: HLine and HDoc.
+As their names suggests, an HLine represents a single line of output, while an
+HDoc represents a multiline document. Atoms formed from `char` and `text` begin
+their lives as HLines, which can be horizontally (but not vertically) composed:
+
+ char :: Char -> HLine
+ text :: String -> HLine
+ (<+>) :: HLine -> HLine -> HLine
+
+Once a line has been fully assembled, it can be “locked up” into a single-line
+HDoc via `line`, and HDocs can be vertically (but not horizontally) composed:
+
+ line :: HLine -> HDoc
+ ($$) :: HLine -> HLine -> HLine
+
+Note that, at runtime, HLine and HDoc use exactly the same representation. This
+distinction only exists in the type system to rule out the cases we don’t want
+to have to handle.
+
+Note [The outputable class hierarchy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in Note [SDoc versus HDoc], we want to be able to parameterize over
+the choice of printing implementation when implementing common bits of printing
+logic. However, as described in Note [HLine versus HDoc], we also want to
+distinguish code that does single-line printing from code that does multi-line
+printing. Therefore, code that is parameterized over the choice of printer must
+respect this single- versus multi-line distinction. This naturally leads to two
+typeclasses:
+
+ class IsLine doc where
+ char :: Char -> doc
+ text :: String -> doc
+ (<>) :: doc -> doc -> doc
+ ...
+
+ class IsLine (Line doc) => IsDoc doc where
+ type Line doc = r | r -> doc
+ line :: Line doc -> doc
+ ($$) :: doc -> doc -> doc
+ ...
+
+These classes support the following instances:
+
+ instance IsLine SDoc
+ instance IsLine SDoc where
+ type Line SDoc = SDoc
+
+ instance IsLine HLine
+ instance IsDoc HDoc where
+ type Line HDoc = HLine
+
+However, we run into a new problem: we provide many useful combinators on docs
+that don’t care at all about the single-/multi-line distinction. For example,
+ppWhen and ppUnless provide conditional logic, and docWithContext provides
+access to the ambient SDocContext. Given the above classes, we would need two
+variants of each of these combinators:
+
+ ppWhenL :: IsLine doc => Bool -> doc -> doc
+ ppWhenL c d = if c then d else emptyL
+
+ ppWhenD :: IsDoc doc => Bool -> doc -> doc
+ ppWhenD c d = if c then d else emptyD
+
+This is a needlessly annoying distinction, so we introduce a common superclass,
+IsOutput, that allows these combinators to be generic over both variants:
+
+ class IsOutput doc where
+ empty :: doc
+ docWithContext :: (SDocContext -> doc) -> doc
+
+ class IsOutput doc => IsLine doc
+ class (IsOutput doc, IsLine (Line doc)) => IsDoc doc
+
+In practice, IsOutput isn’t used explicitly very often, but it makes code that
+uses the combinators derived from it significantly less noisy.
+
+Note [SPECIALIZE to HDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The IsLine and IsDoc classes are useful to share printing logic between code
+that uses SDoc and code that uses HDoc, but we must take some care when doing
+so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses
+it to eliminate unnecessary indirection, but the HDoc primitives must be inlined
+before these opportunities can be exposed. Therefore, we want to explicitly
+request that GHC generate HDoc (or HLine) specializations of any polymorphic
+printing functions used by the code generator.
+
+In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize
+pragma just to the entry point pprNatCmmDecl, to avoid cluttering
+the entire module. Because specialization is transitive, this makes sure
+that other functions in that module are specialized too.
+
+Note [dualLine and dualDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The IsLine and IsDoc classes provide the dualLine and dualDoc methods,
+respectively, which have the following types:
+
+ dualLine :: IsLine doc => SDoc -> HLine -> doc
+ dualDoc :: IsDoc doc => SDoc -> HDoc -> doc
+
+These are effectively a form of type-`case`, selecting between each of their two
+arguments depending on the type they are instantiated at. They serve as a
+“nuclear option” for code that is, for some reason or another, unreasonably
+difficult to make completely equivalent under both printer implementations.
+
+These operations should generally be avoided, as they can result in surprising
+changes in behavior when the printer implementation is changed. However, in
+certain cases, the alternative is even worse. For example, we use dualLine in
+the implementation of pprUnitId, as the hack we use for printing unit ids
+(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine
+and is not necessary for code paths that use it, anyway.
+
+Use these operations wisely. -}
+
+-- | Represents a single line of output that can be efficiently printed directly
+-- to a 'System.IO.Handle' (actually a 'BufHandle').
+-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details.
+newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () }
+
+-- | Represents a (possibly empty) sequence of lines that can be efficiently
+-- printed directly to a 'System.IO.Handle' (actually a 'BufHandle').
+-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details.
+newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () }
+
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine
+pattern HLine f <- HLine' f
+ where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h)))
+{-# COMPLETE HLine #-}
+
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc
+pattern HDoc f <- HDoc' f
+ where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h)))
+{-# COMPLETE HDoc #-}
+
+bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO ()
+bPutHDoc h ctx (HDoc f) = f ctx h
+
+-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty',
+-- as well as access to the shared 'SDocContext'.
+--
+-- See Note [The outputable class hierarchy] for more details.
+class IsOutput doc where
+ empty :: doc
+ docWithContext :: (SDocContext -> doc) -> doc
+
+-- | A class of types that represent a single logical line of text, with support
+-- for horizontal composition.
+--
+-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for
+-- more details.
+class IsOutput doc => IsLine doc where
+ char :: Char -> doc
+ text :: String -> doc
+ ftext :: FastString -> doc
+ ztext :: FastZString -> doc
+
+ -- | Join two @doc@s together horizontally without a gap.
+ (<>) :: doc -> doc -> doc
+ -- | Join two @doc@s together horizontally with a gap between them.
+ (<+>) :: doc -> doc -> doc
+ -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits.
+ sep :: [doc] -> doc
+ -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting
+ -- things on one line until it can't fit any more.
+ fsep :: [doc] -> doc
+
+ -- | Concatenate @doc@s horizontally without gaps.
+ hcat :: [doc] -> doc
+ hcat docs = foldr (<>) empty docs
+ {-# INLINE CONLIKE hcat #-}
+
+ -- | Concatenate @doc@s horizontally with a space between each one.
+ hsep :: [doc] -> doc
+ hsep docs = foldr (<+>) empty docs
+ {-# INLINE CONLIKE hsep #-}
+
+ -- | Prints as either the given 'SDoc' or the given 'HLine', depending on
+ -- which type the result is instantiated to. This should generally be avoided;
+ -- see Note [dualLine and dualDoc] for details.
+ dualLine :: SDoc -> HLine -> doc
+
+
+-- | A class of types that represent a multiline document, with support for
+-- vertical composition.
+--
+-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for
+-- more details.
+class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where
+ type Line doc = r | r -> doc
+ line :: Line doc -> doc
+
+ -- | Join two @doc@s together vertically. If there is no vertical overlap it
+ -- "dovetails" the two onto one line.
+ ($$) :: doc -> doc -> doc
+
+ lines_ :: [Line doc] -> doc
+ lines_ = vcat . map line
+ {-# INLINE CONLIKE lines_ #-}
+
+ -- | Concatenate @doc@s vertically with dovetailing.
+ vcat :: [doc] -> doc
+ vcat ls = foldr ($$) empty ls
+ {-# INLINE CONLIKE vcat #-}
+
+ -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on
+ -- which type the result is instantiated to. This should generally be avoided;
+ -- see Note [dualLine and dualDoc] for details.
+ dualDoc :: SDoc -> HDoc -> doc
+
+instance IsOutput SDoc where
+ empty = docToSDoc $ Pretty.empty
+ {-# INLINE CONLIKE empty #-}
+ docWithContext = sdocWithContext
+ {-# INLINE docWithContext #-}
+
+instance IsLine SDoc where
+ char c = docToSDoc $ Pretty.char c
+ {-# INLINE CONLIKE char #-}
+ text s = docToSDoc $ Pretty.text s
+ {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire
+ ftext s = docToSDoc $ Pretty.ftext s
+ {-# INLINE CONLIKE ftext #-}
+ ztext s = docToSDoc $ Pretty.ztext s
+ {-# INLINE CONLIKE ztext #-}
+ (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx)
+ {-# INLINE CONLIKE (<>) #-}
+ (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx)
+ {-# INLINE CONLIKE (<+>) #-}
+ hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds]
+ {-# INLINE CONLIKE hcat #-}
+ hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds]
+ {-# INLINE CONLIKE hsep #-}
+ sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds]
+ {-# INLINE CONLIKE sep #-}
+ fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds]
+ {-# INLINE CONLIKE fsep #-}
+ dualLine s _ = s
+ {-# INLINE CONLIKE dualLine #-}
+
+instance IsDoc SDoc where
+ type Line SDoc = SDoc
+ line = id
+ {-# INLINE line #-}
+ lines_ = vcat
+ {-# INLINE lines_ #-}
+
+ ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx)
+ {-# INLINE CONLIKE ($$) #-}
+ vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds]
+ {-# INLINE CONLIKE vcat #-}
+ dualDoc s _ = s
+ {-# INLINE CONLIKE dualDoc #-}
+
+instance IsOutput HLine where
+ empty = HLine (\_ _ -> pure ())
+ {-# INLINE empty #-}
+ docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h
+ {-# INLINE CONLIKE docWithContext #-}
+
+instance IsOutput HDoc where
+ empty = HDoc (\_ _ -> pure ())
+ {-# INLINE empty #-}
+ docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h
+ {-# INLINE CONLIKE docWithContext #-}
+
+instance IsLine HLine where
+ char c = HLine (\_ h -> bPutChar h c)
+ {-# INLINE CONLIKE char #-}
+ text str = HLine (\_ h -> bPutStr h str)
+ {-# INLINE CONLIKE text #-}
+ ftext fstr = HLine (\_ h -> bPutFS h fstr)
+ {-# INLINE CONLIKE ftext #-}
+ ztext fstr = HLine (\_ h -> bPutFZS h fstr)
+ {-# INLINE CONLIKE ztext #-}
+
+ HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h)
+ {-# INLINE CONLIKE (<>) #-}
+ f <+> g = f <> char ' ' <> g
+ {-# INLINE CONLIKE (<+>) #-}
+ sep = hsep
+ {-# INLINE sep #-}
+ fsep = hsep
+ {-# INLINE fsep #-}
+
+ dualLine _ h = h
+ {-# INLINE CONLIKE dualLine #-}
+
+instance IsDoc HDoc where
+ type Line HDoc = HLine
+ line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n')
+ {-# INLINE CONLIKE line #-}
+ HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h)
+ {-# INLINE CONLIKE ($$) #-}
+ dualDoc _ h = h
+ {-# INLINE CONLIKE dualDoc #-}