From 0c0cdcacd64860e3a5ae1b876734b4743c7b9252 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Thu, 13 Oct 2022 19:47:27 -0500 Subject: Use a more efficient printer for code generation (#21853) The changes in `GHC.Utils.Outputable` are the bulk of the patch and drive the rest. The types `HLine` and `HDoc` in Outputable can be used instead of `SDoc` and support printing directly to a handle with `bPutHDoc`. See Note [SDoc versus HDoc] and Note [HLine versus HDoc]. The classes `IsLine` and `IsDoc` are used to make the existing code polymorphic over `HLine`/`HDoc` and `SDoc`. This is done for X86, PPC, AArch64, DWARF and dependencies (printing module names, labels etc.). Co-authored-by: Alexis King Metric Decrease: CoOpt_Read ManyAlternatives ManyConstructors T10421 T12425 T12707 T13035 T13056 T13253 T13379 T18140 T18282 T18698a T18698b T1969 T20049 T21839c T21839r T3064 T3294 T4801 T5321FD T5321Fun T5631 T6048 T783 T9198 T9233 --- compiler/GHC/Builtin/PrimOps.hs | 5 +- compiler/GHC/ByteCode/Types.hs | 3 +- compiler/GHC/Cmm/CLabel.hs | 63 +-- compiler/GHC/Cmm/CLabel.hs-boot | 2 +- compiler/GHC/Cmm/DebugBlock.hs | 18 +- compiler/GHC/Cmm/Reg.hs | 5 +- compiler/GHC/CmmToAsm.hs | 57 +-- compiler/GHC/CmmToAsm/AArch64.hs | 6 +- compiler/GHC/CmmToAsm/AArch64/Ppr.hs | 156 +++---- compiler/GHC/CmmToAsm/Dwarf.hs | 63 ++- compiler/GHC/CmmToAsm/Dwarf/Constants.hs | 31 +- compiler/GHC/CmmToAsm/Dwarf/Types.hs | 149 ++++--- compiler/GHC/CmmToAsm/Instr.hs | 3 +- compiler/GHC/CmmToAsm/Monad.hs | 38 +- compiler/GHC/CmmToAsm/PIC.hs | 48 ++- compiler/GHC/CmmToAsm/PPC.hs | 3 +- compiler/GHC/CmmToAsm/PPC/CodeGen.hs | 2 +- compiler/GHC/CmmToAsm/PPC/Instr.hs | 4 +- compiler/GHC/CmmToAsm/PPC/Ppr.hs | 256 +++++------ compiler/GHC/CmmToAsm/Ppr.hs | 52 ++- compiler/GHC/CmmToAsm/X86.hs | 3 +- compiler/GHC/CmmToAsm/X86/CodeGen.hs | 2 +- compiler/GHC/CmmToAsm/X86/Instr.hs | 3 +- compiler/GHC/CmmToAsm/X86/Ppr.hs | 232 +++++----- compiler/GHC/Core/Opt/Simplify/Iteration.hs | 1 + compiler/GHC/HsToCore/Pmc/Solver/Types.hs | 2 +- compiler/GHC/Linker/Types.hs | 4 +- compiler/GHC/Types/CostCentre.hs | 43 +- compiler/GHC/Types/ForeignStubs.hs | 5 +- compiler/GHC/Types/Name.hs | 46 +- compiler/GHC/Types/Name/Occurrence.hs | 8 +- compiler/GHC/Types/Unique.hs | 4 +- compiler/GHC/Unit/Types.hs | 39 +- compiler/GHC/Utils/Asm.hs | 5 +- compiler/GHC/Utils/BufHandle.hs | 21 + compiler/GHC/Utils/Outputable.hs | 541 +++++++++++++++++++----- testsuite/tests/hiefile/should_run/TestUtils.hs | 7 +- 37 files changed, 1224 insertions(+), 706 deletions(-) diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index ecd9da0ac2..8b4fc099cd 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -11,6 +11,7 @@ module GHC.Builtin.PrimOps ( primOpType, primOpSig, primOpResultType, primOpTag, maxPrimOpTag, primOpOcc, primOpWrapperId, + pprPrimOp, tagToEnumKey, @@ -788,8 +789,10 @@ compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy -- Output stuff: -pprPrimOp :: PrimOp -> SDoc +pprPrimOp :: IsLine doc => PrimOp -> doc pprPrimOp other_op = pprOccName (primOpOcc other_op) +{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-} +{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- ************************************************************************ diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs index 6eb661ac18..830b60a4ca 100644 --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -115,7 +116,7 @@ instance Outputable TupleInfo where ppr TupleInfo{..} = text " ppr tupleSize <+> text "stack" <+> ppr tupleNativeStackSize <+> text "regs" <+> - ppr (map (text.show) $ regSetToList tupleRegs) <> + ppr (map (text @SDoc . show) $ regSetToList tupleRegs) <> char '>' voidTupleInfo :: TupleInfo diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 6d4397e62b..5fd6378678 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -307,12 +307,14 @@ data ModuleLabelKind | MLK_IPEBuffer deriving (Eq, Ord) -instance Outputable ModuleLabelKind where - ppr MLK_InitializerArray = text "init_arr" - ppr (MLK_Initializer s) = text ("init__" ++ s) - ppr MLK_FinalizerArray = text "fini_arr" - ppr (MLK_Finalizer s) = text ("fini__" ++ s) - ppr MLK_IPEBuffer = text "ipe_buf" +pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc +pprModuleLabelKind MLK_InitializerArray = text "init_arr" +pprModuleLabelKind (MLK_Initializer s) = text ("init__" ++ s) +pprModuleLabelKind MLK_FinalizerArray = text "fini_arr" +pprModuleLabelKind (MLK_Finalizer s) = text ("fini__" ++ s) +pprModuleLabelKind MLK_IPEBuffer = text "ipe_buf" +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-} +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True @@ -1416,7 +1418,7 @@ allocation. Take care if you want to remove them! -} -pprAsmLabel :: Platform -> CLabel -> SDoc +pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl instance OutputableP Platform CLabel where @@ -1426,19 +1428,19 @@ instance OutputableP Platform CLabel where PprDump{} -> pprCLabel platform CStyle lbl _ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl) -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc +pprCLabel :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] let !use_leading_underscores = platformLeadingUnderscore platform -- some platform (e.g. Darwin) require a leading "_" for exported asm -- symbols - maybe_underscore :: SDoc -> SDoc + maybe_underscore :: doc -> doc maybe_underscore doc = case sty of AsmStyle | use_leading_underscores -> pp_cSEP <> doc _ -> doc - tempLabelPrefixOrUnderscore :: SDoc + tempLabelPrefixOrUnderscore :: doc tempLabelPrefixOrUnderscore = case sty of AsmStyle -> asmTempLabelPrefix platform CStyle -> char '_' @@ -1490,14 +1492,14 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] IdLabel name _cafs flavor -> case sty of - AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor + AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor where isRandomGenerated = not (isExternalName name) internalNamePrefix = if isRandomGenerated then asmTempLabelPrefix platform else empty - CStyle -> ppr name <> ppIdFlavor flavor + CStyle -> pprName name <> ppIdFlavor flavor SRTLabel u -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt" @@ -1534,7 +1536,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] ] RtsLabel (RtsPrimOp primop) - -> maybe_underscore $ text "stg_" <> ppr primop + -> maybe_underscore $ text "stg_" <> pprPrimOp primop RtsLabel (RtsSlowFastTickyCtr pat) -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr" @@ -1552,12 +1554,12 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -- with a letter so the label will be legal assembly code. HpcTicksLabel mod - -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc" + -> maybe_underscore $ text "_hpc_tickboxes_" <> pprModule mod <> text "_hpc" - CC_Label cc -> maybe_underscore $ ppr cc - CCS_Label ccs -> maybe_underscore $ ppr ccs - 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 + CC_Label cc -> maybe_underscore $ pprCostCentre cc + CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> pprModule m <> text "_ipe") + ModuleLabel mod kind -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs @@ -1567,6 +1569,8 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info" CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret" CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure" +{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [Internal proc labels] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1587,21 +1591,24 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -- | Generate a label for a procedure internal to a module (if -- 'Opt_ExposeAllSymbols' is enabled). -- See Note [Internal proc labels]. -ppInternalProcLabel :: Module -- ^ the current module +ppInternalProcLabel :: IsLine doc + => Module -- ^ the current module -> CLabel - -> Maybe SDoc -- ^ the internal proc label + -> Maybe doc -- ^ the internal proc label ppInternalProcLabel this_mod (IdLabel nm _ flavour) | isInternalName nm = Just - $ text "_" <> ppr this_mod + $ text "_" <> pprModule this_mod <> char '_' <> ztext (zEncodeFS (occNameFS (occName nm))) <> char '_' <> pprUniqueAlways (getUnique nm) <> ppIdFlavor flavour ppInternalProcLabel _ _ = Nothing +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-} +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor :: IsLine doc => IdLabelInfo -> doc ppIdFlavor x = pp_cSEP <> case x of Closure -> text "closure" InfoTable -> text "info" @@ -1612,22 +1619,22 @@ ppIdFlavor x = pp_cSEP <> case x of IdTickyInfo TickyRednCounts -> text "ct" IdTickyInfo (TickyInferedTag unique) - -> text "ct_inf_tag" <> char '_' <> ppr unique + -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique ConEntry loc -> case loc of DefinitionSite -> text "con_entry" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry" ConInfoTable k -> case k of DefinitionSite -> text "con_info" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info" ClosureTable -> text "closure_tbl" Bytes -> text "bytes" BlockInfoTable -> text "info" -pp_cSEP :: SDoc +pp_cSEP :: IsLine doc => doc pp_cSEP = char '_' @@ -1641,13 +1648,13 @@ instance Outputable ForeignLabelSource where -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> SDoc -- for formatting labels +asmTempLabelPrefix :: IsLine doc => Platform -> doc -- for formatting labels asmTempLabelPrefix !platform = case platformOS platform of OSDarwin -> text "L" OSAIX -> text "__L" -- follow IBM XL C's convention _ -> text ".L" -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc +pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = case platformOS platform of OSDarwin diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot index 8fb1b74423..4a5ec3dde3 100644 --- a/compiler/GHC/Cmm/CLabel.hs-boot +++ b/compiler/GHC/Cmm/CLabel.hs-boot @@ -5,5 +5,5 @@ import GHC.Platform data CLabel -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc +pprCLabel :: IsLine doc => Platform -> LabelStyle -> CLabel -> doc diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 3a7ceb7746..bfcb16bff9 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -29,7 +29,8 @@ module GHC.Cmm.DebugBlock ( -- * Unwinding information UnwindTable, UnwindPoint(..), - UnwindExpr(..), toUnwindExpr + UnwindExpr(..), toUnwindExpr, + pprUnwindTable ) where import GHC.Prelude @@ -38,6 +39,7 @@ import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm +import GHC.Cmm.Reg ( pprGlobalReg ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module @@ -522,10 +524,18 @@ data UnwindExpr = UwConst !Int -- ^ literal value instance OutputableP Platform UnwindExpr where pdoc = pprUnwindExpr 0 -pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc +pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc +pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u)))) + where print_entry (reg, Nothing) = + parens (sep [pprGlobalReg reg, text "Nothing"]) + print_entry (reg, Just x) = + parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x]) + -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr)) + +pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case UwConst i -> int i - UwReg g 0 -> ppr g + UwReg g 0 -> pprGlobalReg g UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) UwDeref e -> char '*' <> pprUnwindExpr 3 env e UwLabel l -> pprAsmLabel env l @@ -536,6 +546,8 @@ pprUnwindExpr p env = \case UwTimes e0 e1 | p <= 1 -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1 other -> parens (pprUnwindExpr 0 env other) +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-} +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs index 6c94ecb2eb..a9b3fce101 100644 --- a/compiler/GHC/Cmm/Reg.hs +++ b/compiler/GHC/Cmm/Reg.hs @@ -12,6 +12,7 @@ module GHC.Cmm.Reg , localRegType -- * Global registers , GlobalReg(..), isArgReg, globalRegType + , pprGlobalReg , spReg, hpReg, spLimReg, hpLimReg, nodeReg , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg @@ -296,7 +297,7 @@ instance Outputable GlobalReg where instance OutputableP env GlobalReg where pdoc _ = ppr -pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg :: IsLine doc => GlobalReg -> doc pprGlobalReg gr = case gr of VanillaReg n _ -> char 'R' <> int n @@ -324,6 +325,8 @@ pprGlobalReg gr GCFun -> text "stg_gc_fun" BaseReg -> text "BaseReg" PicBaseReg -> text "PicBaseReg" +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-} +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- convenient aliases diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 9fed66053a..db3cc222b3 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -125,7 +125,6 @@ import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Utils.Logger -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic @@ -145,6 +144,7 @@ import Data.Maybe import Data.Ord ( comparing ) import Control.Monad import System.IO +import System.Directory ( getCurrentDirectory ) -------------------- nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply @@ -242,16 +242,17 @@ finishNativeGen :: Instruction instr -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs +finishNativeGen logger config modLoc bufh us ngs = withTimingSilent logger (text "NCG") (`seq` ()) $ do -- Write debug data and finish us' <- if not (ncgDwarfEnabled config) then return us else do - (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs) - emitNativeCode logger config bufh dwarf + compPath <- getCurrentDirectory + let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs) + (dwarf_s, _) = dwarfGen compPath config modLoc us (ngs_debug ngs) + emitNativeCode logger config bufh dwarf_h dwarf_s return us' - bFlush bufh -- dump global NCG stats for graph coloring allocator let stats = concat (ngs_colorStats ngs) @@ -284,8 +285,9 @@ finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs -- write out the imports let ctx = ncgAsmContext config - printSDocLn ctx Pretty.LeftMode h - $ makeImportsDoc config (concat (ngs_imports ngs)) + bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs)) + bFlush bufh + return us' where dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify) @@ -387,12 +389,17 @@ cmmNativeGens logger config ncgImpl h dbgMap = go let newFileIds = sortBy (comparing snd) $ nonDetEltsUFM $ fileIds' `minusUFM` fileIds -- See Note [Unique Determinism and code generation] - pprDecl (f,n) = text "\t.file " <> int n <+> - pprFilePathString (unpackFS f) - - emitNativeCode logger config h $ vcat $ - map pprDecl newFileIds ++ - map (pprNatCmmDecl ncgImpl) native + pprDecl (f,n) = line $ text "\t.file " <> int n <+> + pprFilePathString (unpackFS f) + + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad + emitNativeCode logger config h + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclH ncgImpl) native) + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclS ncgImpl) native) -- force evaluation all this stuff to avoid space leaks let platform = ncgPlatform config @@ -415,11 +422,11 @@ cmmNativeGens logger config ncgImpl h dbgMap = go go us' cmms ngs' (count + 1) -emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode logger config h sdoc = do - +-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad +emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO () +emitNativeCode logger config h hdoc sdoc = do let ctx = ncgAsmContext config - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc + {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc -- dump native code putDumpFileMaybe logger @@ -483,7 +490,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count putDumpFileMaybe logger Opt_D_dump_asm_native "Native code" FormatASM - (vcat $ map (pprNatCmmDecl ncgImpl) native) + (vcat $ map (pprNatCmmDeclS ncgImpl) native) maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -540,7 +547,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) putDumpFileMaybe logger Opt_D_dump_asm_regalloc_stages "Build/spill stages" @@ -584,7 +591,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) let mPprStats = if logHasDumpFlag logger Opt_D_dump_asm_stats @@ -736,7 +743,7 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = -- | Build a doc for all the imports. -- -makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc +makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc makeImportsDoc config imports = dyld_stubs imports $$ @@ -744,7 +751,7 @@ makeImportsDoc config imports -- dead-stripping of code and data on a per-symbol basis. -- There's a hack to make this work in PprMach.pprNatCmmDecl. (if platformHasSubsectionsViaSymbols platform - then text ".subsections_via_symbols" + then line $ text ".subsections_via_symbols" else Outputable.empty) $$ -- On recent GNU ELF systems one can mark an object file @@ -754,14 +761,14 @@ makeImportsDoc config imports -- security. GHC generated code does not need an executable -- stack so add the note in: (if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" + then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" else Outputable.empty) $$ -- And just because every other compiler does, let's stick in -- an identifier directive: .ident "GHC x.y.z" (if platformHasIdentDirective platform then let compilerIdent = text "GHC" <+> text cProjectVersion - in text ".ident" <+> doubleQuotes compilerIdent + in line $ text ".ident" <+> doubleQuotes compilerIdent else Outputable.empty) where @@ -769,7 +776,7 @@ makeImportsDoc config imports -- Generate "symbol stubs" for all external symbols that might -- come from a dynamic library. - dyld_stubs :: [CLabel] -> SDoc + dyld_stubs :: [CLabel] -> HDoc -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... dyld_stubs imps diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs index 8b85b12ff6..d814764b2d 100644 --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -11,6 +11,7 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types +import GHC.Utils.Outputable (ftext) import qualified GHC.CmmToAsm.AArch64.Instr as AArch64 import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64 @@ -28,7 +29,8 @@ ncgAArch64 config ,canShortcut = AArch64.canShortcut ,shortcutStatics = AArch64.shortcutStatics ,shortcutJump = AArch64.shortcutJump - ,pprNatCmmDecl = AArch64.pprNatCmmDecl config + ,pprNatCmmDeclS = AArch64.pprNatCmmDecl config + ,pprNatCmmDeclH = AArch64.pprNatCmmDecl config ,maxSpillSlots = AArch64.maxSpillSlots config ,allocatableRegs = AArch64.allocatableRegs platform ,ncgAllocMoreStack = AArch64.allocMoreStack platform @@ -55,5 +57,5 @@ instance Instruction AArch64.Instr where mkJumpInstr = AArch64.mkJumpInstr mkStackAllocInstr = AArch64.mkStackAllocInstr mkStackDeallocInstr = AArch64.mkStackDeallocInstr - mkComment = pure . AArch64.COMMENT + mkComment = pure . AArch64.COMMENT . ftext pprInstr = AArch64.pprInstr diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs index 5ca443f08e..e782bc41a0 100644 --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -29,12 +29,12 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) where platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas config dats @@ -50,42 +50,45 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config - then pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ -- pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform - then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':' + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] - text "\t.long " + line + $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pprAsmLabel platform lbl <> char ':') + $$ line (pprAsmLabel platform lbl <> char ':') -pprAlign :: Platform -> Alignment -> SDoc +pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign _platform alignment - = text "\t.balign " <> int (alignmentBytes alignment) + = line $ text "\t.balign " <> int (alignmentBytes alignment) -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg -- .balign is stable, whereas .align is platform dependent. - = text "\t.balign 8" -- always 8 + = line (text "\t.balign 8") -- always 8 -- | Print section header and appropriate alignment for that section. -- @@ -94,28 +97,28 @@ pprAlignForSection _platform _seg -- .section .text -- .balign 8 -- -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "AArch64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr - -> SDoc +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> doc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ (if ncgDwarfEnabled config - then pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':' + then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':') else empty ) where @@ -135,7 +138,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprLabel platform info_lbl $$ c $$ (if ncgDwarfEnabled config - then pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':' + then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':') else empty) -- Make sure the info table has the right .loc for the block -- coming right after it. See Note [Info Offset] @@ -143,7 +146,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: NCGConfig -> RawCmmStatics -> SDoc +pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel @@ -153,29 +156,29 @@ pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl (ncgPlatform config) alias - $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind' + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') pprDatas config (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData config) dats) where platform = ncgPlatform config -pprData :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprString str -pprData _config (CmmFileEmbed path) = pprFileEmbed path +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path) = line (pprFileEmbed path) pprData config (CmmUninitialised bytes) - = let platform = ncgPlatform config - in if platformOS platform == OSDarwin - then text ".space " <> int bytes - else text ".skip " <> int bytes + = line $ let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text "\t.globl " <> pprAsmLabel platform lbl + | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl) -- Note [Always use objects for info tables] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -187,7 +190,7 @@ pprGloblDecl platform lbl -- -- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as -- well. -pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" @@ -198,15 +201,15 @@ pprLabelType' platform lbl = isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) -- this is called pprTypeAndSizeDecl in PPC.Ppr -pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where platform = ncgPlatform config @@ -227,7 +230,7 @@ pprDataItem config lit ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm _ (ImmInt i) = int i pprImm _ (ImmInteger i) = integer i pprImm p (ImmCLbl l) = pprAsmLabel p l @@ -257,7 +260,7 @@ asmDoubleslashComment c = whenPprDebug $ text "//" <+> c asmMultilineComment :: SDoc -> SDoc asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" -pprIm :: Platform -> Imm -> SDoc +pprIm :: IsLine doc => Platform -> Imm -> doc pprIm platform im = case im of ImmInt i -> char '#' <> int i ImmInteger i -> char '#' <> integer i @@ -283,7 +286,7 @@ pprIm platform im = case im of ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']' _ -> panic "AArch64.pprIm" -pprExt :: ExtMode -> SDoc +pprExt :: IsLine doc => ExtMode -> doc pprExt EUXTB = text "uxtb" pprExt EUXTH = text "uxth" pprExt EUXTW = text "uxtw" @@ -293,13 +296,13 @@ pprExt ESXTH = text "sxth" pprExt ESXTW = text "sxtw" pprExt ESXTX = text "sxtx" -pprShift :: ShiftMode -> SDoc +pprShift :: IsLine doc => ShiftMode -> doc pprShift SLSL = text "lsl" pprShift SLSR = text "lsr" pprShift SASR = text "asr" pprShift SROR = text "ror" -pprOp :: Platform -> Operand -> SDoc +pprOp :: IsLine doc => Platform -> Operand -> doc pprOp plat op = case op of OpReg w r -> pprReg w r OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x @@ -312,7 +315,7 @@ pprOp plat op = case op of OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']' OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']' -pprReg :: Width -> Reg -> SDoc +pprReg :: forall doc. IsLine doc => Width -> Reg -> doc pprReg w r = case r of RegReal (RealRegSingle i) -> ppr_reg_no w i -- virtual regs should not show up, but this is helpful for debugging. @@ -322,7 +325,7 @@ pprReg w r = case r of _ -> pprPanic "AArch64.pprReg" (text $ show r) where - ppr_reg_no :: Width -> Int -> SDoc + ppr_reg_no :: Width -> Int -> doc ppr_reg_no w 31 | w == W64 = text "sp" | w == W32 = text "wsp" @@ -351,24 +354,27 @@ isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True isFloatOp _ = False -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of -- Meta Instructions --------------------------------------------------------- - COMMENT s -> asmComment s - MULTILINE_COMMENT s -> asmMultilineComment s - ANN d i -> pprInstr platform i <+> asmDoubleslashComment d - LOCATION file line col _name - -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col - DELTA d -> asmComment $ text ("\tdelta = " ++ show d) + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + COMMENT s -> dualDoc (asmComment s) empty + MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty + ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i) + + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) + DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" LDATA _ _ -> panic "pprInstr: LDATA" -- Pseudo Instructions ------------------------------------------------------- - PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!" - $$ text "\tmov x29, sp" + PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!", + text "\tmov x29, sp"] - POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16" + POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16" -- =========================================================================== -- AArch64 Instruction Set -- 1. Arithmetic Instructions ------------------------------------------------ @@ -430,28 +436,28 @@ pprInstr platform instr = case instr of -- 4. Branch Instructions ---------------------------------------------------- J t -> pprInstr platform (B t) - B (TBlock bid) -> text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - B (TLabel lbl) -> text "\tb" <+> pprAsmLabel platform lbl - B (TReg r) -> text "\tbr" <+> pprReg W64 r + B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl + B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r - BL (TBlock bid) _ _ -> text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - BL (TLabel lbl) _ _ -> text "\tbl" <+> pprAsmLabel platform lbl - BL (TReg r) _ _ -> text "\tblr" <+> pprReg W64 r + BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ _ -> line $ text "\tblr" <+> pprReg W64 r - BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pprAsmLabel platform lbl + BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!" -- 5. Atomic Instructions ---------------------------------------------------- -- 6. Conditional Instructions ----------------------------------------------- - CSET o c -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c + CSET o c -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c - CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl + CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!" - CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl + CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!" -- 7. Load and Store Instructions -------------------------------------------- @@ -532,23 +538,23 @@ pprInstr platform instr = case instr of LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3 -- 8. Synchronization Instructions ------------------------------------------- - DMBSY -> text "\tdmb sy" + DMBSY -> line $ text "\tdmb sy" -- 9. Floating Point Instructions -------------------------------------------- FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2 SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2 FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2 FABS o1 o2 -> op2 (text "\tfabs") o1 o2 - where op2 op o1 o2 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 - op3 op o1 o2 o3 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - op4 op o1 o2 o3 o4 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 - op_ldr o1 rest = text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]" - op_adrp o1 rest = text "\tadrp" <+> pprOp platform o1 <> comma <+> rest - op_add o1 rest = text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest - -pprBcond :: Cond -> SDoc + where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + op_ldr o1 rest = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]" + op_adrp o1 rest = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest + op_add o1 rest = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest + +pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of ALWAYS -> text "al" -- Always EQ -> text "eq" -- Equal diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 407050d045..0eef6ecb49 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -26,50 +26,47 @@ import Data.List ( sortBy ) import Data.Ord ( comparing ) import qualified Data.Map as Map import System.FilePath -import System.Directory ( getCurrentDirectory ) import qualified GHC.Cmm.Dataflow.Label as H import qualified GHC.Cmm.Dataflow.Collections as H -- | Generate DWARF/debug information -dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] - -> IO (SDoc, UniqSupply) -dwarfGen _ _ us [] = return (empty, us) -dwarfGen config modLoc us blocks = do +dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] + -> (doc, UniqSupply) +dwarfGen _ _ _ us [] = (empty, us) +dwarfGen compPath config modLoc us blocks = let platform = ncgPlatform config - -- Convert debug data structures to DWARF info records - let procs = debugSplitProcs blocks + -- Convert debug data structures to DWARF info records + procs = debugSplitProcs blocks stripBlocks dbg | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] } | otherwise = dbg - compPath <- getCurrentDirectory - let lowLabel = dblCLabel $ head procs + lowLabel = dblCLabel $ head procs highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs dwarfUnit = DwarfCompileUnit { dwChildren = map (procToDwarf config) (map stripBlocks procs) , dwName = fromMaybe "" (ml_hs_file modLoc) , dwCompDir = addTrailingPathSeparator compPath , dwProducer = cProjectName ++ " " ++ cProjectVersion - , dwLowLabel = pprAsmLabel platform lowLabel - , dwHighLabel = pprAsmLabel platform highLabel - , dwLineLabel = dwarfLineLabel + , dwLowLabel = lowLabel + , dwHighLabel = highLabel } - -- Check whether we have any source code information, so we do not - -- end up writing a pointer to an empty .debug_line section - -- (dsymutil on Mac Os gets confused by this). - let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) + -- Check whether we have any source code information, so we do not + -- end up writing a pointer to an empty .debug_line section + -- (dsymutil on Mac Os gets confused by this). + haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) || any haveSrcIn (dblBlocks blk) haveSrc = any haveSrcIn procs -- .debug_abbrev section: Declare the format we're using - let abbrevSct = pprAbbrevDecls platform haveSrc + abbrevSct = pprAbbrevDecls platform haveSrc -- .debug_info section: Information records on procedures and blocks - let -- unique to identify start and end compilation unit .debug_inf + -- unique to identify start and end compilation unit .debug_inf (unitU, us') = takeUniqFromSupply us - infoSct = vcat [ dwarfInfoLabel <> colon + infoSct = vcat [ line (dwarfInfoLabel <> colon) , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit @@ -78,21 +75,23 @@ dwarfGen config modLoc us blocks = do -- .debug_line section: Generated mainly by the assembler, but we -- need to label it - let lineSct = dwarfLineSection platform $$ - dwarfLineLabel <> colon + lineSct = dwarfLineSection platform $$ + line (dwarfLineLabel <> colon) -- .debug_frame section: Information about the layout of the GHC stack - let (framesU, us'') = takeUniqFromSupply us' + (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$ - dwarfFrameLabel <> colon $$ + line (dwarfFrameLabel <> colon) $$ pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units - let aranges' | ncgSplitSections config = map mkDwarfARange procs + aranges' | ncgSplitSections config = map mkDwarfARange procs | otherwise = [DwarfARange lowLabel highLabel] - let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU + aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU - return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') + in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-} +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Build an address range entry for one proc. -- With split sections, each proc needs its own entry, since they may get @@ -106,24 +105,24 @@ mkDwarfARange proc = DwarfARange lbl end -- | Header for a compilation unit, establishing global format -- parameters -compileUnitHeader :: Platform -> Unique -> SDoc +compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc compileUnitHeader platform unitU = let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel <> text "-4" -- length of initialLength field - in vcat [ pprAsmLabel platform cuLabel <> colon - , text "\t.long " <> length -- compilation unit size + in vcat [ line (pprAsmLabel platform cuLabel <> colon) + , line (text "\t.long " <> length) -- compilation unit size , pprHalf 3 -- DWARF version , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel -- abbrevs offset - , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size + , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size ] -- | Compilation unit footer, mainly establishing size of debug sections -compileUnitFooter :: Platform -> Unique -> SDoc +compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc compileUnitFooter platform unitU = let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU - in pprAsmLabel platform cuEndLabel <> colon + in line (pprAsmLabel platform cuEndLabel <> colon) -- | Splits the blocks by procedures. In the result all nested blocks -- will come from the same procedure as the top-level block. See diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs index b8fb5706cb..58e123176e 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -144,17 +144,29 @@ dW_OP_call_frame_cfa = 0x9c -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, - dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc + dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc dwarfInfoSection platform = dwarfSection platform "info" dwarfAbbrevSection platform = dwarfSection platform "abbrev" dwarfLineSection platform = dwarfSection platform "line" dwarfFrameSection platform = dwarfSection platform "frame" dwarfGhcSection platform = dwarfSection platform "ghc" dwarfARangesSection platform = dwarfSection platform "aranges" +{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -dwarfSection :: Platform -> String -> SDoc +dwarfSection :: IsDoc doc => Platform -> String -> doc dwarfSection platform name = - case platformOS platform of + line $ case platformOS platform of os | osElfTarget os -> text "\t.section .debug_" <> text name <> text ",\"\"," <> sectionType platform "progbits" @@ -162,13 +174,24 @@ dwarfSection platform name = -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" | otherwise -> text "\t.section .debug_" <> text name <> text ",\"dr\"" +{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-} +{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc dwarfInfoLabel = text ".Lsection_info" dwarfAbbrevLabel = text ".Lsection_abbrev" dwarfLineLabel = text ".Lsection_line" dwarfFrameLabel = text ".Lsection_frame" +{-# SPECIALIZE dwarfInfoLabel :: SDoc #-} +{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-} +{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineLabel :: SDoc #-} +{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameLabel :: SDoc #-} +{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8 diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index 236ddb5ffc..5722e07a3a 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -59,9 +59,8 @@ data DwarfInfo , dwName :: String , dwProducer :: String , dwCompDir :: String - , dwLowLabel :: SDoc - , dwHighLabel :: SDoc - , dwLineLabel :: SDoc } + , dwLowLabel :: CLabel + , dwHighLabel :: CLabel } | DwarfSubprogram { dwChildren :: [DwarfInfo] , dwName :: String , dwLabel :: CLabel @@ -88,13 +87,13 @@ data DwarfAbbrev deriving (Eq, Enum) -- | Generate assembly for the given abbreviation code -pprAbbrev :: DwarfAbbrev -> SDoc +pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc pprAbbrev = pprLEBWord . fromIntegral . fromEnum -- | Abbreviation declaration. This explains the binary encoding we -- use for representing 'DwarfInfo'. Be aware that this must be updated -- along with 'pprDwarfInfo'. -pprAbbrevDecls :: Platform -> Bool -> SDoc +pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc pprAbbrevDecls platform haveDebugLine = let mkAbbrev abbr tag chld flds = let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form @@ -111,7 +110,7 @@ pprAbbrevDecls platform haveDebugLine = , (dW_AT_frame_base, dW_FORM_block1) ] in dwarfAbbrevSection platform $$ - dwarfAbbrevLabel <> colon $$ + line (dwarfAbbrevLabel <> colon) $$ mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes ([(dW_AT_name, dW_FORM_string) , (dW_AT_producer, dW_FORM_string) @@ -144,9 +143,11 @@ pprAbbrevDecls platform haveDebugLine = , (dW_AT_ghc_span_end_col, dW_FORM_data2) ] $$ pprByte 0 +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-} +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Generate assembly for DWARF data -pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d = case d of DwarfCompileUnit {} -> hasChildren @@ -159,9 +160,11 @@ pprDwarfInfo platform haveSrc d vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$ pprDwarfInfoClose noChildren = pprDwarfInfoOpen platform haveSrc d +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-} +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print a CLabel name in a ".stringz \"LABEL\"" -pprLabelString :: Platform -> CLabel -> SDoc +pprLabelString :: IsDoc doc => Platform -> CLabel -> doc pprLabelString platform label = pprString' -- we don't need to escape the string as labels don't contain exotic characters $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm) @@ -169,22 +172,22 @@ pprLabelString platform label = -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch. -pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel - highLabel lineLbl) = + highLabel) = pprAbbrev DwAbbrCompileUnit $$ pprString name $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir -- Offset due to Note [Info Offset] - $$ pprWord platform (lowLabel <> text "-1") - $$ pprWord platform highLabel + $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1") + $$ pprWord platform (pprAsmLabel platform highLabel) $$ if haveSrc - then sectionOffset platform lineLbl dwarfLineLabel + then sectionOffset platform dwarfLineLabel dwarfLineLabel else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = - pprAsmLabel platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev abbrev $$ pprString name $$ pprLabelString platform label @@ -201,11 +204,11 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = parentValue = maybe empty pprParentDie parent pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = - pprAsmLabel platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev DwAbbrBlockWithoutCode $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = - pprAsmLabel platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev DwAbbrBlock $$ pprLabelString platform label $$ pprWord platform (pprAsmLabel platform marker) @@ -219,7 +222,7 @@ pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = $$ pprHalf (fromIntegral $ srcSpanEndCol ss) -- | Close a DWARF info record with children -pprDwarfInfoClose :: SDoc +pprDwarfInfoClose :: IsDoc doc => doc pprDwarfInfoClose = pprAbbrev DwAbbrNull -- | A DWARF address range. This is used by the debugger to quickly locate @@ -233,7 +236,7 @@ data DwarfARange -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry. -pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc +pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc pprDwarfARanges platform arngs unitU = let wordSize = platformWordSizeInBytes platform paddingSize = 4 :: Int @@ -243,7 +246,7 @@ pprDwarfARanges platform arngs unitU = pad n = vcat $ replicate n $ pprByte 0 -- Fix for #17428 initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize - in pprDwWord (ppr initialLength) + in pprDwWord (int initialLength) $$ pprHalf 2 $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel $$ pprByte (fromIntegral wordSize) @@ -254,8 +257,10 @@ pprDwarfARanges platform arngs unitU = -- terminus $$ pprWord platform (char '0') $$ pprWord platform (char '0') +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-} +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDwarfARange :: Platform -> DwarfARange -> SDoc +pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc pprDwarfARange platform arng = -- Offset due to Note [Info Offset]. pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1") @@ -299,7 +304,7 @@ instance OutputableP Platform DwarfFrameBlock where -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame -- parameters and the default stack layout. -pprDwarfFrame :: Platform -> DwarfFrame -> SDoc +pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") cieEndLabel = mkAsmTempEndLabel cieLabel @@ -307,7 +312,7 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro spReg = dwarfGlobalRegNo platform Sp retReg = dwarfReturnRegNo platform wordSize = platformWordSizeInBytes platform - pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc + pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw) -- Preserve C stack pointer: This necessary to override that default @@ -316,9 +321,9 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 _ -> empty - in vcat [ pprAsmLabel platform cieLabel <> colon + in vcat [ line (pprAsmLabel platform cieLabel <> colon) , pprData4' length -- Length of CIE - , pprAsmLabel platform cieStartLabel <> colon + , line (pprAsmLabel platform cieStartLabel <> colon) , pprData4' (text "-1") -- Common Information Entry marker (-1 = 0xf..f) , pprByte 3 -- CIE version (we require DWARF 3) @@ -346,23 +351,25 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro , pprLEBWord 0 ] $$ wordAlign platform $$ - pprAsmLabel platform cieEndLabel <> colon $$ + line (pprAsmLabel platform cieEndLabel <> colon) $$ -- Procedure unwind tables vcat (map (pprFrameProc platform cieLabel cieInit) procs) +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-} +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Writes a "Frame Description Entry" for a procedure. This consists -- mainly of referencing the CIE and writing state machine -- instructions to describe how the frame base (CFA) changes. -pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc +pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") procEnd = mkAsmTempProcEndLabel procLbl ifInfo str = if hasInfo then text str else empty -- see Note [Info Offset] - in vcat [ whenPprDebug $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon + in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel) - , pprAsmLabel platform fdeLabel <> colon + , line (pprAsmLabel platform fdeLabel <> colon) , pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE , pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer , pprWord platform (pprAsmLabel platform procEnd <> char '-' <> @@ -370,17 +377,17 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) ] $$ vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ wordAlign platform $$ - pprAsmLabel platform fdeEndLabel <> colon + line (pprAsmLabel platform fdeEndLabel <> colon) -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small -- optimisations saves a lot of space, as subsequent blocks often have -- the same unwind information. -pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc +pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 where - pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc + pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> let -- Did a register's unwind expression change? isChanged :: GlobalReg -> Maybe UnwindExpr @@ -450,12 +457,12 @@ dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg -- | Generate code for setting the unwind information for a register, -- optimized using its known old value in the table. Note that "Sp" is -- special: We see it as synonym for the CFA. -pprSetUnwind :: Platform +pprSetUnwind :: IsDoc doc => Platform -> GlobalReg -- ^ the register to produce an unwinding table entry for -> (Maybe UnwindExpr, Maybe UnwindExpr) -- ^ the old and new values of the register - -> SDoc + -> doc pprSetUnwind plat g (_, Nothing) = pprUndefUnwind plat g pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' @@ -495,13 +502,13 @@ pprSetUnwind plat g (_, Just uw) -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number. -pprLEBRegNo :: Platform -> GlobalReg -> SDoc +pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat -- | Generates a DWARF expression for the given unwind expression. If -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets -- mentioned. -pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc +pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc pprUnwindExpr platform spIsCFA expr = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) @@ -517,84 +524,100 @@ pprUnwindExpr platform spIsCFA expr pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul - in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length + in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length -- computed as the difference of the following local labels 2: and 1: - text "1:" $$ + line (text "1:") $$ pprE expr $$ - text "2:" + line (text "2:") -- | Generate code for re-setting the unwind information for a -- register to @undefined@ -pprUndefUnwind :: Platform -> GlobalReg -> SDoc +pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ pprLEBRegNo plat g -- | Align assembly at (machine) word boundary -wordAlign :: Platform -> SDoc +wordAlign :: IsDoc doc => Platform -> doc wordAlign plat = - text "\t.align " <> case platformOS plat of + line $ text "\t.align " <> case platformOS plat of OSDarwin -> case platformWordSize plat of PW8 -> char '3' PW4 -> char '2' - _other -> ppr (platformWordSizeInBytes plat) + _other -> int (platformWordSizeInBytes plat) +{-# SPECIALIZE wordAlign :: Platform -> SDoc #-} +{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a single byte of constant DWARF data -pprByte :: Word8 -> SDoc -pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) +pprByte :: IsDoc doc => Word8 -> doc +pprByte x = line $ text "\t.byte " <> integer (fromIntegral x) +{-# SPECIALIZE pprByte :: Word8 -> SDoc #-} +{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a two-byte constant integer -pprHalf :: Word16 -> SDoc -pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word) +pprHalf :: IsDoc doc => Word16 -> doc +pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x) +{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-} +{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a constant DWARF flag -pprFlag :: Bool -> SDoc +pprFlag :: IsDoc doc => Bool -> doc pprFlag f = pprByte (if f then 0xff else 0x00) -- | Assembly for 4 bytes of dynamic DWARF data -pprData4' :: SDoc -> SDoc -pprData4' x = text "\t.long " <> x +pprData4' :: IsDoc doc => Line doc -> doc +pprData4' x = line (text "\t.long " <> x) +{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-} +{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for 4 bytes of constant DWARF data -pprData4 :: Word -> SDoc -pprData4 = pprData4' . ppr +pprData4 :: IsDoc doc => Word -> doc +pprData4 = pprData4' . integer . fromIntegral -- | Assembly for a DWARF word of dynamic data. This means 32 bit, as -- we are generating 32 bit DWARF. -pprDwWord :: SDoc -> SDoc +pprDwWord :: IsDoc doc => Line doc -> doc pprDwWord = pprData4' +{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-} +{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a machine word of dynamic data. Depends on the -- architecture we are currently generating code for. -pprWord :: Platform -> SDoc -> SDoc +pprWord :: IsDoc doc => Platform -> Line doc -> doc pprWord plat s = - case platformWordSize plat of + line $ case platformWordSize plat of PW4 -> text "\t.long " <> s PW8 -> text "\t.quad " <> s +{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-} +{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes -- would be 0. The highest bit in every byte signals whether there -- are further bytes to read. -pprLEBWord :: Word -> SDoc +pprLEBWord :: IsDoc doc => Word -> doc pprLEBWord x | x < 128 = pprByte (fromIntegral x) | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ pprLEBWord (x `shiftR` 7) +{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-} +{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Same as @pprLEBWord@, but for a signed number -pprLEBInt :: Int -> SDoc +pprLEBInt :: IsDoc doc => Int -> doc pprLEBInt x | x >= -64 && x < 64 = pprByte (fromIntegral (x .&. 127)) | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ pprLEBInt (x `shiftR` 7) +{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-} +{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Generates a dynamic null-terminated string. If required the -- caller needs to make sure that the string is escaped properly. -pprString' :: SDoc -> SDoc -pprString' str = text "\t.asciz \"" <> str <> char '"' +pprString' :: IsDoc doc => Line doc -> doc +pprString' str = line (text "\t.asciz \"" <> str <> char '"') -- | Generate a string constant. We take care to escape the string. -pprString :: String -> SDoc +pprString :: IsDoc doc => String -> doc pprString str = pprString' $ hcat $ map escapeChar $ if str `lengthIs` utf8EncodedLength str @@ -602,7 +625,7 @@ pprString str else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str -- | Escape a single non-unicode character -escapeChar :: Char -> SDoc +escapeChar :: IsLine doc => Char -> doc escapeChar '\\' = text "\\\\" escapeChar '\"' = text "\\\"" escapeChar '\n' = text "\\n" @@ -621,9 +644,11 @@ escapeChar c -- us to just reference the target directly, and will figure out on -- their own that we actually need an offset. Finally, Windows has -- a special directive to refer to relative offsets. Fun. -sectionOffset :: Platform -> SDoc -> SDoc -> SDoc +sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc sectionOffset plat target section = case platformOS plat of OSDarwin -> pprDwWord (target <> char '-' <> section) - OSMinGW32 -> text "\t.secrel32 " <> target + OSMinGW32 -> line (text "\t.secrel32 " <> target) _other -> pprDwWord target +{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs index bc2e2969e6..aa8f538e07 100644 --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -15,6 +15,7 @@ import GHC.Utils.Outputable (SDoc) import GHC.Cmm.BlockId import GHC.CmmToAsm.Config +import GHC.Data.FastString -- | Holds a list of source and destination registers used by a -- particular instruction. @@ -160,4 +161,4 @@ class Instruction instr where pprInstr :: Platform -> instr -> SDoc -- Create a comment instruction - mkComment :: SDoc -> [instr] + mkComment :: FastString -> [instr] diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index eb445649c3..2a61ff0314 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -67,7 +67,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique ) import GHC.Unit.Module -import GHC.Utils.Outputable (SDoc, ppr) +import GHC.Utils.Outputable (SDoc, HDoc, ppr) import GHC.Utils.Panic (pprPanic) import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc @@ -84,7 +84,9 @@ data NcgImpl statics instr jumpDest = NcgImpl { shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel. - pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, + pprNatCmmDeclS :: NatCmmDecl statics instr -> SDoc, + pprNatCmmDeclH :: NatCmmDecl statics instr -> HDoc, + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] maxSpillSlots :: Int, allocatableRegs :: [RealReg], ncgAllocMoreStack :: Int -> NatCmmDecl statics instr @@ -103,6 +105,38 @@ data NcgImpl statics instr jumpDest = NcgImpl { -- when possible. } +{- Note [pprNatCmmDeclS and pprNatCmmDeclH] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS +and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively +(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally +implemented as a single, polymorphic function, but they need to be stored using +monomorphic types to ensure the specialized versions are used, which is +essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable). + +One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we +have a perfectly serviceable HDoc-based implementation that is more efficient. +However, it turns out we benefit from keeping both, for two (related) reasons: + + 1. Although we absolutely want to take care to use pprNatCmmDeclH for actual + code generation (the improved performance there is why we have HDoc at + all!), we also sometimes print assembly for debug dumps, when requested via + -ddump-asm. In this case, it’s more convenient to produce an SDoc, which + can be concatenated with other SDocs for consistency with the general- + purpose dump file infrastructure. + + 2. Some debug information is sometimes useful to include in -ddump-asm that is + neither necessary nor useful in normal code generation, and it turns out to + be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc. + +Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes +include additional information in the SDoc variant using dualDoc +(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is +absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm +is provided, as that would rather defeat the whole point. (Fortunately, the +difference in allocations between the two implementations is so vast that such a +mistake would readily show up in performance tests). -} + data NatM_State = NatM_State { natm_us :: UniqSupply, diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index 0b92afbfe6..e4b47f91f9 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -532,11 +532,11 @@ gotLabel -- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: NCGConfig -> SDoc +pprGotDeclaration :: NCGConfig -> HDoc pprGotDeclaration config = case (arch,os) of (ArchX86, OSDarwin) | ncgPIC config - -> vcat [ + -> lines_ [ text ".section __TEXT,__textcoal_nt,coalesced,no_toc", text ".weak_definition ___i686.get_pc_thunk.ax", text ".private_extern ___i686.get_pc_thunk.ax", @@ -548,26 +548,26 @@ pprGotDeclaration config = case (arch,os) of -- Emit XCOFF TOC section (_, OSAIX) - -> vcat $ [ text ".toc" - , text ".tc ghc_toc_table[TC],.LCTOC1" - , text ".csect ghc_toc_table[RW]" - -- See Note [.LCTOC1 in PPC PIC code] - , text ".set .LCTOC1,$+0x8000" - ] + -> lines_ $ [ text ".toc" + , text ".tc ghc_toc_table[TC],.LCTOC1" + , text ".csect ghc_toc_table[RW]" + -- See Note [.LCTOC1 in PPC PIC code] + , text ".set .LCTOC1,$+0x8000" + ] -- PPC 64 ELF v1 needs a Table Of Contents (TOC) (ArchPPC_64 ELF_V1, _) - -> text ".section \".toc\",\"aw\"" + -> line $ text ".section \".toc\",\"aw\"" -- In ELF v2 we also need to tell the assembler that we want ABI -- version 2. This would normally be done at the top of the file -- right after a file directive, but I could not figure out how -- to do that. (ArchPPC_64 ELF_V2, _) - -> vcat [ text ".abiversion 2", - text ".section \".toc\",\"aw\"" - ] + -> lines_ [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" + ] (arch, os) | osElfTarget os @@ -577,7 +577,7 @@ pprGotDeclaration config = case (arch,os) of | osElfTarget os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - -> vcat [ + -> lines_ [ -- See Note [.LCTOC1 in PPC PIC code] text ".section \".got2\",\"aw\"", text ".LCTOC1 = .+32768" ] @@ -595,15 +595,16 @@ pprGotDeclaration config = case (arch,os) of -- and one for non-PIC. -- -pprImportedSymbol :: NCGConfig -> CLabel -> SDoc +pprImportedSymbol :: NCGConfig -> CLabel -> HDoc pprImportedSymbol config importedLbl = case (arch,os) of + (ArchX86, OSDarwin) | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl -> if not pic then - vcat [ + lines_ [ text ".symbol_stub", - text "L" <> ppr_lbl lbl <> text "$stub:", + (text "L" <> ppr_lbl lbl <> text "$stub:"), text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tjmp *L" <> ppr_lbl lbl <> text "$lazy_ptr", @@ -614,7 +615,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of text "\tjmp dyld_stub_binding_helper" ] else - vcat [ + lines_ [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25", text "L" <> ppr_lbl lbl <> text "$stub:", @@ -631,7 +632,8 @@ pprImportedSymbol config importedLbl = case (arch,os) of text "\tpushl %eax", text "\tjmp dyld_stub_binding_helper" ] - $+$ vcat [ text ".section __DATA, __la_sym_ptr" + $$ lines_ [ + text ".section __DATA, __la_sym_ptr" <> (if pic then int 2 else int 3) <> text ",lazy_symbol_pointers", text "L" <> ppr_lbl lbl <> text "$lazy_ptr:", @@ -640,7 +642,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - -> vcat [ + -> lines_ [ text ".non_lazy_symbol_pointer", char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:", text "\t.indirect_symbol" <+> ppr_lbl lbl, @@ -667,7 +669,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> vcat [ + -> lines_ [ text "LC.." <> ppr_lbl lbl <> char ':', text "\t.long" <+> ppr_lbl lbl ] _ -> empty @@ -700,12 +702,11 @@ pprImportedSymbol config importedLbl = case (arch,os) of -- When needImportedSymbols is defined, -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. - (ArchPPC_64 _, _) | osElfTarget os -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> vcat [ + -> lines_ [ text ".LC_" <> ppr_lbl lbl <> char ':', text "\t.quad" <+> ppr_lbl lbl ] _ -> empty @@ -718,7 +719,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of W64 -> text "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" - in vcat [ + in lines_ [ text ".section \".got2\", \"aw\"", text ".LC_" <> ppr_lbl lbl <> char ':', symbolSize <+> ppr_lbl lbl ] @@ -729,6 +730,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of _ -> panic "PIC.pprImportedSymbol: no match" where platform = ncgPlatform config + ppr_lbl :: CLabel -> HLine ppr_lbl = pprAsmLabel platform arch = platformArch platform os = platformOS platform diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs index cbfbdb539c..40a629907f 100644 --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -28,7 +28,8 @@ ncgPPC config = NcgImpl , canShortcut = PPC.canShortcut , shortcutStatics = PPC.shortcutStatics , shortcutJump = PPC.shortcutJump - , pprNatCmmDecl = PPC.pprNatCmmDecl config + , pprNatCmmDeclH = PPC.pprNatCmmDecl config + , pprNatCmmDeclS = PPC.pprNatCmmDecl config , maxSpillSlots = PPC.maxSpillSlots config , allocatableRegs = PPC.allocatableRegs platform , ncgAllocMoreStack = PPC.allocMoreStack platform diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index f8563004b5..9ddcdc32dd 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -162,7 +162,7 @@ stmtToInstrs stmt = do config <- getConfig platform <- getPlatform case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) + CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL CmmUnwind {} -> return nilOL diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs index c852789bbe..639ae979f8 100644 --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -52,7 +52,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.CLabel -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) @@ -60,6 +59,7 @@ import GHC.Types.Unique.Supply import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE +import GHC.Data.FastString (FastString) import Data.Maybe (fromMaybe) @@ -179,7 +179,7 @@ data RI data Instr -- comment pseudo-op - = COMMENT SDoc + = COMMENT FastString -- location pseudo-op (file, line, col, name) | LOCATION Int Int Int String diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 19de3cd1e2..f03f56f6d8 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -46,7 +46,7 @@ import Data.Int -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas (ncgPlatform config) dats @@ -63,15 +63,15 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel lbl) - <> char ':' $$ - pprProcEndLabel platform lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl) + <> char ':') $$ + line (pprProcEndLabel platform lbl)) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform - then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':' + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -79,18 +79,20 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> pprAsmLabel platform info_lbl - <+> char '-' - <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) + line (text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)) else empty) $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl + then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl) else empty where prettyLbl = pprAsmLabel platform lbl @@ -98,47 +100,45 @@ pprSizeDecl platform lbl | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl | otherwise = prettyLbl -pprFunctionDescriptor :: Platform -> CLabel -> SDoc -pprFunctionDescriptor platform lab = pprGloblDecl platform lab - $$ text "\t.section \".opd\", \"aw\"" - $$ text "\t.align 3" - $$ pprAsmLabel platform lab <> char ':' - $$ text "\t.quad ." - <> pprAsmLabel platform lab - <> text ",.TOC.@tocbase,0" - $$ text "\t.previous" - $$ text "\t.type" - <+> pprAsmLabel platform lab - <> text ", @function" - $$ char '.' <> pprAsmLabel platform lab <> char ':' - -pprFunctionPrologue :: Platform -> CLabel ->SDoc -pprFunctionPrologue platform lab = pprGloblDecl platform lab - $$ text ".type " - <> pprAsmLabel platform lab - <> text ", @function" - $$ pprAsmLabel platform lab <> char ':' - $$ text "0:\taddis\t" <> pprReg toc - <> text ",12,.TOC.-0b@ha" - $$ text "\taddi\t" <> pprReg toc - <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> pprAsmLabel platform lab - <> text ",.-" <> pprAsmLabel platform lab - -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name - -> SDoc +pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionDescriptor platform lab = + vcat [pprGloblDecl platform lab, + line (text "\t.section \".opd\", \"aw\""), + line (text "\t.align 3"), + line (pprAsmLabel platform lab <> char ':'), + line (text "\t.quad ." + <> pprAsmLabel platform lab + <> text ",.TOC.@tocbase,0"), + line (text "\t.previous"), + line (text "\t.type" + <+> pprAsmLabel platform lab + <> text ", @function"), + line (char '.' <> pprAsmLabel platform lab <> char ':')] + +pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionPrologue platform lab = + vcat [pprGloblDecl platform lab, + line (text ".type " <> pprAsmLabel platform lab <> text ", @function"), + line (pprAsmLabel platform lab <> char ':'), + line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"), + line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"), + line (text "\t.localentry\t" <> pprAsmLabel platform lab <> + text ",.-" <> pprAsmLabel platform lab)] + +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':' -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr - -> SDoc +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> doc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ ppWhen (ncgDwarfEnabled config) ( - pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':' - <> pprProcEndLabel platform asmLbl + line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':' + <> pprProcEndLabel platform asmLbl) ) where asmLbl = blockLbl blockid @@ -152,7 +152,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) -pprDatas :: Platform -> RawCmmStatics -> SDoc +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel @@ -162,38 +162,38 @@ pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLi , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl platform alias - $$ text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind' + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> SDoc +pprData :: IsDoc doc => Platform -> CmmStatic -> doc pprData platform d = case d of - CmmString str -> pprString str - CmmFileEmbed path -> pprFileEmbed path - CmmUninitialised bytes -> text ".space " <> int bytes + CmmString str -> line (pprString str) + CmmFileEmbed path -> line (pprFileEmbed path) + CmmUninitialised bytes -> line (text ".space " <> int bytes) CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> pprAsmLabel platform lbl + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> pprAsmLabel platform lbl <> text ", @object" else empty -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl - $$ pprTypeAndSizeDecl platform lbl - $$ (pprAsmLabel platform lbl <> char ':') + $$ line (pprTypeAndSizeDecl platform lbl) + $$ line (pprAsmLabel platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -pprReg :: Reg -> SDoc +pprReg :: forall doc. IsLine doc => Reg -> doc pprReg r = case r of @@ -204,7 +204,7 @@ pprReg r RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where - ppr_reg_no :: Int -> SDoc + ppr_reg_no :: Int -> doc ppr_reg_no i | i <= 31 = int i -- GPRs | i <= 63 = int (i-32) -- FPRs @@ -212,7 +212,7 @@ pprReg r -pprFormat :: Format -> SDoc +pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of II8 -> text "b" @@ -223,7 +223,7 @@ pprFormat x FF64 -> text "fd" -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of { ALWAYS -> text ""; @@ -234,7 +234,7 @@ pprCond c GU -> text "gt"; LEU -> text "le"; } -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case ImmInt i -> int i ImmInteger i -> integer i @@ -264,7 +264,7 @@ pprImm platform = \case HIGHESTA i -> pprImm platform i <> text "@highesta" -pprAddr :: Platform -> AddrMode -> SDoc +pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform = \case AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2 AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ] @@ -272,14 +272,14 @@ pprAddr platform = \case AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc -pprAlignForSection platform seg = +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ let ppc64 = not $ target32Bit platform in case seg of Text -> text ".align 2" @@ -304,9 +304,9 @@ pprAlignForSection platform seg = | otherwise -> text ".align 2" OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" -pprDataItem :: Platform -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc pprDataItem platform lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where imm = litToImm lit archPPC_64 = not $ target32Bit platform @@ -333,21 +333,21 @@ pprDataItem platform lit = panic "PPC.Ppr.pprDataItem: no match" -asmComment :: SDoc -> SDoc +asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "#" <+> c -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of COMMENT s - -> asmComment s + -> line (asmComment (ftext s)) - LOCATION file line col _name - -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) DELTA d - -> asmComment $ text ("\tdelta = " ++ show d) + -> line (asmComment $ text ("\tdelta = " ++ show d)) NEWBLOCK _ -> panic "PprMach.pprInstr: NEWBLOCK" @@ -374,7 +374,7 @@ pprInstr platform instr = case instr of -} LD fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "l", (case fmt of @@ -403,7 +403,7 @@ pprInstr platform instr = case instr of -> panic "PPC.Ppr.pprInstr LDFAR: no match" LDR fmt reg1 addr - -> hcat [ + -> line $ hcat [ text "\tl", case fmt of II32 -> char 'w' @@ -416,7 +416,7 @@ pprInstr platform instr = case instr of ] LA fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "l", (case fmt of @@ -436,7 +436,7 @@ pprInstr platform instr = case instr of ] ST fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "st", pprFormat fmt, @@ -457,7 +457,7 @@ pprInstr platform instr = case instr of -> panic "PPC.Ppr.pprInstr STFAR: no match" STU fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "st", pprFormat fmt, @@ -471,7 +471,7 @@ pprInstr platform instr = case instr of ] STC fmt reg1 addr - -> hcat [ + -> line $ hcat [ text "\tst", case fmt of II32 -> char 'w' @@ -484,7 +484,7 @@ pprInstr platform instr = case instr of ] LIS reg imm - -> hcat [ + -> line $ hcat [ char '\t', text "lis", char '\t', @@ -494,7 +494,7 @@ pprInstr platform instr = case instr of ] LI reg imm - -> hcat [ + -> line $ hcat [ char '\t', text "li", char '\t', @@ -505,7 +505,7 @@ pprInstr platform instr = case instr of MR reg1 reg2 | reg1 == reg2 -> empty - | otherwise -> hcat [ + | otherwise -> line $ hcat [ char '\t', case targetClassOfReg platform reg1 of RcInteger -> text "mr" @@ -517,7 +517,7 @@ pprInstr platform instr = case instr of ] CMP fmt reg ri - -> hcat [ + -> line $ hcat [ char '\t', op, char '\t', @@ -535,7 +535,7 @@ pprInstr platform instr = case instr of ] CMPL fmt reg ri - -> hcat [ + -> line $ hcat [ char '\t', op, char '\t', @@ -553,7 +553,7 @@ pprInstr platform instr = case instr of ] BCC cond blockid prediction - -> hcat [ + -> line $ hcat [ char '\t', text "b", pprCond cond, @@ -568,7 +568,7 @@ pprInstr platform instr = case instr of Just False -> char '-' BCCFAR cond blockid prediction - -> vcat [ + -> lines_ [ hcat [ text "\tb", pprCond (condNegate cond), @@ -590,7 +590,7 @@ pprInstr platform instr = case instr of -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" | otherwise -> - hcat [ -- an alias for b that takes a CLabel + lines_ [ -- an alias for b that takes a CLabel char '\t', text "b", char '\t', @@ -598,7 +598,7 @@ pprInstr platform instr = case instr of ] MTCTR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mtctr", char '\t', @@ -606,7 +606,7 @@ pprInstr platform instr = case instr of ] BCTR _ _ _ - -> hcat [ + -> line $ hcat [ char '\t', text "bctr" ] @@ -623,18 +623,18 @@ pprInstr platform instr = case instr of -- but when profiling the codegen inserts calls via -- 'emitRtsCallGen' which are 'CmmLabel's even though -- they'd technically be more like 'ForeignLabel's. - hcat [ + line $ hcat [ text "\tbl\t.", pprAsmLabel platform lbl ] _ -> - hcat [ + line $ hcat [ text "\tbl\t", pprAsmLabel platform lbl ] BCTRL _ - -> hcat [ + -> line $ hcat [ char '\t', text "bctrl" ] @@ -643,7 +643,7 @@ pprInstr platform instr = case instr of -> pprLogic platform (text "add") reg1 reg2 ri ADDIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "addis", char '\t', @@ -673,7 +673,7 @@ pprInstr platform instr = case instr of -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri - -> hcat [ + -> line $ hcat [ char '\t', text "subf", case ri of @@ -694,7 +694,7 @@ pprInstr platform instr = case instr of -> pprMul platform fmt reg1 reg2 ri MULLO fmt reg1 reg2 reg3 - -> hcat [ + -> line $ hcat [ char '\t', text "mull", case fmt of @@ -711,13 +711,13 @@ pprInstr platform instr = case instr of MFOV fmt reg -> vcat [ - hcat [ + lines_ [ char '\t', text "mfxer", char '\t', pprReg reg ], - hcat [ + lines_ [ char '\t', text "extr", case fmt of @@ -737,7 +737,7 @@ pprInstr platform instr = case instr of ] MULHU fmt reg1 reg2 reg3 - -> hcat [ + -> line $ hcat [ char '\t', text "mulh", case fmt of @@ -758,7 +758,7 @@ pprInstr platform instr = case instr of -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. AND reg1 reg2 (RIImm imm) - -> hcat [ + -> line $ hcat [ char '\t', text "andi.", char '\t', @@ -785,7 +785,7 @@ pprInstr platform instr = case instr of -> pprLogic platform (text "xor") reg1 reg2 ri ORIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "oris", char '\t', @@ -797,7 +797,7 @@ pprInstr platform instr = case instr of ] XORIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "xoris", char '\t', @@ -809,7 +809,7 @@ pprInstr platform instr = case instr of ] EXTS fmt reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "exts", pprFormat fmt, @@ -820,7 +820,7 @@ pprInstr platform instr = case instr of ] CNTLZ fmt reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "cntlz", case fmt of @@ -881,7 +881,7 @@ pprInstr platform instr = case instr of in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me - -> hcat [ + -> line $ hcat [ text "\trlwinm\t", pprReg reg1, text ", ", @@ -895,7 +895,7 @@ pprInstr platform instr = case instr of ] CLRLI fmt reg1 reg2 n - -> hcat [ + -> line $ hcat [ text "\tclrl", pprFormat fmt, text "i ", @@ -907,7 +907,7 @@ pprInstr platform instr = case instr of ] CLRRI fmt reg1 reg2 n - -> hcat [ + -> line $ hcat [ text "\tclrr", pprFormat fmt, text "i ", @@ -937,7 +937,7 @@ pprInstr platform instr = case instr of -> pprUnary (text "fneg") reg1 reg2 FCMP reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "fcmpu\t0, ", -- Note: we're using fcmpu, not fcmpo @@ -965,7 +965,7 @@ pprInstr platform instr = case instr of -> pprUnary (text "frsp") reg1 reg2 CRNOR dst src1 src2 - -> hcat [ + -> line $ hcat [ text "\tcrnor\t", int dst, text ", ", @@ -975,7 +975,7 @@ pprInstr platform instr = case instr of ] MFCR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mfcr", char '\t', @@ -983,7 +983,7 @@ pprInstr platform instr = case instr of ] MFLR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mflr", char '\t', @@ -991,25 +991,25 @@ pprInstr platform instr = case instr of ] FETCHPC reg - -> vcat [ + -> lines_ [ text "\tbcl\t20,31,1f", hcat [ text "1:\tmflr\t", pprReg reg ] ] HWSYNC - -> text "\tsync" + -> line $ text "\tsync" ISYNC - -> text "\tisync" + -> line $ text "\tisync" LWSYNC - -> text "\tlwsync" + -> line $ text "\tlwsync" NOP - -> text "\tnop" + -> line $ text "\tnop" -pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc -pprLogic platform op reg1 reg2 ri = hcat [ +pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc +pprLogic platform op reg1 reg2 ri = line $ hcat [ char '\t', op, case ri of @@ -1024,8 +1024,8 @@ pprLogic platform op reg1 reg2 ri = hcat [ ] -pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc -pprMul platform fmt reg1 reg2 ri = hcat [ +pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc +pprMul platform fmt reg1 reg2 ri = line $ hcat [ char '\t', text "mull", case ri of @@ -1043,8 +1043,8 @@ pprMul platform fmt reg1 reg2 ri = hcat [ ] -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc -pprDiv fmt sgn reg1 reg2 reg3 = hcat [ +pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc +pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [ char '\t', text "div", case fmt of @@ -1061,8 +1061,8 @@ pprDiv fmt sgn reg1 reg2 reg3 = hcat [ ] -pprUnary :: SDoc -> Reg -> Reg -> SDoc -pprUnary op reg1 reg2 = hcat [ +pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc +pprUnary op reg1 reg2 = line $ hcat [ char '\t', op, char '\t', @@ -1072,8 +1072,8 @@ pprUnary op reg1 reg2 = hcat [ ] -pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc -pprBinaryF op fmt reg1 reg2 reg3 = hcat [ +pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc +pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [ char '\t', op, pprFFormat fmt, @@ -1085,12 +1085,12 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [ pprReg reg3 ] -pprRI :: Platform -> RI -> SDoc +pprRI :: IsLine doc => Platform -> RI -> doc pprRI _ (RIReg r) = pprReg r pprRI platform (RIImm r) = pprImm platform r -pprFFormat :: Format -> SDoc +pprFFormat :: IsLine doc => Format -> doc pprFFormat FF64 = empty pprFFormat FF32 = char 's' pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index c54ce8f906..7959db8d69 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -27,7 +27,6 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -89,7 +88,7 @@ doubleToBytes d = runST $ do -- Print as a string and escape non-printable characters. -- This is similar to charToC in GHC.Utils.Misc -pprASCII :: ByteString -> SDoc +pprASCII :: forall doc. IsLine doc => ByteString -> doc pprASCII str -- Transform this given literal bytestring to escaped string and construct -- the literal SDoc directly. @@ -98,19 +97,19 @@ pprASCII str -- -- We work with a `Doc` instead of an `SDoc` because there is no need to carry -- an `SDocContext` that we don't use. It leads to nicer (STG) code. - = docToSDoc (BS.foldr f Pretty.empty str) + = BS.foldr f empty str where - f :: Word8 -> Pretty.Doc -> Pretty.Doc - f w s = do1 w Pretty.<> s - - do1 :: Word8 -> Pretty.Doc - do1 w | 0x09 == w = Pretty.text "\\t" - | 0x0A == w = Pretty.text "\\n" - | 0x22 == w = Pretty.text "\\\"" - | 0x5C == w = Pretty.text "\\\\" + f :: Word8 -> doc -> doc + f w s = do1 w <> s + + do1 :: Word8 -> doc + do1 w | 0x09 == w = text "\\t" + | 0x0A == w = text "\\n" + | 0x22 == w = text "\\\"" + | 0x5C == w = text "\\\\" -- ASCII printable characters range - | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w) - | otherwise = Pretty.sizedText 4 xs + | w >= 0x20 && w <= 0x7E = char (chr' w) + | otherwise = text xs where !xs = [ '\\', x0, x1, x2] -- octal !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) @@ -122,20 +121,25 @@ pprASCII str -- so we bypass the check in "chr" chr' :: Word8 -> Char chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) - +{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-} +{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Emit a ".string" directive -pprString :: ByteString -> SDoc +pprString :: IsLine doc => ByteString -> doc pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs) +{-# SPECIALIZE pprString :: ByteString -> SDoc #-} +{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Emit a ".incbin" directive -- -- A NULL byte is added after the binary data. -pprFileEmbed :: FilePath -> SDoc +pprFileEmbed :: IsLine doc => FilePath -> doc pprFileEmbed path = text "\t.incbin " <> pprFilePathString path -- proper escape (see #16389) <> text "\n\t.byte 0" +{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- Note [Embedding large binary blobs] @@ -193,14 +197,16 @@ string in source code. See #14741 for profiling results. -- identical strings in the linker. With -split-sections each string also gets -- a unique section to allow strings from unused code to be GC'd. -pprSectionHeader :: NCGConfig -> Section -> SDoc +pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc pprSectionHeader config (Section t suffix) = case platformOS (ncgPlatform config) of OSAIX -> pprXcoffSectionHeader t OSDarwin -> pprDarwinSectionHeader t _ -> pprGNUSectionHeader config t suffix +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-} +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc +pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc pprGNUSectionHeader config t suffix = hcat [text ".section ", header, subsection, flags] where @@ -244,10 +250,12 @@ pprGNUSectionHeader config t suffix = -> empty | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" _ -> empty +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-} +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections -pprXcoffSectionHeader :: SectionType -> SDoc +pprXcoffSectionHeader :: IsLine doc => SectionType -> doc pprXcoffSectionHeader t = case t of Text -> text ".csect .text[PR]" Data -> text ".csect .data[RW]" @@ -256,8 +264,10 @@ pprXcoffSectionHeader t = case t of CString -> text ".csect .text[PR] # CString" UninitialisedData -> text ".csect .data[BS]" _ -> panic "pprXcoffSectionHeader: unknown section type" +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDarwinSectionHeader :: SectionType -> SDoc +pprDarwinSectionHeader :: IsLine doc => SectionType -> doc pprDarwinSectionHeader t = case t of Text -> text ".text" Data -> text ".data" @@ -268,3 +278,5 @@ pprDarwinSectionHeader t = case t of FiniArray -> panic "pprDarwinSectionHeader: fini not supported" CString -> text ".section\t__TEXT,__cstring,cstring_literals" OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type" +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs index 91b571f4de..a82674afe8 100644 --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -33,7 +33,8 @@ ncgX86_64 config = NcgImpl , canShortcut = X86.canShortcut , shortcutStatics = X86.shortcutStatics , shortcutJump = X86.shortcutJump - , pprNatCmmDecl = X86.pprNatCmmDecl config + , pprNatCmmDeclS = X86.pprNatCmmDecl config + , pprNatCmmDeclH = X86.pprNatCmmDecl config , maxSpillSlots = X86.maxSpillSlots config , allocatableRegs = X86.allocatableRegs platform , ncgAllocMoreStack = X86.allocMoreStack platform diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index fd85ae6154..67c5504295 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -326,7 +326,7 @@ stmtToInstrs bid stmt = do -> genForeignCall target result_regs args bid _ -> (,Nothing) <$> case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) + CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL CmmUnwind regs -> do diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs index 42b9543204..59c4770c9b 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -67,6 +67,7 @@ import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable) import Data.Maybe (fromMaybe) +import GHC.Data.FastString (FastString) -- Format of an x86/x86_64 memory address, in bytes. -- @@ -170,7 +171,7 @@ bit precision. data Instr -- comment pseudo-op - = COMMENT SDoc + = COMMENT FastString -- location pseudo-op (file, line, col, name) | LOCATION Int Int Int String diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 0b19665857..11c882e547 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- @@ -11,11 +12,7 @@ module GHC.CmmToAsm.X86.Ppr ( pprNatCmmDecl, - pprData, pprInstr, - pprFormat, - pprImm, - pprDataItem, ) where @@ -39,6 +36,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.DebugBlock (pprUnwindTable) import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) @@ -65,12 +63,12 @@ import Data.Word -- .subsections_via_symbols and -dead_strip can be found at -- -pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) where platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas config dats @@ -85,7 +83,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprProcLabel config lbl $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> @@ -93,48 +91,51 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprProcAlignment config $$ pprProcLabel config lbl $$ (if platformHasSubsectionsViaSymbols platform - then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon) else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] - text "\t.long " + line + $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Output an internal proc label. See Note [Internal proc labels] in CLabel. -pprProcLabel :: NCGConfig -> CLabel -> SDoc +pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc pprProcLabel config lbl | ncgExposeInternalSymbols config , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl - = lbl' <> colon + = line (lbl' <> colon) | otherwise = empty -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name - -> SDoc +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon -pprBlockEndLabel :: Platform -> CLabel -- ^ Block name - -> SDoc +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc pprBlockEndLabel platform lbl = pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ @@ -142,8 +143,8 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) ppWhen (ncgDwarfEnabled config) ( -- Emit both end labels since this may end up being a standalone -- top-level block - pprBlockEndLabel platform asmLbl - <> pprProcEndLabel platform asmLbl + line (pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl) ) where asmLbl = blockLbl blockid @@ -156,7 +157,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$ - ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon) + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon)) -- Make sure the info table has the right .loc for the block -- coming right after it. See Note [Info Offset] @@ -165,7 +166,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) _other -> empty -pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc +pprDatas :: IsDoc doc => NCGConfig -> (Alignment, RawCmmStatics) -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel @@ -175,31 +176,32 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl (ncgPlatform config) alias - $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind' + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) where platform = ncgPlatform config -pprData :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprString str -pprData _config (CmmFileEmbed path) = pprFileEmbed path +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path) = line (pprFileEmbed path) pprData config (CmmUninitialised bytes) - = let platform = ncgPlatform config + = line + $ let platform = ncgPlatform config in if platformOS platform == OSDarwin then text ".space " <> int bytes else text ".skip " <> int bytes pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> pprAsmLabel platform lbl + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" @@ -257,21 +259,21 @@ pprLabelType' platform lbl = isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) -pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pprAsmLabel platform lbl <> colon) + $$ line (pprAsmLabel platform lbl <> colon) -pprAlign :: Platform -> Alignment -> SDoc +pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign platform alignment - = text ".align " <> int (alignmentOn platform) + = line $ text ".align " <> int (alignmentOn platform) where bytes = alignmentBytes alignment alignmentOn platform = if platformOS platform == OSDarwin @@ -285,7 +287,7 @@ pprAlign platform alignment log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -pprReg :: Platform -> Format -> Reg -> SDoc +pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc pprReg platform f r = case r of RegReal (RealRegSingle i) -> @@ -297,7 +299,7 @@ pprReg platform f r RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where - ppr32_reg_no :: Format -> Int -> SDoc + ppr32_reg_no :: Format -> Int -> doc ppr32_reg_no II8 = ppr32_reg_byte ppr32_reg_no II16 = ppr32_reg_word ppr32_reg_no _ = ppr32_reg_long @@ -327,7 +329,7 @@ pprReg platform f r _ -> ppr_reg_float i } - ppr64_reg_no :: Format -> Int -> SDoc + ppr64_reg_no :: Format -> Int -> doc ppr64_reg_no II8 = ppr64_reg_byte ppr64_reg_no II16 = ppr64_reg_word ppr64_reg_no II32 = ppr64_reg_long @@ -385,7 +387,7 @@ pprReg platform f r _ -> ppr_reg_float i } -ppr_reg_float :: Int -> SDoc +ppr_reg_float :: IsLine doc => Int -> doc ppr_reg_float i = case i of 16 -> text "%xmm0" ; 17 -> text "%xmm1" 18 -> text "%xmm2" ; 19 -> text "%xmm3" @@ -397,7 +399,7 @@ ppr_reg_float i = case i of 30 -> text "%xmm14"; 31 -> text "%xmm15" _ -> text "very naughty x86 register" -pprFormat :: Format -> SDoc +pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of II8 -> text "b" II16 -> text "w" @@ -406,14 +408,14 @@ pprFormat x = case x of FF32 -> text "ss" -- "scalar single-precision float" (SSE2) FF64 -> text "sd" -- "scalar double-precision float" (SSE2) -pprFormat_x87 :: Format -> SDoc +pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of FF32 -> text "s" FF64 -> text "l" _ -> panic "X86.Ppr.pprFormat_x87" -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of { GEU -> text "ae"; LU -> text "b"; EQQ -> text "e"; GTT -> text "g"; @@ -426,7 +428,7 @@ pprCond c = case c of { ALWAYS -> text "mp"} -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case ImmInt i -> int i ImmInteger i -> integer i @@ -440,7 +442,7 @@ pprImm platform = \case -pprAddr :: Platform -> AddrMode -> SDoc +pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform (ImmAddr imm off) = let pp_imm = pprImm platform imm in @@ -471,16 +473,16 @@ pprAddr platform (AddrBaseIndex base index displacement) ppr_disp imm = pprImm platform imm -- | Print section header and appropriate alignment for that section. -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "X86.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc -pprAlignForSection platform seg = +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ text ".align " <> case platformOS platform of -- Darwin: alignments are given as shifts. @@ -505,9 +507,9 @@ pprAlignForSection platform seg = CString -> int 1 _ -> int 8 -pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where platform = ncgPlatform config imm = litToImm lit @@ -557,26 +559,26 @@ pprDataItem config lit [text "\t.quad\t" <> pprImm platform imm] -asmComment :: SDoc -> SDoc +asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "# " <> c -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc pprInstr platform i = case i of COMMENT s - -> asmComment s + -> line (asmComment (ftext s)) - LOCATION file line col _name - -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col + LOCATION file line' col _name + -> line (text "\t.loc " <> int file <+> int line' <+> int col) DELTA d - -> asmComment $ text ("\tdelta = " ++ show d) + -> line (asmComment $ text ("\tdelta = " ++ show d)) NEWBLOCK _ -> panic "pprInstr: NEWBLOCK" UNWIND lbl d - -> asmComment (text "\tunwind = " <> pdoc platform d) - $$ pprAsmLabel platform lbl <> colon + -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d)) + $$ line (pprAsmLabel platform lbl <> colon) LDATA _ _ -> panic "pprInstr: LDATA" @@ -794,19 +796,19 @@ pprInstr platform i = case i of -- POPA -> text "\tpopal" NOP - -> text "\tnop" + -> line $ text "\tnop" CLTD II8 - -> text "\tcbtw" + -> line $ text "\tcbtw" CLTD II16 - -> text "\tcwtd" + -> line $ text "\tcwtd" CLTD II32 - -> text "\tcltd" + -> line $ text "\tcltd" CLTD II64 - -> text "\tcqto" + -> line $ text "\tcqto" CLTD x -> panic $ "pprInstr: CLTD " ++ show x @@ -825,19 +827,19 @@ pprInstr platform i = case i of -> pprCondInstr (text "j") cond (pprImm platform imm) JMP (OpImm imm) _ - -> text "\tjmp " <> pprImm platform imm + -> line $ text "\tjmp " <> pprImm platform imm JMP op _ - -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op + -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op JMP_TBL op _ _ _ -> pprInstr platform (JMP op []) CALL (Left imm) _ - -> text "\tcall " <> pprImm platform imm + -> line $ text "\tcall " <> pprImm platform imm CALL (Right reg) _ - -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg + -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg IDIV fmt op -> pprFormatOp (text "idiv") fmt op @@ -881,20 +883,20 @@ pprInstr platform i = case i of -- FETCHGOT for PIC on ELF platforms FETCHGOT reg - -> vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], - hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", - pprReg platform II32 reg ] - ] + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", + pprReg platform II32 reg ] + ] -- FETCHPC for PIC on Darwin/x86 -- get the instruction pointer into a register -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) FETCHPC reg - -> vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] - ] + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] + ] -- the -- GST fmt src addr ==> FLD dst ; FSTPsz addr @@ -903,10 +905,10 @@ pprInstr platform i = case i of -- Atomics LOCK i - -> text "\tlock" $$ pprInstr platform i + -> line (text "\tlock") $$ pprInstr platform i MFENCE - -> text "\tmfence" + -> line $ text "\tmfence" XADD format src dst -> pprFormatOpOp (text "xadd") format src dst @@ -916,46 +918,46 @@ pprInstr platform i = case i of where - gtab :: SDoc + gtab :: Line doc gtab = char '\t' - gsp :: SDoc + gsp :: Line doc gsp = char ' ' - pprX87 :: Instr -> SDoc -> SDoc + pprX87 :: Instr -> Line doc -> doc pprX87 fake actual - = (char '#' <> pprX87Instr fake) $$ actual + = line (char '#' <> pprX87Instr fake) $$ line actual - pprX87Instr :: Instr -> SDoc + pprX87Instr :: Instr -> Line doc pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" - pprDollImm :: Imm -> SDoc + pprDollImm :: Imm -> Line doc pprDollImm i = text "$" <> pprImm platform i - pprOperand :: Platform -> Format -> Operand -> SDoc + pprOperand :: Platform -> Format -> Operand -> Line doc pprOperand platform f op = case op of OpReg r -> pprReg platform f r OpImm i -> pprDollImm i OpAddr ea -> pprAddr platform ea - pprMnemonic_ :: SDoc -> SDoc + pprMnemonic_ :: Line doc -> Line doc pprMnemonic_ name = char '\t' <> name <> space - pprMnemonic :: SDoc -> Format -> SDoc + pprMnemonic :: Line doc -> Format -> Line doc pprMnemonic name format = char '\t' <> name <> pprFormat format <> space - pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc + pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc pprFormatImmOp name format imm op1 - = hcat [ + = line $ hcat [ pprMnemonic name format, char '$', pprImm platform imm, @@ -964,24 +966,24 @@ pprInstr platform i = case i of ] - pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc + pprFormatOp_ :: Line doc -> Format -> Operand -> doc pprFormatOp_ name format op1 - = hcat [ + = line $ hcat [ pprMnemonic_ name , pprOperand platform format op1 ] - pprFormatOp :: SDoc -> Format -> Operand -> SDoc + pprFormatOp :: Line doc -> Format -> Operand -> doc pprFormatOp name format op1 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1 ] - pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc + pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprFormatOpOp name format op1 op2 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, @@ -989,18 +991,18 @@ pprInstr platform i = case i of ] - pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc + pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprOpOp name format op1 op2 - = hcat [ + = line $ hcat [ pprMnemonic_ name, pprOperand platform format op1, comma, pprOperand platform format op2 ] - pprRegReg :: SDoc -> Reg -> Reg -> SDoc + pprRegReg :: Line doc -> Reg -> Reg -> doc pprRegReg name reg1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic_ name, pprReg platform (archWordFormat (target32Bit platform)) reg1, comma, @@ -1008,18 +1010,18 @@ pprInstr platform i = case i of ] - pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc + pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc pprFormatOpReg name format op1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, pprReg platform (archWordFormat (target32Bit platform)) reg2 ] - pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc + pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc pprCondOpReg name format cond op1 reg2 - = hcat [ + = line $ hcat [ char '\t', name, pprCond cond, @@ -1029,18 +1031,18 @@ pprInstr platform i = case i of pprReg platform format reg2 ] - pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc + pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc pprFormatFormatOpReg name format1 format2 op1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic name format2, pprOperand platform format1 op1, comma, pprReg platform format2 reg2 ] - pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc + pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc pprFormatOpOpReg name format op1 op2 reg3 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, @@ -1051,7 +1053,7 @@ pprInstr platform i = case i of - pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc + pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc pprFormatAddr name format op = hcat [ pprMnemonic name format, @@ -1059,9 +1061,9 @@ pprInstr platform i = case i of pprAddr platform op ] - pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc + pprShift :: Line doc -> Format -> Operand -> Operand -> doc pprShift name format src dest - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform II8 src, -- src is 8-bit sized comma, @@ -1069,15 +1071,15 @@ pprInstr platform i = case i of ] - pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc + pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, + = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, pprOperand platform format1 op1, comma, pprOperand platform format2 op2 ] - pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc + pprCondInstr :: Line doc -> Cond -> Line doc -> doc pprCondInstr name cond arg - = hcat [ char '\t', name, pprCond cond, space, arg] + = line $ hcat [ char '\t', name, pprCond cond, space, arg] diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index f3fb5c2f0b..dc7dc13637 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -3276,6 +3276,7 @@ addEvals _scrut con vs = go vs the_strs where ppr_with_length list = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp :: StrictnessMark -> SDoc strdisp MarkedStrict = text "MarkedStrict" strdisp NotMarkedStrict = text "NotMarkedStrict" diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs index fa22807358..e9c8c66033 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -766,7 +766,7 @@ it's already overloaded. instance Outputable PmLitValue where ppr (PmLitInt i) = ppr i - ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough + ppr (PmLitRat r) = double (fromRat r) -- good enough ppr (PmLitChar c) = pprHsChar c ppr (PmLitString s) = pprHsString s ppr (PmLitOverInt n i) = minuses n (ppr i) diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs index 605754b0ae..c26cdb0dad 100644 --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -5,7 +5,7 @@ -- (c) The University of Glasgow 2019 -- ----------------------------------------------------------------------------- - +{-# LANGUAGE TypeApplications #-} module GHC.Linker.Types ( Loader (..) , LoaderState (..) @@ -254,7 +254,7 @@ data LibrarySpec | Framework String -- Only used for darwin, but does no harm instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr (map text objs) + ppr (Objects objs) = text "Objects" <+> ppr (map (text @SDoc) objs) ppr (Archive a) = text "Archive" <+> text a ppr (DLL s) = text "DLL" <+> text s ppr (DLLPath f) = text "DLLPath" <+> text f diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs index 092b727d8d..2031f33d50 100644 --- a/compiler/GHC/Types/CostCentre.hs +++ b/compiler/GHC/Types/CostCentre.hs @@ -3,7 +3,9 @@ module GHC.Types.CostCentre ( CostCentre(..), CcName, CCFlavour(..), -- All abstract except to friend: ParseIface.y + pprCostCentre, CostCentreStack, + pprCostCentreStack, CollectedCCs, emptyCollectedCCs, collectCC, currentCCS, dontCareCCS, isCurrentCCS, @@ -236,10 +238,14 @@ mkSingletonCCS cc = SingletonCCS cc -- expression. instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + ppr = pprCostCentreStack +pprCostCentreStack :: IsLine doc => CostCentreStack -> doc +pprCostCentreStack CurrentCCS = text "CCCS" +pprCostCentreStack DontCareCCS = text "CCS_DONT_CARE" +pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs" +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-} +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ----------------------------------------------------------------------------- -- Printing Cost Centres @@ -256,10 +262,15 @@ instance Outputable CostCentreStack where -- by costCentreName. instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) + ppr = pprCostCentre + +pprCostCentre :: IsLine doc => CostCentre -> doc +pprCostCentre cc = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) + then ppCostCentreLbl cc + else text (costCentreUserName cc) +{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} +{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc @@ -284,26 +295,32 @@ pprIdxCore 0 = empty pprIdxCore idx = whenPprDebug $ ppr idx -- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl :: IsLine doc => CostCentre -> doc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModule m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> ppFlavourLblComponent f <> text "_cc" +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-} +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc ppFlavourLblComponent CafCC = text "CAF" ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-} +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc ppIdxLblComponent n = case unCostCentreIndex n of 0 -> empty - n -> ppr n + n -> int n +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-} +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs index b92bfd9b64..99dfcf61da 100644 --- a/compiler/GHC/Types/ForeignStubs.hs +++ b/compiler/GHC/Types/ForeignStubs.hs @@ -1,5 +1,6 @@ -- | Foreign export stubs {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.ForeignStubs ( ForeignStubs (..) , CHeader(..) @@ -68,10 +69,10 @@ newtype CHeader = CHeader { getCHeader :: SDoc } instance Monoid CHeader where mempty = CHeader empty - mconcat = coerce vcat + mconcat = coerce (vcat @SDoc) instance Semigroup CHeader where - (<>) = coerce ($$) + (<>) = coerce (($$) @SDoc) -- | Foreign export stubs data ForeignStubs diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 9f82fd42a8..9ee9ee322c 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -56,6 +56,7 @@ module GHC.Types.Name ( localiseName, namePun_maybe, + pprName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, pprFullName, pprTickyName, @@ -624,12 +625,13 @@ instance OutputableBndr Name where pprInfixOcc = pprInfixName pprPrefixOcc = pprPrefixName -pprName :: Name -> SDoc +pprName :: forall doc. IsLine doc => Name -> doc pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \sty -> - getPprDebug $ \debug -> - sdocOption sdocListTuplePuns $ \listTuplePuns -> - handlePuns listTuplePuns (namePun_maybe name) $ + = docWithContext $ \ctx -> + let sty = sdocStyle ctx + debug = sdocPprDebug ctx + listTuplePuns = sdocListTuplePuns ctx + in handlePuns listTuplePuns (namePun_maybe name) $ case sort of WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin External mod -> pprExternal debug sty uniq mod occ False UserSyntax @@ -637,9 +639,11 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) Internal -> pprInternal debug sty uniq occ where -- Print GHC.Types.List as [], etc. - handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc + handlePuns :: Bool -> Maybe FastString -> doc -> doc handlePuns True (Just pun) _ = ftext pun handlePuns _ _ r = r +{-# SPECIALISE pprName :: Name -> SDoc #-} +{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print fully qualified name (with unit-id, module and unique) pprFullName :: Module -> Name -> SDoc @@ -670,9 +674,9 @@ pprTickyName this_mod name pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc pprExternal debug sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? @@ -685,13 +689,13 @@ pprExternal debug sty uniq mod occ is_wired is_builtin if isHoleModule mod then case qualName sty mod occ of NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ) else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = ppUnlessOption sdocSuppressModulePrefixes - (ppr mod <> dot) + (pprModule mod <> dot) -pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprInternal debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), @@ -702,7 +706,7 @@ pprInternal debug sty uniq occ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprSystem debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -713,38 +717,38 @@ pprSystem debug sty uniq occ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in GHC.Types.Name.Ppr pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either + NameQual modname -> pprModuleName modname <> dot -- Name is in scope + NameNotInScope1 -> pprModule mod <> dot -- Not in scope + NameNotInScope2 -> pprUnit (moduleUnit mod) <> colon -- Module not in + <> pprModuleName (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified -pprUnique :: Unique -> SDoc +pprUnique :: IsLine doc => Unique -> doc -- Print a unique unless we are suppressing them pprUnique uniq = ppUnlessOption sdocSuppressUniques $ pprUniqueAlways uniq -ppr_underscore_unique :: Unique -> SDoc +ppr_underscore_unique :: IsLine doc => Unique -> doc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq = ppUnlessOption sdocSuppressUniques $ char '_' <> pprUniqueAlways uniq -ppr_occ_name :: OccName -> SDoc +ppr_occ_name :: IsLine doc => OccName -> doc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name :: IsLine doc => OccName -> doc ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) -- Prints (if mod information is available) "Defined at " or diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index 947982b53d..92691f3f2f 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -200,7 +200,7 @@ pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief :: IsLine doc => NameSpace -> doc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = text "tv" @@ -276,10 +276,10 @@ instance OutputableBndr OccName where pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) -pprOccName :: OccName -> SDoc +pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty + = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) then ztext (zEncodeFS occ) else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs index 60d1c452e2..c17d080f6f 100644 --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -281,13 +281,15 @@ showUnique uniq = case unpkUnique uniq of (tag, u) -> tag : iToBase62 u -pprUniqueAlways :: Unique -> SDoc +pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques -- It replaces the old pprUnique to remind callers that -- they should consider whether they want to consult -- Opt_SuppressUniques pprUniqueAlways u = text (showUnique u) +{-# SPECIALIZE pprUniqueAlways :: Unique -> SDoc #-} +{-# SPECIALIZE pprUniqueAlways :: Unique -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Outputable Unique where ppr = pprUniqueAlways diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index c0d314baa0..573801434d 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -50,6 +50,7 @@ module GHC.Unit.Types , stableUnitCmp , unitIsDefinite , isHoleUnit + , pprUnit -- * Unit Ids , unitIdString @@ -162,19 +163,24 @@ instance Outputable InstantiatedModule where ppr = pprInstantiatedModule instance Outputable InstantiatedUnit where - ppr uid = + ppr = pprInstantiatedUnit + +pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc +pprInstantiatedUnit uid = -- getPprStyle $ \sty -> - ppr cid <> + pprUnitId cid <> (if not (null insts) -- pprIf then brackets (hcat (punctuate comma $ - [ ppr modname <> text "=" <> pprModule m + [ pprModuleName modname <> text "=" <> pprModule m | (modname, m) <- insts])) else empty) where cid = instUnitInstanceOf uid insts = instUnitInsts uid +{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-} +{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) -- @@ -195,8 +201,8 @@ instance IsUnitId u => IsUnitId (GenUnit u) where unitFS (RealUnit (Definite x)) = unitFS x unitFS HoleUnit = holeFS -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc +pprModule :: IsLine doc => Module -> doc +pprModule mod@(Module p n) = docWithContext (doc . sdocStyle) where doc sty | codeStyle sty = @@ -207,10 +213,11 @@ pprModule mod@(Module p n) = getPprStyle doc | qualModule sty mod = case p of HoleUnit -> angleBrackets (pprModuleName n) - _ -> ppr p <> char ':' <> pprModuleName n + _ -> pprUnit p <> char ':' <> pprModuleName n | otherwise = pprModuleName n - +{-# SPECIALIZE pprModule :: Module -> SDoc #-} +{-# SPECIALIZE pprModule :: Module -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable pprInstantiatedModule :: InstantiatedModule -> SDoc pprInstantiatedModule (Module uid m) = @@ -344,10 +351,12 @@ stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2 instance Outputable Unit where ppr pk = pprUnit pk -pprUnit :: Unit -> SDoc -pprUnit (RealUnit uid) = ppr uid -pprUnit (VirtUnit uid) = ppr uid +pprUnit :: IsLine doc => Unit -> doc +pprUnit (RealUnit (Definite d)) = pprUnitId d +pprUnit (VirtUnit uid) = pprInstantiatedUnit uid pprUnit HoleUnit = ftext holeFS +{-# SPECIALIZE pprUnit :: Unit -> SDoc #-} +{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Show Unit where show = unitString @@ -523,8 +532,14 @@ instance Uniquable UnitId where getUnique = getUnique . unitIdFS instance Outputable UnitId where - ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId] - -- in "GHC.Unit" + ppr = pprUnitId + +pprUnitId :: IsLine doc => UnitId -> doc +pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs) + -- see Note [Pretty-printing UnitId] in GHC.Unit + -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable +{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-} +{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated diff --git a/compiler/GHC/Utils/Asm.hs b/compiler/GHC/Utils/Asm.hs index 2841ad3efa..237e482661 100644 --- a/compiler/GHC/Utils/Asm.hs +++ b/compiler/GHC/Utils/Asm.hs @@ -12,9 +12,10 @@ import GHC.Platform import GHC.Utils.Outputable -- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: Platform -- ^ Target platform +sectionType :: IsLine doc + => Platform -- ^ Target platform -> String -- ^ section type - -> SDoc -- ^ pretty assembler fragment + -> doc -- ^ pretty assembler fragment sectionType platform ty = case platformArch platform of ArchARM{} -> char '%' <> text ty diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs index aed15610cb..7fbca1932a 100644 --- a/compiler/GHC/Utils/BufHandle.hs +++ b/compiler/GHC/Utils/BufHandle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- @@ -37,6 +38,10 @@ import Foreign import Foreign.C.String import System.IO +-- for RULES +import GHC.Exts (unpackCString#, unpackNBytes#, Int(..)) +import GHC.Ptr (Ptr(..)) + -- ----------------------------------------------------------------------------- data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) @@ -62,6 +67,22 @@ bPutChar b@(BufHandle buf r hdl) !c = do else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) writeFastMutInt r (i+1) +-- Equivalent of the text/str, text/unpackNBytes#, text/[] rules +-- in GHC.Utils.Ppr. +{-# RULES "hdoc/str" + forall a h. bPutStr h (unpackCString# a) = bPutPtrString h (mkPtrString# a) + #-} +{-# RULES "hdoc/unpackNBytes#" + forall p n h. bPutStr h (unpackNBytes# p n) = bPutPtrString h (PtrString (Ptr p) (I# n)) + #-} +{-# RULES "hdoc/[]#" + forall h. bPutStr h [] = return () + #-} + +{-# NOINLINE [0] bPutStr #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + bPutStr :: BufHandle -> String -> IO () bPutStr (BufHandle buf r hdl) !str = do i <- readFastMutInt r diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 1c6126d208..d23582897d 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -5,6 +5,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} {- (c) The University of Glasgow 2006-2012 @@ -21,15 +23,17 @@ module GHC.Utils.Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), + IsOutput(..), IsLine(..), IsDoc(..), + HLine, HDoc, + -- * Pretty printing combinators SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, + isEmpty, nest, + ptext, int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, @@ -38,10 +42,8 @@ module GHC.Utils.Outputable ( lambda, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, forAllLit, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + ($+$), + cat, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, speakNth, speakN, speakNOf, plural, singular, @@ -104,6 +106,8 @@ module GHC.Utils.Outputable ( ifPprDebug, whenPprDebug, getPprDebug, + bPutHDoc + ) where import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) @@ -113,7 +117,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) -import GHC.Utils.BufHandle (BufHandle) +import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col @@ -561,17 +565,17 @@ userStyle (PprUser {}) = True userStyle _other = False -- | Indicate if -dppr-debug mode is enabled -getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug :: IsOutput doc => (Bool -> doc) -> doc {-# INLINE CONLIKE getPprDebug #-} -getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) +getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx) -- | Says what to do with and without -dppr-debug -ifPprDebug :: SDoc -> SDoc -> SDoc +ifPprDebug :: IsOutput doc => doc -> doc -> doc {-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no -- | Says what to do with -dppr-debug; without, return empty -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style {-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty @@ -638,43 +642,26 @@ isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -{-# INLINE CONLIKE empty #-} -empty = docToSDoc $ Pretty.empty -{-# INLINE CONLIKE char #-} -char c = docToSDoc $ Pretty.char c - -{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire -text s = docToSDoc $ Pretty.text s - -{-# INLINE CONLIKE ftext #-} -ftext s = docToSDoc $ Pretty.ftext s +ptext :: PtrString -> SDoc +int :: IsLine doc => Int -> doc +integer :: IsLine doc => Integer -> doc +word :: Integer -> SDoc +float :: IsLine doc => Float -> doc +double :: IsLine doc => Double -> doc +rational :: Rational -> SDoc + {-# INLINE CONLIKE ptext #-} ptext s = docToSDoc $ Pretty.ptext s -{-# INLINE CONLIKE ztext #-} -ztext s = docToSDoc $ Pretty.ztext s {-# INLINE CONLIKE int #-} -int n = docToSDoc $ Pretty.int n +int n = text $ show n {-# INLINE CONLIKE integer #-} -integer n = docToSDoc $ Pretty.integer n +integer n = text $ show n {-# INLINE CONLIKE float #-} -float n = docToSDoc $ Pretty.float n +float n = text $ show n {-# INLINE CONLIKE double #-} -double n = docToSDoc $ Pretty.double n +double n = text $ show n {-# INLINE CONLIKE rational #-} -rational n = docToSDoc $ Pretty.rational n +rational n = text $ show n -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr {-# INLINE CONLIKE word #-} word n = sdocOption sdocHexWordLiterals $ \case @@ -686,19 +673,19 @@ word n = sdocOption sdocHexWordLiterals $ \case doublePrec :: Int -> Double -> SDoc doublePrec p n = text (showFFloat (Just p) n "") -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc +quotes, quote :: SDoc -> SDoc +parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc {-# INLINE CONLIKE parens #-} -parens d = SDoc $ Pretty.parens . runSDoc d +parens d = char '(' <> d <> char ')' {-# INLINE CONLIKE braces #-} -braces d = SDoc $ Pretty.braces . runSDoc d +braces d = char '{' <> d <> char '}' {-# INLINE CONLIKE brackets #-} -brackets d = SDoc $ Pretty.brackets . runSDoc d +brackets d = char '[' <> d <> char ']' {-# INLINE CONLIKE quote #-} quote d = SDoc $ Pretty.quote . runSDoc d {-# INLINE CONLIKE doubleQuotes #-} -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +doubleQuotes d = char '"' <> d <> char '"' {-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>' @@ -720,35 +707,37 @@ quotes d = sdocOption sdocCanUseUnicode $ \case _ | Just '\'' <- lastMaybe str -> pp_d | otherwise -> Pretty.quotes pp_d -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, + larrowtt, lambda :: SDoc blankLine = docToSDoc Pretty.emptyText -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +dcolon = unicodeSyntax (char '∷') (text "::") +arrow = unicodeSyntax (char '→') (text "->") +lollipop = unicodeSyntax (char '⊸') (text "%1 ->") +larrow = unicodeSyntax (char '←') (text "<-") +darrow = unicodeSyntax (char '⇒') (text "=>") +arrowt = unicodeSyntax (char '⤚') (text ">-") +larrowt = unicodeSyntax (char '⤙') (text "-<") +arrowtt = unicodeSyntax (char '⤜') (text ">>-") +larrowtt = unicodeSyntax (char '⤛') (text "-<<") lambda = unicodeSyntax (char 'λ') (char '\\') -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space + +semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc +semi = char ';' +comma = char ',' +colon = char ':' +equals = char '=' +space = char ' ' underscore = char '_' dot = char '.' vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") @@ -771,38 +760,15 @@ unicode unicode plain = sdocOption sdocCanUseUnicode $ \case nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically {-# INLINE CONLIKE nest #-} nest n d = SDoc $ Pretty.nest n . runSDoc d -{-# INLINE CONLIKE (<>) #-} -(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE (<+>) #-} -(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE ($$) #-} -($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) {-# INLINE CONLIKE ($+$) #-} ($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits cat :: [SDoc] -> SDoc --- ^ Concatenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc -- ^ A paragraph-fill combinator. It's much like sep, only it -- keeps fitting things on one line until it can't fit any more. fcat :: [SDoc] -> SDoc @@ -812,18 +778,8 @@ fcat :: [SDoc] -> SDoc -- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc -- later applied to the same SDocContext. It helps the worker/wrapper -- transformation extracting only the required fields from the SDocContext. -{-# INLINE CONLIKE hcat #-} -hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE hsep #-} -hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE vcat #-} -vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE sep #-} -sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE cat #-} cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE fsep #-} -fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE fcat #-} fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] @@ -841,16 +797,17 @@ hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc hangNotEmpty d1 n d2 = SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list +punctuate :: IsLine doc + => doc -- ^ The punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es -ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc ppWhen False _ = empty @@ -866,10 +823,9 @@ ppWhenOption f doc = sdocOption f $ \case False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppUnlessOption f doc = sdocOption f $ \case - True -> empty - False -> doc +ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc +ppUnlessOption f doc = docWithContext $ + \ctx -> if f ctx then empty else doc -- | Apply the given colour\/style for the argument. -- @@ -1041,12 +997,14 @@ instance Outputable Extension where instance Outputable ModuleName where ppr = pprModuleName -pprModuleName :: ModuleName -> SDoc +pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty + docWithContext $ \ctx -> + if codeStyle (sdocStyle ctx) then ztext (zEncodeFS nm) else ftext nm +{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} +{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] ----------------------------------------------------------------------- -- The @OutputableP@ class @@ -1314,12 +1272,14 @@ pprFastFilePath path = text $ normalise $ unpackFS path -- | Normalise, escape and render a string representing a path -- -- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc +pprFilePathString :: IsLine doc => FilePath -> doc pprFilePathString path = doubleQuotes $ text (escape (normalise path)) where escape [] = [] escape ('\\':xs) = '\\':'\\':escape xs escape (x:xs) = x:escape xs +{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] {- ************************************************************************ @@ -1498,3 +1458,352 @@ thisOrThese _ = text "These" hasOrHave :: [a] -> SDoc hasOrHave [_] = text "has" hasOrHave _ = text "have" + +{- Note [SDoc versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SDoc type is used pervasively throughout the compiler to represent pretty- +printable output. Almost all text written by GHC, from the Haskell types and +expressions included in error messages to debug dumps, is assembled using SDoc. +SDoc is nice because it handles multiline layout in a semi-automatic fashion, +enabling printed expressions to wrap to fit a given line width while correctly +indenting the following lines to preserve alignment. + +SDoc’s niceties necessarily have some performance cost, but this is normally +okay, as printing output is rarely a performance bottleneck. However, one +notable exception to this is code generation: GHC must sometimes write +megabytes’ worth of generated assembly when compiling a single module, in which +case the overhead of SDoc has a significant cost (see #21853 for some numbers). +Moreover, generated assembly does not have the complex layout requirements of +pretty-printed Haskell code, so using SDoc does not buy us much, anyway. + +Nevertheless, we do still want to be able to share some logic between writing +assembly and pretty-printing. For example, the logic for printing basic block +labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single +implementation that can be used both when generating code and when generating +Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc +interface, but it is implemented in a far more efficient way, writing directly +to a `Handle` (via a `BufHandle`) without building any intermediate structures. +We can then use typeclasses to parameterize functions like `pprCLabel` over the +printing implementation. + +One might imagine this would result in one IsDoc typeclass, and two instances, +one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc, +as described in Note [HLine versus HDoc], and this gives rise to a small +typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc; +see Note [The outputable class hierarchy] for details. + +Note [HLine versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], HDoc does not support any of the layout +niceties of SDoc for efficiency. However, this presents a small problem if we +want to be compatible with the SDoc API, as expressions like + + text "foo" <+> (text "bar" $$ text "baz") + +are expected to produce + + foo bar + baz + +which requires tracking line widths to know how far to indent the second line. +We can’t throw out vertical composition altogether, as we need to be able to +construct multiline HDocs, but we *can* restrict vertical composition to +concatenating whole lines at a time, as this is all that is necessary to +generate assembly in the code generator. + +To implement this restriction, we provide two distinct types: HLine and HDoc. +As their names suggests, an HLine represents a single line of output, while an +HDoc represents a multiline document. Atoms formed from `char` and `text` begin +their lives as HLines, which can be horizontally (but not vertically) composed: + + char :: Char -> HLine + text :: String -> HLine + (<+>) :: HLine -> HLine -> HLine + +Once a line has been fully assembled, it can be “locked up” into a single-line +HDoc via `line`, and HDocs can be vertically (but not horizontally) composed: + + line :: HLine -> HDoc + ($$) :: HLine -> HLine -> HLine + +Note that, at runtime, HLine and HDoc use exactly the same representation. This +distinction only exists in the type system to rule out the cases we don’t want +to have to handle. + +Note [The outputable class hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], we want to be able to parameterize over +the choice of printing implementation when implementing common bits of printing +logic. However, as described in Note [HLine versus HDoc], we also want to +distinguish code that does single-line printing from code that does multi-line +printing. Therefore, code that is parameterized over the choice of printer must +respect this single- versus multi-line distinction. This naturally leads to two +typeclasses: + + class IsLine doc where + char :: Char -> doc + text :: String -> doc + (<>) :: doc -> doc -> doc + ... + + class IsLine (Line doc) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + ($$) :: doc -> doc -> doc + ... + +These classes support the following instances: + + instance IsLine SDoc + instance IsLine SDoc where + type Line SDoc = SDoc + + instance IsLine HLine + instance IsDoc HDoc where + type Line HDoc = HLine + +However, we run into a new problem: we provide many useful combinators on docs +that don’t care at all about the single-/multi-line distinction. For example, +ppWhen and ppUnless provide conditional logic, and docWithContext provides +access to the ambient SDocContext. Given the above classes, we would need two +variants of each of these combinators: + + ppWhenL :: IsLine doc => Bool -> doc -> doc + ppWhenL c d = if c then d else emptyL + + ppWhenD :: IsDoc doc => Bool -> doc -> doc + ppWhenD c d = if c then d else emptyD + +This is a needlessly annoying distinction, so we introduce a common superclass, +IsOutput, that allows these combinators to be generic over both variants: + + class IsOutput doc => IsLine doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + + class IsOutput doc => IsLine doc + class (IsOutput doc, IsLine (Line doc)) => IsDoc doc + +In practice, IsOutput isn’t used explicitly very often, but it makes code that +uses the combinators derived from it significantly less noisy. + +Note [SPECIALIZE to HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes are useful to share printing logic between code +that uses SDoc and code that uses HDoc, but we must take some care when doing +so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses +it to eliminate unnecessary indirection, but the HDoc primitives must be inlined +before these opportunities can be exposed. Therefore, we want to explicitly +request that GHC generate HDoc (or HLine) specializations of any polymorphic +printing functions used by the code generator. + +In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize +pragma just to the entry point pprNatCmmDecl, to avoid cluttering +the entire module. Because specialization is transitive, this makes sure +that other functions in that module are specialized too. + +Note [dualLine and dualDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes provide the dualLine and dualDoc methods, +respectively, which have the following types: + + dualLine :: IsLine doc => SDoc -> HLine -> doc + dualDoc :: IsDoc doc => SDoc -> HDoc -> doc + +These are effectively a form of type-`case`, selecting between each of their two +arguments depending on the type they are instantiated at. They serve as a +“nuclear option” for code that is, for some reason or another, unreasonably +difficult to make completely equivalent under both printer implementations. + +These operations should generally be avoided, as they can result in surprising +changes in behavior when the printer implementation is changed. However, in +certain cases, the alternative is even worse. For example, we use dualLine in +the implementation of pprUnitId, as the hack we use for printing unit ids +(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine +and is not necessary for code paths that use it, anyway. + +Use these operations wisely. -} + +-- | Represents a single line of output that can be efficiently printed directly +-- to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () } + +-- | Represents a (possibly empty) sequence of lines that can be efficiently +-- printed directly to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () } + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine +pattern HLine f <- HLine' f + where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HLine #-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc +pattern HDoc f <- HDoc' f + where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HDoc #-} + +bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () +bPutHDoc h ctx (HDoc f) = f ctx h + +-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', +-- as well as access to the shared 'SDocContext'. +-- +-- See Note [The outputable class hierarchy] for more details. +class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + +-- | A class of types that represent a single logical line of text, with support +-- for horizontal composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class IsOutput doc => IsLine doc where + char :: Char -> doc + text :: String -> doc + ftext :: FastString -> doc + ztext :: FastZString -> doc + + -- | Join two @doc@s together horizontally without a gap. + (<>) :: doc -> doc -> doc + -- | Join two @doc@s together horizontally with a gap between them. + (<+>) :: doc -> doc -> doc + -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits. + sep :: [doc] -> doc + -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting + -- things on one line until it can't fit any more. + fsep :: [doc] -> doc + + -- | Concatenate @doc@s horizontally without gaps. + hcat :: [doc] -> doc + hcat docs = foldr (<>) empty docs + {-# INLINE CONLIKE hcat #-} + + -- | Concatenate @doc@s horizontally with a space between each one. + hsep :: [doc] -> doc + hsep docs = foldr (<+>) empty docs + {-# INLINE CONLIKE hsep #-} + + -- | Prints as either the given 'SDoc' or the given 'HLine', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualLine :: SDoc -> HLine -> doc + + +-- | A class of types that represent a multiline document, with support for +-- vertical composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + + -- | Join two @doc@s together vertically. If there is no vertical overlap it + -- "dovetails" the two onto one line. + ($$) :: doc -> doc -> doc + + lines_ :: [Line doc] -> doc + lines_ = vcat . map line + {-# INLINE CONLIKE lines_ #-} + + -- | Concatenate @doc@s vertically with dovetailing. + vcat :: [doc] -> doc + vcat ls = foldr ($$) empty ls + {-# INLINE CONLIKE vcat #-} + + -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualDoc :: SDoc -> HDoc -> doc + +instance IsOutput SDoc where + empty = docToSDoc $ Pretty.empty + {-# INLINE CONLIKE empty #-} + docWithContext = sdocWithContext + {-# INLINE docWithContext #-} + +instance IsLine SDoc where + char c = docToSDoc $ Pretty.char c + {-# INLINE CONLIKE char #-} + text s = docToSDoc $ Pretty.text s + {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s + {-# INLINE CONLIKE ftext #-} + ztext s = docToSDoc $ Pretty.ztext s + {-# INLINE CONLIKE ztext #-} + (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<>) #-} + (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<+>) #-} + hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hcat #-} + hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hsep #-} + sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE sep #-} + fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE fsep #-} + dualLine s _ = s + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc SDoc where + type Line SDoc = SDoc + line = id + {-# INLINE line #-} + lines_ = vcat + {-# INLINE lines_ #-} + + ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE ($$) #-} + vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE vcat #-} + dualDoc s _ = s + {-# INLINE CONLIKE dualDoc #-} + +instance IsOutput HLine where + empty = HLine (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsOutput HDoc where + empty = HDoc (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsLine HLine where + char c = HLine (\_ h -> bPutChar h c) + {-# INLINE CONLIKE char #-} + text str = HLine (\_ h -> bPutStr h str) + {-# INLINE CONLIKE text #-} + ftext fstr = HLine (\_ h -> bPutFS h fstr) + {-# INLINE CONLIKE ftext #-} + ztext fstr = HLine (\_ h -> bPutFZS h fstr) + {-# INLINE CONLIKE ztext #-} + + HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE (<>) #-} + f <+> g = f <> char ' ' <> g + {-# INLINE CONLIKE (<+>) #-} + sep = hsep + {-# INLINE sep #-} + fsep = hsep + {-# INLINE fsep #-} + + dualLine _ h = h + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc HDoc where + type Line HDoc = HLine + line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n') + {-# INLINE CONLIKE line #-} + HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE ($$) #-} + dualDoc _ h = h + {-# INLINE CONLIKE dualDoc #-} diff --git a/testsuite/tests/hiefile/should_run/TestUtils.hs b/testsuite/tests/hiefile/should_run/TestUtils.hs index ec5d75e73f..5ba0a3dc58 100644 --- a/testsuite/tests/hiefile/should_run/TestUtils.hs +++ b/testsuite/tests/hiefile/should_run/TestUtils.hs @@ -2,6 +2,7 @@ module TestUtils ( readTestHie , render , text + , SDoc , DynFlags , module GHC.Iface.Ext.Types , module GHC.Iface.Ext.Utils @@ -13,7 +14,8 @@ import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Types.Unique.Supply import GHC.Types.Name -import GHC.Utils.Outputable ( Outputable, renderWithContext, ppr, defaultUserStyle, text) +import GHC.Utils.Outputable ( Outputable, renderWithContext, ppr, defaultUserStyle, SDoc ) +import qualified GHC.Utils.Outputable as O import GHC.Iface.Ext.Binary import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils @@ -39,3 +41,6 @@ readTestHie fp = do render :: Outputable a => DynFlags -> a -> String render df = renderWithContext (initSDocContext df defaultUserStyle) . ppr + +text :: String -> SDoc +text = O.text -- SDoc-only version -- cgit v1.2.1