[Git][ghc/ghc][wip/styled-labels-final] 4 commits: Specify style when printing labels
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Thu Aug 25 22:34:07 UTC 2022
Krzysztof Gogolewski pushed to branch wip/styled-labels-final at Glasgow Haskell Compiler / GHC
Commits:
889a490e by Krzysztof Gogolewski at 2022-08-26T00:31:29+02:00
Specify style when printing labels
- - - - -
4aa651b5 by Krzysztof Gogolewski at 2022-08-26T00:31:34+02:00
Fix test T15155
- - - - -
baf49542 by Krzysztof Gogolewski at 2022-08-26T00:31:34+02:00
Remove the PprCode parameter, assert OutputableP is used only for dumps
- - - - -
0ed62270 by Krzysztof Gogolewski at 2022-08-26T00:31:34+02:00
Fix remaining prints
- - - - -
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/-/compare/7094f35e49af5bd2b7033440b909a7b19ac354af...0ed622700c7ebf8cbaee0f0eb6931bae7d6a9de4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7094f35e49af5bd2b7033440b909a7b19ac354af...0ed622700c7ebf8cbaee0f0eb6931bae7d6a9de4
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/20220825/b3fae0b5/attachment-0001.html>
More information about the ghc-commits
mailing list