diff options
27 files changed, 179 insertions, 180 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index c12ecff5eb..5a969d30f5 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/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 diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 977ab271f7..6eca29e722 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/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 diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index ec81099223..03d667b4d4 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/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 () diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 117ed9747a..24983360c2 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/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 diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 92ff930bf1..312dc2e4f7 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/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 diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 21b68a8f01..a8cfd23f08 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs index 0071f291a1..c017f376bb 100644 --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs index 9c50f7676c..16665b9c57 100644 --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/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 -> diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 503aca0b3e..407050d045 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index caa829db21..236ddb5ffc 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index 2bf8a58fd6..0b92afbfe6 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index c09d02bafc..19de3cd1e2 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/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.@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@ha" $$ text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@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 _ diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index 5bda8d7a01..c54ce8f906 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/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" diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 8eb69f5179..cad3ab7163 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/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 diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index 55c6e18883..cd110a0900 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/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 diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index ce5a7e156d..e07c0af91f 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/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 diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs index edf82a37cc..877035d7ec 100644 --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/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 diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs index 61ffb8bcf4..8097bbec7e 100644 --- a/compiler/GHC/Driver/Config/CmmToLlvm.hs +++ b/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 diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index b060b4f457..cd2c3e93be 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/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 diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs index 69ae4962d8..63350bf258 100644 --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/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 diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index 3107a593b1..63297f4ad2 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/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 diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 0857cf5db2..26ebb8a7f1 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/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 diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 9f9aa451e2..6e9b84d53c 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/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 diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 83b2600439..43a290189c 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/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 $ diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index c820c8b51d..e1c9ceb054 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/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 diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile index 90cf78fb4b..35242a5830 100644 --- a/testsuite/tests/codeGen/should_compile/Makefile +++ b/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. diff --git a/testsuite/tests/codeGen/should_compile/T15155.stdout-darwin b/testsuite/tests/codeGen/should_compile/T15155.stdout-darwin new file mode 100644 index 0000000000..535026aed4 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T15155.stdout-darwin @@ -0,0 +1 @@ +.equiv _T15155.b_closure,_T15155.a_closure |