summaryrefslogtreecommitdiff
path: root/compiler/GHC/CmmToAsm
diff options
context:
space:
mode:
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