summaryrefslogtreecommitdiff
path: root/compiler/GHC/CmmToAsm
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-10-24 22:41:23 +0200
commit0c0cdcacd64860e3a5ae1b876734b4743c7b9252 (patch)
tree41e37bc947d1ca2fea62220842574d1088800dbb /compiler/GHC/CmmToAsm
parent8d2dbe2db4cc7c8b6d39b1ea64b0508304a3273c (diff)
downloadhaskell-wip/efficient-codegen.tar.gz
Use a more efficient printer for code generation (#21853)wip/efficient-codegen
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/GHC/CmmToAsm')
-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.hs48
-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.hs3
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs232
17 files changed, 580 insertions, 471 deletions
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 5ca443f08e..e782bc41a0 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 236ddb5ffc..5722e07a3a 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 CStyle 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..e4b47f91f9 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,26 +548,26 @@ pprGotDeclaration config = case (arch,os) of
-- Emit XCOFF TOC section
(_, OSAIX)
- -> vcat $ [ text ".toc"
- , text ".tc ghc_toc_table[TC],.LCTOC1"
- , text ".csect ghc_toc_table[RW]"
- -- See Note [.LCTOC1 in PPC PIC code]
- , text ".set .LCTOC1,$+0x8000"
- ]
+ -> lines_ $ [ text ".toc"
+ , text ".tc ghc_toc_table[TC],.LCTOC1"
+ , text ".csect ghc_toc_table[RW]"
+ -- See Note [.LCTOC1 in PPC PIC code]
+ , text ".set .LCTOC1,$+0x8000"
+ ]
-- 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,15 +595,16 @@ 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 "L" <> ppr_lbl lbl <> text "$stub:"),
text "\t.indirect_symbol" <+> ppr_lbl lbl,
text "\tjmp *L" <> ppr_lbl lbl
<> text "$lazy_ptr",
@@ -614,7 +615,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 +632,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 +642,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 +669,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
@@ -700,12 +702,11 @@ pprImportedSymbol config importedLbl = case (arch,os) of
-- When needImportedSymbols is defined,
-- the NCG will keep track of all DynamicLinkerLabels it uses
-- and output each of them using pprImportedSymbol.
-
(ArchPPC_64 _, _)
| 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 f8563004b5..9ddcdc32dd 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 19de3cd1e2..f03f56f6d8 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 fd85ae6154..67c5504295 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 42b9543204..59c4770c9b 100644
--- a/compiler/GHC/CmmToAsm/X86/Instr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Instr.hs
@@ -67,6 +67,7 @@ import GHC.Types.Basic (Alignment)
import GHC.Cmm.DebugBlock (UnwindTable)
import Data.Maybe (fromMaybe)
+import GHC.Data.FastString (FastString)
-- Format of an x86/x86_64 memory address, in bytes.
--
@@ -170,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 0b19665857..11c882e547 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
@@ -557,26 +559,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"
@@ -794,19 +796,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
@@ -825,19 +827,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
@@ -881,20 +883,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
@@ -903,10 +905,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
@@ -916,46 +918,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,
@@ -964,24 +966,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,
@@ -989,18 +991,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,
@@ -1008,18 +1010,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,
@@ -1029,18 +1031,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,
@@ -1051,7 +1053,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,
@@ -1059,9 +1061,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,
@@ -1069,15 +1071,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]
View Lorry Controller Status