[Git][ghc/ghc][master] Remove label style from printing context
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Aug 26 19:06:25 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f5e0f086 by Krzysztof Gogolewski at 2022-08-26T15:06:01-04:00
Remove label style from printing context
Previously, the SDocContext used for code generation contained
information whether the labels should use Asm or C style.
However, at every individual call site, this is known statically.
This removes the parameter to 'PprCode' and replaces every 'pdoc'
used to print a label in code style with 'pprCLabel' or 'pprAsmLabel'.
The OutputableP instance is now used only for dumps.
The output of T15155 changes, it now uses the Asm style
(which is faithful to what actually happens).
- - - - -
27 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/Dwarf.hs
- compiler/GHC/CmmToAsm/Dwarf/Types.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/Config/CmmToLlvm.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Utils/Logger.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/T15155.stdout-darwin
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -128,6 +128,7 @@ module GHC.Cmm.CLabel (
LabelStyle (..),
pprDebugCLabel,
pprCLabel,
+ pprAsmLabel,
ppInternalProcLabel,
-- * Others
@@ -1389,13 +1390,15 @@ allocation. Take care if you want to remove them!
-}
+pprAsmLabel :: Platform -> CLabel -> SDoc
+pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl
+
instance OutputableP Platform CLabel where
{-# INLINE pdoc #-} -- see Note [Bangs in CLabel]
pdoc !platform lbl = getPprStyle $ \pp_sty ->
- let !sty = case pp_sty of
- PprCode sty -> sty
- _ -> CStyle
- in pprCLabel platform sty lbl
+ case pp_sty of
+ PprDump{} -> pprCLabel platform CStyle lbl
+ _ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
@@ -1522,7 +1525,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
CC_Label cc -> maybe_underscore $ ppr cc
CCS_Label ccs -> maybe_underscore $ ppr ccs
- IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe")
+ IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> ppr m <> text "_ipe")
ModuleLabel mod kind -> maybe_underscore $ ppr mod <> text "_" <> ppr kind
CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -77,7 +77,7 @@ data DebugBlock =
, dblBlocks :: ![DebugBlock] -- ^ Nested blocks
}
-instance OutputableP env CLabel => OutputableP env DebugBlock where
+instance OutputableP Platform DebugBlock where
pdoc env blk =
(if | dblProcedure blk == dblLabel blk
-> text "proc"
@@ -85,7 +85,7 @@ instance OutputableP env CLabel => OutputableP env DebugBlock where
-> text "pp-blk"
| otherwise
-> text "blk") <+>
- ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+>
+ ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+>
(maybe empty ppr (dblSourceTick blk)) <+>
(maybe (text "removed") ((text "pos " <>) . ppr)
(dblPosition blk)) <+>
@@ -495,9 +495,9 @@ LOC this information will end up in is Y.
-- | A label associated with an 'UnwindTable'
data UnwindPoint = UnwindPoint !CLabel !UnwindTable
-instance OutputableP env CLabel => OutputableP env UnwindPoint where
+instance OutputableP Platform UnwindPoint where
pdoc env (UnwindPoint lbl uws) =
- braces $ pdoc env lbl <> colon
+ braces $ pprAsmLabel env lbl <> colon
<+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
where
pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr
@@ -519,16 +519,16 @@ data UnwindExpr = UwConst !Int -- ^ literal value
| UwTimes UnwindExpr UnwindExpr
deriving (Eq)
-instance OutputableP env CLabel => OutputableP env UnwindExpr where
+instance OutputableP Platform UnwindExpr where
pdoc = pprUnwindExpr 0
-pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc
+pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc
pprUnwindExpr p env = \case
UwConst i -> ppr i
UwReg g 0 -> ppr g
UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))
UwDeref e -> char '*' <> pprUnwindExpr 3 env e
- UwLabel l -> pdoc env l
+ UwLabel l -> pprAsmLabel env l
UwPlus e0 e1
| p <= 0 -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1
UwMinus e0 e1
=====================================
compiler/GHC/Cmm/Lint.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Cmm.Liveness
import GHC.Cmm.Switch (switchTargetsToList)
+import GHC.Cmm.CLabel (pprDebugCLabel)
import GHC.Utils.Outputable
import Control.Monad (ap, unless)
@@ -55,7 +56,7 @@ lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl (CmmProc _ lbl _ g)
= do
platform <- getPlatform
- addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g
+ addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g
lintCmmDecl (CmmData {})
= return ()
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -508,9 +508,9 @@ pprForeignTarget platform (PrimTarget op)
-- HACK: We're just using a ForeignLabel to get this printed, the label
-- might not really be foreign.
= pdoc platform
- (CmmLabel (mkForeignLabel
+ (mkForeignLabel
(mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction))
+ Nothing ForeignLabelInThisPackage IsFunction)
instance Outputable Convention where
ppr = pprConvention
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -449,7 +449,7 @@ cmmproc :: { CmmParse () }
platform <- getPlatform;
ctx <- getContext;
formals <- sequence (fromMaybe [] $3);
- withName (renderWithContext ctx (pdoc platform entry_ret_label))
+ withName (renderWithContext ctx (pprCLabel platform CStyle entry_ret_label))
$4;
return (entry_ret_label, info, stk_formals, formals) }
let do_layout = isJust $3
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -396,7 +396,7 @@ cmmNativeGens logger config modLoc ncgImpl h dbgMap = go
-- force evaluation all this stuff to avoid space leaks
let platform = ncgPlatform config
- {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) ()
+ {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()
let !labels' = if ncgDwarfEnabled config
then cmmDebugLabels isMetaInstr native else []
@@ -455,7 +455,7 @@ cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count
let weights = ncgCfgWeights config
let proc_name = case cmm of
- (CmmProc _ entry_label _ _) -> pdoc platform entry_label
+ (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label
_ -> text "DataChunk"
-- rewrite assignments to global regs
@@ -789,7 +789,7 @@ makeImportsDoc config imports
doPpr lbl = (lbl, renderWithContext
(ncgAsmContext config)
- (pprCLabel platform AsmStyle lbl))
+ (pprAsmLabel platform lbl))
-- -----------------------------------------------------------------------------
-- Generate jump tables
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -60,6 +60,7 @@ import GHC.Types.ForeignCall
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
-- Note [General layout of an NCG]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -135,10 +136,11 @@ basicBlockCodeGen block = do
id = entryLabel block
stmts = blockToList nodes
- header_comment_instr = unitOL $ MULTILINE_COMMENT (
+ header_comment_instr | debugIsOn = unitOL $ MULTILINE_COMMENT (
text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
- $+$ pdoc (ncgPlatform config) block
+ $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)
)
+ | otherwise = nilOL
-- Generate location directive
dbg <- getDebugBlock (entryLabel block)
loc_instrs <- case dblSourceTick =<< dbg of
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -50,14 +50,14 @@ 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 pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+ then 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 pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'
+ then 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
@@ -65,9 +65,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
text "\t.long "
- <+> pdoc platform info_lbl
+ <+> pprAsmLabel platform info_lbl
<+> char '-'
- <+> pdoc platform (mkDeadStripPreventer info_lbl)
+ <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
@@ -75,7 +75,7 @@ pprLabel :: Platform -> CLabel -> SDoc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeDecl platform lbl
- $$ (pdoc platform lbl <> char ':')
+ $$ (pprAsmLabel platform lbl <> char ':')
pprAlign :: Platform -> Alignment -> SDoc
pprAlign _platform alignment
@@ -105,7 +105,7 @@ pprSectionAlign config sec@(Section seg _) =
pprSizeDecl :: Platform -> CLabel -> SDoc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl
+ then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl
else empty
pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
@@ -115,7 +115,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
(if ncgDwarfEnabled config
- then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':'
+ then pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
where
@@ -135,7 +135,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform info_lbl $$
c $$
(if ncgDwarfEnabled config
- then pdoc platform (mkAsmTempEndLabel info_lbl) <> char ':'
+ then 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]
@@ -153,7 +153,7 @@ pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl (ncgPlatform config) alias
- $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind')
+ $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind'
pprDatas config (CmmStaticsRaw lbl dats)
= vcat (pprLabel platform lbl : map (pprData config) dats)
@@ -175,7 +175,7 @@ pprData config (CmmStaticLit lit) = pprDataItem config lit
pprGloblDecl :: Platform -> CLabel -> SDoc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text "\t.globl " <> pdoc platform lbl
+ | otherwise = text "\t.globl " <> pprAsmLabel platform lbl
-- Note [Always use objects for info tables]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -201,7 +201,7 @@ pprLabelType' platform lbl =
pprTypeDecl :: Platform -> CLabel -> SDoc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
- then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl
+ then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl
else empty
pprDataItem :: NCGConfig -> CmmLit -> SDoc
@@ -230,8 +230,8 @@ pprDataItem config lit
pprImm :: Platform -> Imm -> SDoc
pprImm _ (ImmInt i) = int i
pprImm _ (ImmInteger i) = integer i
-pprImm p (ImmCLbl l) = pdoc p l
-pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i
+pprImm p (ImmCLbl l) = pprAsmLabel p l
+pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i
pprImm _ (ImmLit s) = text s
-- TODO: See pprIm below for why this is a bad idea!
@@ -279,8 +279,8 @@ pprIm platform im = case im of
ImmDouble d | d == 0 -> text "xzr"
ImmDouble d -> char '#' <> double (fromRational d)
-- =<lbl> pseudo instruction!
- ImmCLbl l -> char '=' <> pdoc platform l
- ImmIndex l o -> text "[=" <> pdoc platform l <> comma <+> char '#' <> int o <> char ']'
+ ImmCLbl l -> char '=' <> pprAsmLabel platform l
+ ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'
_ -> panic "AArch64.pprIm"
pprExt :: ExtMode -> SDoc
@@ -430,28 +430,28 @@ pprInstr platform instr = case instr of
-- 4. Branch Instructions ----------------------------------------------------
J t -> pprInstr platform (B t)
- B (TBlock bid) -> text "\tb" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))
- B (TLabel lbl) -> text "\tb" <+> pdoc platform lbl
+ 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
- BL (TBlock bid) _ _ -> text "\tbl" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))
- BL (TLabel lbl) _ _ -> text "\tbl" <+> pdoc platform lbl
+ 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
- BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pdoc platform (mkLocalBlockLabel (getUnique bid))
- BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pdoc platform lbl
+ 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 _ (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
- CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))
- CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform lbl
+ 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 _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!"
- CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))
- CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform lbl
+ 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 _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"
-- 7. Load and Store Instructions --------------------------------------------
@@ -466,58 +466,58 @@ pprInstr platform instr = case instr of
#if defined(darwin_HOST_OS)
LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpage" $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpageoff" <> text "]" $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpage" $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpageoff" <> text "]" $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmIndex lbl off)) ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$
- text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@page" $$
+ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@pageoff" $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpage" $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpageoff" <> text "]"
LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpage" $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@gotpageoff" <> text "]"
LDR _f o1 (OpImm (ImmCLbl lbl)) ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$
- text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff"
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@page" $$
+ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl <> text "@pageoff"
#else
LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pprAsmLabel platform lbl $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pprAsmLabel platform lbl <> text "]" $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pprAsmLabel platform lbl $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pprAsmLabel platform lbl <> text "]" $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmIndex lbl off)) ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$
- text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl $$
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl $$
+ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pprAsmLabel platform lbl $$
text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.
LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pprAsmLabel platform lbl $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pprAsmLabel platform lbl <> text "]"
LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$
- text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pprAsmLabel platform lbl $$
+ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pprAsmLabel platform lbl <> text "]"
LDR _f o1 (OpImm (ImmCLbl lbl)) ->
- text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$
- text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl
+ text "\tadrp" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl $$
+ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pprAsmLabel platform lbl
#endif
LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
=====================================
compiler/GHC/CmmToAsm/Dwarf.hs
=====================================
@@ -51,8 +51,8 @@ dwarfGen config modLoc us blocks = do
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
- , dwLowLabel = pdoc platform lowLabel
- , dwHighLabel = pdoc platform highLabel
+ , dwLowLabel = pprAsmLabel platform lowLabel
+ , dwHighLabel = pprAsmLabel platform highLabel
, dwLineLabel = dwarfLineLabel
}
@@ -109,9 +109,9 @@ mkDwarfARange proc = DwarfARange lbl end
compileUnitHeader :: Platform -> Unique -> SDoc
compileUnitHeader platform unitU =
let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
- length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel
+ length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel
<> text "-4" -- length of initialLength field
- in vcat [ pdoc platform cuLabel <> colon
+ in vcat [ pprAsmLabel platform cuLabel <> colon
, text "\t.long " <> length -- compilation unit size
, pprHalf 3 -- DWARF version
, sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel
@@ -123,7 +123,7 @@ compileUnitHeader platform unitU =
compileUnitFooter :: Platform -> Unique -> SDoc
compileUnitFooter platform unitU =
let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
- in pdoc platform cuEndLabel <> colon
+ in 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
=====================================
compiler/GHC/CmmToAsm/Dwarf/Types.hs
=====================================
@@ -184,14 +184,14 @@ pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowL
then sectionOffset platform lineLbl dwarfLineLabel
else empty
pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
- pdoc platform (mkAsmTempDieLabel label) <> colon
+ pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
$$ pprLabelString platform label
$$ pprFlag (externallyVisibleCLabel label)
-- Offset due to Note [Info Offset]
- $$ pprWord platform (pdoc platform label <> text "-1")
- $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label)
+ $$ pprWord platform (pprAsmLabel platform label <> text "-1")
+ $$ pprWord platform (pprAsmLabel platform $ mkAsmTempProcEndLabel label)
$$ pprByte 1
$$ pprByte dW_OP_call_frame_cfa
$$ parentValue
@@ -199,17 +199,17 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
abbrev = case parent of Nothing -> DwAbbrSubprogram
Just _ -> DwAbbrSubprogramWithParent
parentValue = maybe empty pprParentDie parent
- pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel
+ pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel
pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
- pdoc platform (mkAsmTempDieLabel label) <> colon
+ pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
$$ pprLabelString platform label
pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
- pdoc platform (mkAsmTempDieLabel label) <> colon
+ pprAsmLabel platform (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
$$ pprLabelString platform label
- $$ pprWord platform (pdoc platform marker)
- $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker)
+ $$ pprWord platform (pprAsmLabel platform marker)
+ $$ pprWord platform (pprAsmLabel platform $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
pprAbbrev DwAbbrGhcSrcNote
$$ pprString' (ftext $ srcSpanFile ss)
@@ -245,7 +245,7 @@ pprDwarfARanges platform arngs unitU =
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
- $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel
+ $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
@@ -258,11 +258,11 @@ pprDwarfARanges platform arngs unitU =
pprDwarfARange :: Platform -> DwarfARange -> SDoc
pprDwarfARange platform arng =
-- Offset due to Note [Info Offset].
- pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")
+ pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1")
$$ pprWord platform length
where
- length = pdoc platform (dwArngEndLabel arng)
- <> char '-' <> pdoc platform (dwArngStartLabel arng)
+ length = pprAsmLabel platform (dwArngEndLabel arng)
+ <> char '-' <> pprAsmLabel platform (dwArngStartLabel arng)
-- | Information about unwind instructions for a procedure. This
-- corresponds to a "Common Information Entry" (CIE) in DWARF.
@@ -293,7 +293,7 @@ data DwarfFrameBlock
-- in the block
}
-instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where
+instance OutputableP Platform DwarfFrameBlock where
pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds
-- | Header for the @.debug_frame@ section. Here we emit the "Common
@@ -303,7 +303,7 @@ pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
cieEndLabel = mkAsmTempEndLabel cieLabel
- length = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel
+ length = pprAsmLabel platform cieEndLabel <> char '-' <> pprAsmLabel platform cieStartLabel
spReg = dwarfGlobalRegNo platform Sp
retReg = dwarfReturnRegNo platform
wordSize = platformWordSizeInBytes platform
@@ -316,9 +316,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 [ pdoc platform cieLabel <> colon
+ in vcat [ pprAsmLabel platform cieLabel <> colon
, pprData4' length -- Length of CIE
- , pdoc platform cieStartLabel <> colon
+ , pprAsmLabel platform cieStartLabel <> colon
, pprData4' (text "-1")
-- Common Information Entry marker (-1 = 0xf..f)
, pprByte 3 -- CIE version (we require DWARF 3)
@@ -346,7 +346,7 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro
, pprLEBWord 0
] $$
wordAlign platform $$
- pdoc platform cieEndLabel <> colon $$
+ pprAsmLabel platform cieEndLabel <> colon $$
-- Procedure unwind tables
vcat (map (pprFrameProc platform cieLabel cieInit) procs)
@@ -360,17 +360,17 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
procEnd = mkAsmTempProcEndLabel procLbl
ifInfo str = if hasInfo then text str else empty
-- see Note [Info Offset]
- in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon
- , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)
- , pdoc platform fdeLabel <> colon
- , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE
- , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer
- , pprWord platform (pdoc platform procEnd <> char '-' <>
- pdoc platform procLbl <> ifInfo "+1") -- Block byte length
+ in vcat [ whenPprDebug $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon
+ , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel)
+ , 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 '-' <>
+ pprAsmLabel platform procLbl <> ifInfo "+1") -- Block byte length
] $$
vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
wordAlign platform $$
- pdoc platform fdeEndLabel <> colon
+ pprAsmLabel platform fdeEndLabel <> colon
-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
@@ -402,7 +402,7 @@ pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =
then (empty, oldUws)
else let -- see Note [Info Offset]
needsOffset = firstDecl && hasInfo
- lblDoc = pdoc platform lbl <>
+ lblDoc = pprAsmLabel platform lbl <>
if needsOffset then text "-1" else empty
doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$
vcat (map (uncurry $ pprSetUnwind platform) changed)
@@ -513,7 +513,7 @@ pprUnwindExpr platform spIsCFA expr
pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$
pprLEBInt i
pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
- pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pdoc platform l)
+ pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l)
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
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -729,7 +729,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
_ -> panic "PIC.pprImportedSymbol: no match"
where
platform = ncgPlatform config
- ppr_lbl = pprCLabel platform AsmStyle
+ ppr_lbl = pprAsmLabel platform
arch = platformArch platform
os = platformOS platform
pic = ncgPIC config
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -63,7 +63,7 @@ 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) (pdoc platform (mkAsmTempEndLabel lbl)
+ ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel lbl)
<> char ':' $$
pprProcEndLabel platform lbl) $$
pprSizeDecl platform lbl
@@ -71,7 +71,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
(if platformHasSubsectionsViaSymbols platform
- then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'
+ then 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
@@ -80,9 +80,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
then
-- See Note [Subsections Via Symbols] in X86/Ppr.hs
text "\t.long "
- <+> pdoc platform info_lbl
+ <+> pprAsmLabel platform info_lbl
<+> char '-'
- <+> pdoc platform (mkDeadStripPreventer info_lbl)
+ <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
@@ -93,7 +93,7 @@ pprSizeDecl platform lbl
then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl
else empty
where
- prettyLbl = pdoc platform lbl
+ prettyLbl = pprAsmLabel platform lbl
codeLbl
| platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl
| otherwise = prettyLbl
@@ -102,33 +102,33 @@ pprFunctionDescriptor :: Platform -> CLabel -> SDoc
pprFunctionDescriptor platform lab = pprGloblDecl platform lab
$$ text "\t.section \".opd\", \"aw\""
$$ text "\t.align 3"
- $$ pdoc platform lab <> char ':'
+ $$ pprAsmLabel platform lab <> char ':'
$$ text "\t.quad ."
- <> pdoc platform lab
+ <> pprAsmLabel platform lab
<> text ",.TOC. at tocbase,0"
$$ text "\t.previous"
$$ text "\t.type"
- <+> pdoc platform lab
+ <+> pprAsmLabel platform lab
<> text ", @function"
- $$ char '.' <> pdoc platform lab <> char ':'
+ $$ char '.' <> pprAsmLabel platform lab <> char ':'
pprFunctionPrologue :: Platform -> CLabel ->SDoc
pprFunctionPrologue platform lab = pprGloblDecl platform lab
$$ text ".type "
- <> pdoc platform lab
+ <> pprAsmLabel platform lab
<> text ", @function"
- $$ pdoc platform lab <> char ':'
+ $$ pprAsmLabel platform lab <> char ':'
$$ text "0:\taddis\t" <> pprReg toc
<> text ",12,.TOC.-0b at ha"
$$ text "\taddi\t" <> pprReg toc
<> char ',' <> pprReg toc <> text ",.TOC.-0b at l"
- $$ text "\t.localentry\t" <> pdoc platform lab
- <> text ",.-" <> pdoc platform lab
+ $$ text "\t.localentry\t" <> pprAsmLabel platform lab
+ <> text ",.-" <> pprAsmLabel platform lab
pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name
-> SDoc
pprProcEndLabel platform lbl =
- pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'
+ pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':'
pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
-> SDoc
@@ -137,7 +137,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
ppWhen (ncgDwarfEnabled config) (
- pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':'
+ pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
<> pprProcEndLabel platform asmLbl
)
where
@@ -162,7 +162,7 @@ pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLi
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl platform alias
- $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind')
+ $$ 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
@@ -175,20 +175,20 @@ pprData platform d = case d of
pprGloblDecl :: Platform -> CLabel -> SDoc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text ".globl " <> pdoc platform lbl
+ | otherwise = text ".globl " <> pprAsmLabel platform lbl
pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc
pprTypeAndSizeDecl platform lbl
= if platformOS platform == OSLinux && externallyVisibleCLabel lbl
then text ".type " <>
- pdoc platform lbl <> text ", @object"
+ pprAsmLabel platform lbl <> text ", @object"
else empty
pprLabel :: Platform -> CLabel -> SDoc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeAndSizeDecl platform lbl
- $$ (pdoc platform lbl <> char ':')
+ $$ (pprAsmLabel platform lbl <> char ':')
-- -----------------------------------------------------------------------------
-- pprInstr: print an 'Instr'
@@ -238,8 +238,8 @@ pprImm :: Platform -> Imm -> SDoc
pprImm platform = \case
ImmInt i -> int i
ImmInteger i -> integer i
- ImmCLbl l -> pdoc platform l
- ImmIndex l i -> pdoc platform l <> char '+' <> int i
+ ImmCLbl l -> pprAsmLabel platform l
+ ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i
ImmLit s -> text s
ImmFloat f -> float $ fromRational f
ImmDouble d -> double $ fromRational d
@@ -559,7 +559,7 @@ pprInstr platform instr = case instr of
pprCond cond,
pprPrediction prediction,
char '\t',
- pdoc platform lbl
+ pprAsmLabel platform lbl
]
where lbl = mkLocalBlockLabel (getUnique blockid)
pprPrediction p = case p of
@@ -577,7 +577,7 @@ pprInstr platform instr = case instr of
],
hcat [
text "\tb\t",
- pdoc platform lbl
+ pprAsmLabel platform lbl
]
]
where lbl = mkLocalBlockLabel (getUnique blockid)
@@ -594,7 +594,7 @@ pprInstr platform instr = case instr of
char '\t',
text "b",
char '\t',
- pdoc platform lbl
+ pprAsmLabel platform lbl
]
MTCTR reg
@@ -625,12 +625,12 @@ pprInstr platform instr = case instr of
-- they'd technically be more like 'ForeignLabel's.
hcat [
text "\tbl\t.",
- pdoc platform lbl
+ pprAsmLabel platform lbl
]
_ ->
hcat [
text "\tbl\t",
- pdoc platform lbl
+ pprAsmLabel platform lbl
]
BCTRL _
=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -210,7 +210,7 @@ pprGNUSectionHeader config t suffix =
platform = ncgPlatform config
splitSections = ncgSplitSections config
subsection
- | splitSections = sep <> pdoc platform suffix
+ | splitSections = sep <> pprAsmLabel platform suffix
| otherwise = empty
header = case t of
Text -> text ".text"
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -93,7 +93,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprProcAlignment config $$
pprProcLabel config lbl $$
(if platformHasSubsectionsViaSymbols platform
- then pdoc platform (mkDeadStripPreventer info_lbl) <> colon
+ then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon
else empty) $$
vcat (map (pprBasicBlock config top_info) blocks) $$
ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$
@@ -102,9 +102,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
text "\t.long "
- <+> pdoc platform info_lbl
+ <+> pprAsmLabel platform info_lbl
<+> char '-'
- <+> pdoc platform (mkDeadStripPreventer info_lbl)
+ <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
@@ -120,18 +120,18 @@ pprProcLabel config lbl
pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name
-> SDoc
pprProcEndLabel platform lbl =
- pdoc platform (mkAsmTempProcEndLabel lbl) <> colon
+ pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
pprBlockEndLabel :: Platform -> CLabel -- ^ Block name
-> SDoc
pprBlockEndLabel platform lbl =
- pdoc platform (mkAsmTempEndLabel lbl) <> colon
+ pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon
-- | Output the ELF .size directive.
pprSizeDecl :: Platform -> CLabel -> SDoc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
- then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl
+ then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl
else empty
pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc
@@ -156,7 +156,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
vcat (map (pprData config) info) $$
pprLabel platform infoLbl $$
c $$
- ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon)
+ ppWhen (ncgDwarfEnabled config) (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]
@@ -175,7 +175,7 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl (ncgPlatform config) alias
- $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind')
+ $$ 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)
@@ -197,7 +197,7 @@ pprData config (CmmStaticLit lit) = pprDataItem config lit
pprGloblDecl :: Platform -> CLabel -> SDoc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = text ".globl " <> pdoc platform lbl
+ | otherwise = text ".globl " <> pprAsmLabel platform lbl
pprLabelType' :: Platform -> CLabel -> SDoc
pprLabelType' platform lbl =
@@ -260,14 +260,14 @@ pprLabelType' platform lbl =
pprTypeDecl :: Platform -> CLabel -> SDoc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
- then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl
+ then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl
else empty
pprLabel :: Platform -> CLabel -> SDoc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeDecl platform lbl
- $$ (pdoc platform lbl <> colon)
+ $$ (pprAsmLabel platform lbl <> colon)
pprAlign :: Platform -> Alignment -> SDoc
pprAlign platform alignment
@@ -430,8 +430,8 @@ pprImm :: Platform -> Imm -> SDoc
pprImm platform = \case
ImmInt i -> int i
ImmInteger i -> integer i
- ImmCLbl l -> pdoc platform l
- ImmIndex l i -> pdoc platform l <> char '+' <> int i
+ ImmCLbl l -> pprAsmLabel platform l
+ ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i
ImmLit s -> text s
ImmFloat f -> float $ fromRational f
ImmDouble d -> double $ fromRational d
@@ -576,7 +576,7 @@ pprInstr platform i = case i of
UNWIND lbl d
-> asmComment (text "\tunwind = " <> pdoc platform d)
- $$ pdoc platform lbl <> colon
+ $$ pprAsmLabel platform lbl <> colon
LDATA _ _
-> panic "pprInstr: LDATA"
@@ -818,7 +818,7 @@ pprInstr platform i = case i of
-> pprFormatOpReg (text "xchg") format src val
JXX cond blockid
- -> pprCondInstr (text "j") cond (pdoc platform lab)
+ -> pprCondInstr (text "j") cond (pprAsmLabel platform lab)
where lab = blockLbl blockid
JXX_GBL cond imm
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1705,7 +1705,6 @@ genMachOp_slow opt op [x, y] = case op of
where
binLlvmOp ty binOp allow_y_cast = do
- cfg <- getConfig
platform <- getPlatform
runExprData $ do
vx <- exprToVarW x
@@ -1721,13 +1720,7 @@ genMachOp_slow opt op [x, y] = case op of
doExprW (ty vx) $ binOp vx vy'
| otherwise
- -> do
- -- Error. Continue anyway so we can debug the generated ll file.
- let render = renderWithContext (llvmCgContext cfg)
- cmmToStr = (lines . render . pdoc platform)
- statement $ Comment $ map fsLit $ cmmToStr x
- statement $ Comment $ map fsLit $ cmmToStr y
- doExprW (ty vx) $ binOp vx vy
+ -> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y)
binCastLlvmOp ty binOp = runExprData $ do
vx <- exprToVarW x
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -173,7 +173,7 @@ outputC logger dflags filenm cmm_stream unit_deps =
"C backend output"
FormatC
doc
- let ctx = initSDocContext dflags (PprCode CStyle)
+ let ctx = initSDocContext dflags PprCode
printSDocLn ctx LeftMode h doc
Stream.consume cmm_stream id writeC
@@ -253,11 +253,11 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do
let
- stub_c_output_d = pprCode CStyle c_code
+ stub_c_output_d = pprCode c_code
stub_c_output_w = showSDoc dflags stub_c_output_d
-- Header file protos for "foreign export"ed functions.
- stub_h_output_d = pprCode CStyle h_code
+ stub_h_output_d = pprCode h_code
stub_h_output_w = showSDoc dflags stub_h_output_d
createDirectoryIfMissing True (takeDirectory stub_h)
@@ -330,6 +330,7 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
= {-# SCC profilingInitCode #-}
initializerCStub platform fn_name decls body
where
+ pdocC = pprCLabel platform CStyle
fn_name = mkInitializerStubLabel this_mod "prof_init"
decls = vcat
$ map emit_cc_decl local_CCs
@@ -342,22 +343,22 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
]
emit_cc_decl cc =
text "extern CostCentre" <+> cc_lbl <> text "[];"
- where cc_lbl = pdoc platform (mkCCLabel cc)
+ where cc_lbl = pdocC (mkCCLabel cc)
local_cc_list_label = text "local_cc_" <> ppr this_mod
emit_cc_list ccs =
text "static CostCentre *" <> local_cc_list_label <> text "[] ="
- <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma
+ <+> braces (vcat $ [ pdocC (mkCCLabel cc) <> comma
| cc <- ccs
] ++ [text "NULL"])
<> semi
emit_ccs_decl ccs =
text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
- where ccs_lbl = pdoc platform (mkCCSLabel ccs)
+ where ccs_lbl = pdocC (mkCCSLabel ccs)
singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
emit_ccs_list ccs =
text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
- <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma
+ <+> braces (vcat $ [ pdocC (mkCCSLabel cc) <> comma
| cc <- ccs
] ++ [text "NULL"])
<> semi
=====================================
compiler/GHC/Driver/Config/CmmToAsm.hs
=====================================
@@ -18,7 +18,7 @@ initNCGConfig :: DynFlags -> Module -> NCGConfig
initNCGConfig dflags this_mod = NCGConfig
{ ncgPlatform = targetPlatform dflags
, ncgThisModule = this_mod
- , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle)
+ , ncgAsmContext = initSDocContext dflags PprCode
, ncgProcAlignment = cmmProcAlignment dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, ncgPIC = positionIndependent dflags
=====================================
compiler/GHC/Driver/Config/CmmToLlvm.hs
=====================================
@@ -20,7 +20,7 @@ initLlvmCgConfig logger config_cache dflags = do
llvm_config <- readLlvmConfigCache config_cache
pure $! LlvmCgConfig {
llvmCgPlatform = targetPlatform dflags
- , llvmCgContext = initSDocContext dflags (PprCode CStyle)
+ , llvmCgContext = initSDocContext dflags PprCode
, llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
, llvmCgSplitSection = gopt Opt_SplitSections dflags
, llvmCgBmiVersion = case platformArch (targetPlatform dflags) of
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -606,7 +606,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
let home_unit = hsc_home_unit hsc_env
src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
- writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
+ writeFile empty_stub (showSDoc dflags (pprCode src))
let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
_ <- runPipeline (hsc_hooks hsc_env) pipeline
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -333,7 +333,7 @@ dsFCall fn_id co fcall mDeclHeader = do
toCName :: Id -> String
-toCName i = renderWithContext defaultSDocContext (pprCode CStyle (ppr (idName i)))
+toCName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i)))
toCType :: Type -> (Maybe Header, SDoc)
toCType = f False
=====================================
compiler/GHC/Iface/Tidy/StaticPtrTable.hs
=====================================
@@ -249,11 +249,11 @@ sptModuleInitCode platform this_mod entries =
[ text "static StgWord64 k" <> int i <> text "[2] = "
<> pprFingerprint fp <> semi
$$ text "extern StgPtr "
- <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+ <> (pprCLabel platform CStyle $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
$$ text "hs_spt_insert" <> parens
(hcat $ punctuate comma
[ char 'k' <> int i
- , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n))
+ , char '&' <> pprCLabel platform CStyle (mkClosureLabel (idName n) (idCafInfo n))
]
)
<> semi
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -297,7 +297,7 @@ direct_call caller call_conv lbl arity args
platform <- getPlatform
pprPanic "direct_call" $
text caller <+> ppr arity <+>
- pdoc platform lbl <+> ppr (length args) <+>
+ pprDebugCLabel platform lbl <+> ppr (length args) <+>
pdoc platform (map snd args) <+> ppr (map fst args)
| null rest_args -- Precisely the right number of arguments
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -363,7 +363,7 @@ emitTickyCounter cloType tickee
Just (CgIdInfo { cg_lf = cg_lf })
| isLFThunk cg_lf
-> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf
- _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pdoc (profilePlatform profile) (mkInfoTableLabel name NoCafRefs))
+ _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pprDebugCLabel (profilePlatform profile) (mkInfoTableLabel name NoCafRefs))
return $! zeroCLit platform
TickyLNE {} -> return $! zeroCLit platform
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -332,7 +332,7 @@ jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the messa
jsonLogAction logflags msg_class srcSpan msg
=
defaultLogActionHPutStrDoc logflags True stdout
- (withPprStyle (PprCode CStyle) (doc $$ text ""))
+ (withPprStyle PprCode (doc $$ text ""))
where
str = renderWithContext (log_default_user_context logflags) msg
doc = renderJSON $
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -96,7 +96,7 @@ module GHC.Utils.Outputable (
defaultSDocContext, traceSDocContext,
getPprStyle, withPprStyle, setStyleColoured,
pprDeeper, pprDeeperList, pprSetDepth,
- codeStyle, userStyle, dumpStyle, asmStyle,
+ codeStyle, userStyle, dumpStyle,
qualName, qualModule, qualPackage,
mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
mkUserStyle, cmdlineParserStyle, Depth(..),
@@ -170,7 +170,7 @@ data PprStyle
-- Does not assume tidied code: non-external names
-- are printed with uniques.
- | PprCode !LabelStyle -- ^ Print code; either C or assembler
+ | PprCode -- ^ Print code; either C or assembler
-- | Style of label pretty-printing.
--
@@ -550,12 +550,8 @@ queryQual s = QueryQualify (qualName s)
(qualPackage s)
codeStyle :: PprStyle -> Bool
-codeStyle (PprCode _) = True
-codeStyle _ = False
-
-asmStyle :: PprStyle -> Bool
-asmStyle (PprCode AsmStyle) = True
-asmStyle _other = False
+codeStyle PprCode = True
+codeStyle _ = False
dumpStyle :: PprStyle -> Bool
dumpStyle (PprDump {}) = True
@@ -603,9 +599,9 @@ bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
bufLeftRenderSDoc ctx bufHandle doc =
Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
-pprCode :: LabelStyle -> SDoc -> SDoc
+pprCode :: SDoc -> SDoc
{-# INLINE CONLIKE pprCode #-}
-pprCode cs d = withPprStyle (PprCode cs) d
+pprCode d = withPprStyle PprCode d
renderWithContext :: SDocContext -> SDoc -> String
renderWithContext ctx sdoc
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -48,9 +48,11 @@ T15723:
'$(TEST_HC)' $(TEST_HC_OPTS) -dynamic -shared T15723B.o -o T15723B.so
# Check that the static indirection b is compiled to an equiv directive
+# This will be .equiv T15155_b_closure,T15155_a_closure
+# or .equiv _T15155_b_closure,_T15155_a_closure on Darwin
T15155:
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O0 -ddump-asm T15155l.hs | \
- grep -F ".equiv T15155.b_closure,T15155.a_closure"
+ grep -F ".equiv"
# Same as above, but in LLVM. Check that the static indirection b is compiled to
# an alias.
=====================================
testsuite/tests/codeGen/should_compile/T15155.stdout-darwin
=====================================
@@ -0,0 +1 @@
+.equiv _T15155.b_closure,_T15155.a_closure
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5e0f086a43c4e830f3fec343917daf3cc24b73a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5e0f086a43c4e830f3fec343917daf3cc24b73a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220826/72da026d/attachment-0001.html>
More information about the ghc-commits
mailing list