diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2022-10-13 19:47:27 -0500 |
---|---|---|
committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2022-11-11 19:18:39 +0100 |
commit | 3c37d30b07fc85fe09452f4ce250aec42cb1d2e4 (patch) | |
tree | a5e36e0e66d1c221ed2d018b5c5c7fd82943f38c | |
parent | d0c691b6110b11a43d5ea2685d17bc001d2298da (diff) | |
download | haskell-3c37d30b07fc85fe09452f4ce250aec42cb1d2e4.tar.gz |
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 <lexi.lambda@gmail.com>
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
36 files changed, 1219 insertions, 699 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 "<size" <+> 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 83555e9227..96f78b6789 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 (LexicalFastString s)) = text "init__" <> ftext s - ppr MLK_FinalizerArray = text "fini_arr" - ppr (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s - ppr MLK_IPEBuffer = text "ipe_buf" +pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc +pprModuleLabelKind MLK_InitializerArray = text "init_arr" +pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s +pprModuleLabelKind MLK_FinalizerArray = text "fini_arr" +pprModuleLabelKind (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext 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 @@ -1431,11 +1433,15 @@ data LabelStyle = CStyle -- ^ C label style (used by C and LLVM backends) | AsmStyle -- ^ Asm label style (used by NCG backend) -pprAsmLabel :: Platform -> CLabel -> SDoc +pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprCLabel :: Platform -> CLabel -> SDoc +pprCLabel :: IsLine doc => Platform -> CLabel -> doc pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance OutputableP Platform CLabel where {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] @@ -1444,19 +1450,19 @@ instance OutputableP Platform CLabel where PprDump{} -> pprCLabel platform lbl _ -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl) -pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc +pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc pprCLabelStyle !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 '_' @@ -1508,14 +1514,14 @@ pprCLabelStyle !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" @@ -1552,7 +1558,7 @@ pprCLabelStyle !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" @@ -1570,12 +1576,12 @@ pprCLabelStyle !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 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 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 @@ -1585,6 +1591,8 @@ pprCLabelStyle !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 pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [Internal proc labels] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1605,21 +1613,24 @@ pprCLabelStyle !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" @@ -1630,22 +1641,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 '_' @@ -1659,13 +1670,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 cca3ce684e..028e0a63fb 100644 --- a/compiler/GHC/Cmm/CLabel.hs-boot +++ b/compiler/GHC/Cmm/CLabel.hs-boot @@ -5,4 +5,4 @@ import GHC.Platform data CLabel -pprCLabel :: Platform -> CLabel -> SDoc +pprCLabel :: IsLine doc => Platform -> 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 37d77900ba..5de914fcc9 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -126,7 +126,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 @@ -146,6 +145,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 @@ -244,16 +244,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) @@ -286,8 +287,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) @@ -389,12 +391,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 @@ -417,11 +424,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 @@ -485,7 +492,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 @@ -542,7 +549,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" @@ -586,7 +593,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 @@ -738,7 +745,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 $$ @@ -746,7 +753,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 @@ -756,14 +763,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 @@ -771,7 +778,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 9997b8fb52..e34dcfeae9 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 55eb0246bf..94593508c3 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 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..d388d5b328 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,7 +548,7 @@ pprGotDeclaration config = case (arch,os) of -- Emit XCOFF TOC section (_, OSAIX) - -> vcat $ [ text ".toc" + -> lines_ [ text ".toc" , text ".tc ghc_toc_table[TC],.LCTOC1" , text ".csect ghc_toc_table[RW]" -- See Note [.LCTOC1 in PPC PIC code] @@ -558,16 +558,16 @@ pprGotDeclaration config = case (arch,os) of -- 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,13 +595,13 @@ 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 "\t.indirect_symbol" <+> ppr_lbl lbl, @@ -614,7 +614,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 +631,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 +641,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 +668,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 @@ -705,7 +706,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of | 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 abad5d0427..3b448041e3 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 e16006bcd2..051fc0b7dc 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 564822e3e3..6fe264572a 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 06fc3f6c7e..ccb3ce09ba 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -171,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 4e029902b8..4a8f55fdf0 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- @@ -11,11 +12,7 @@ module GHC.CmmToAsm.X86.Ppr ( pprNatCmmDecl, - pprData, pprInstr, - pprFormat, - pprImm, - pprDataItem, ) where @@ -39,6 +36,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.DebugBlock (pprUnwindTable) import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) @@ -65,12 +63,12 @@ import Data.Word -- .subsections_via_symbols and -dead_strip can be found at -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101> -pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) where platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas config dats @@ -85,7 +83,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprProcLabel config lbl $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> @@ -93,48 +91,51 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprProcAlignment config $$ pprProcLabel config lbl $$ (if platformHasSubsectionsViaSymbols platform - then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon) else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] - text "\t.long " + line + $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Output an internal proc label. See Note [Internal proc labels] in CLabel. -pprProcLabel :: NCGConfig -> CLabel -> SDoc +pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc pprProcLabel config lbl | ncgExposeInternalSymbols config , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl - = lbl' <> colon + = line (lbl' <> colon) | otherwise = empty -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name - -> SDoc +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon -pprBlockEndLabel :: Platform -> CLabel -- ^ Block name - -> SDoc +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc pprBlockEndLabel platform lbl = pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ @@ -142,8 +143,8 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) ppWhen (ncgDwarfEnabled config) ( -- Emit both end labels since this may end up being a standalone -- top-level block - pprBlockEndLabel platform asmLbl - <> pprProcEndLabel platform asmLbl + line (pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl) ) where asmLbl = blockLbl blockid @@ -156,7 +157,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$ - ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon) + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon)) -- Make sure the info table has the right .loc for the block -- coming right after it. See Note [Info Offset] @@ -165,7 +166,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) _other -> empty -pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc +pprDatas :: IsDoc doc => NCGConfig -> (Alignment, RawCmmStatics) -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel @@ -175,31 +176,32 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl (ncgPlatform config) alias - $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind' + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) where platform = ncgPlatform config -pprData :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprString str -pprData _config (CmmFileEmbed path _) = pprFileEmbed path +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) pprData config (CmmUninitialised bytes) - = let platform = ncgPlatform config + = line + $ let platform = ncgPlatform config in if platformOS platform == OSDarwin then text ".space " <> int bytes else text ".skip " <> int bytes pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> pprAsmLabel platform lbl + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" @@ -257,21 +259,21 @@ pprLabelType' platform lbl = isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) -pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pprAsmLabel platform lbl <> colon) + $$ line (pprAsmLabel platform lbl <> colon) -pprAlign :: Platform -> Alignment -> SDoc +pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign platform alignment - = text ".align " <> int (alignmentOn platform) + = line $ text ".align " <> int (alignmentOn platform) where bytes = alignmentBytes alignment alignmentOn platform = if platformOS platform == OSDarwin @@ -285,7 +287,7 @@ pprAlign platform alignment log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -pprReg :: Platform -> Format -> Reg -> SDoc +pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc pprReg platform f r = case r of RegReal (RealRegSingle i) -> @@ -297,7 +299,7 @@ pprReg platform f r RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where - ppr32_reg_no :: Format -> Int -> SDoc + ppr32_reg_no :: Format -> Int -> doc ppr32_reg_no II8 = ppr32_reg_byte ppr32_reg_no II16 = ppr32_reg_word ppr32_reg_no _ = ppr32_reg_long @@ -327,7 +329,7 @@ pprReg platform f r _ -> ppr_reg_float i } - ppr64_reg_no :: Format -> Int -> SDoc + ppr64_reg_no :: Format -> Int -> doc ppr64_reg_no II8 = ppr64_reg_byte ppr64_reg_no II16 = ppr64_reg_word ppr64_reg_no II32 = ppr64_reg_long @@ -385,7 +387,7 @@ pprReg platform f r _ -> ppr_reg_float i } -ppr_reg_float :: Int -> SDoc +ppr_reg_float :: IsLine doc => Int -> doc ppr_reg_float i = case i of 16 -> text "%xmm0" ; 17 -> text "%xmm1" 18 -> text "%xmm2" ; 19 -> text "%xmm3" @@ -397,7 +399,7 @@ ppr_reg_float i = case i of 30 -> text "%xmm14"; 31 -> text "%xmm15" _ -> text "very naughty x86 register" -pprFormat :: Format -> SDoc +pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of II8 -> text "b" II16 -> text "w" @@ -406,14 +408,14 @@ pprFormat x = case x of FF32 -> text "ss" -- "scalar single-precision float" (SSE2) FF64 -> text "sd" -- "scalar double-precision float" (SSE2) -pprFormat_x87 :: Format -> SDoc +pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of FF32 -> text "s" FF64 -> text "l" _ -> panic "X86.Ppr.pprFormat_x87" -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of { GEU -> text "ae"; LU -> text "b"; EQQ -> text "e"; GTT -> text "g"; @@ -426,7 +428,7 @@ pprCond c = case c of { ALWAYS -> text "mp"} -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case ImmInt i -> int i ImmInteger i -> integer i @@ -440,7 +442,7 @@ pprImm platform = \case -pprAddr :: Platform -> AddrMode -> SDoc +pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform (ImmAddr imm off) = let pp_imm = pprImm platform imm in @@ -471,16 +473,16 @@ pprAddr platform (AddrBaseIndex base index displacement) ppr_disp imm = pprImm platform imm -- | Print section header and appropriate alignment for that section. -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "X86.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc -pprAlignForSection platform seg = +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ text ".align " <> case platformOS platform of -- Darwin: alignments are given as shifts. @@ -505,9 +507,9 @@ pprAlignForSection platform seg = CString -> int 1 _ -> int 8 -pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where platform = ncgPlatform config imm = litToImm lit @@ -535,26 +537,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" @@ -772,19 +774,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 @@ -803,19 +805,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 @@ -859,20 +861,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 @@ -881,10 +883,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 @@ -894,46 +896,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, @@ -942,24 +944,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, @@ -967,18 +969,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, @@ -986,18 +988,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, @@ -1007,18 +1009,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, @@ -1029,7 +1031,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, @@ -1037,9 +1039,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, @@ -1047,15 +1049,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 1b7e30dfec..7acf31ef0d 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -3299,6 +3299,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/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 cbfe4637a3..75b500694e 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 ftext (costCentreUserNameFS cc) + ppr = pprCostCentre + +pprCostCentre :: IsLine doc => CostCentre -> doc +pprCostCentre cc = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) + then ppCostCentreLbl cc + else ftext (costCentreUserNameFS 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 f366ddbf4a..949b750d38 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 8176bec011..1b70c4d910 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 <loc>" or diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index 38eefebc59..0faf042b4e 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 0e08f6860b..4fe2b932f6 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 @@ -163,19 +164,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) -- @@ -196,8 +202,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 = @@ -208,10 +214,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) = @@ -345,10 +352,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 @@ -524,8 +533,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 b7b0981117..79d2dbed60 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 d7300242bd..87bfd89909 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,7 @@ module GHC.Utils.Outputable ( ifPprDebug, whenPprDebug, getPprDebug, + bPutHDoc ) where import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) @@ -113,7 +116,7 @@ import GHC.Prelude.Basic 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 @@ -548,17 +551,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 @@ -625,43 +628,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 @@ -673,19 +659,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 '>' @@ -707,35 +693,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") @@ -758,38 +746,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 @@ -799,18 +764,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] @@ -828,16 +783,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 @@ -853,10 +809,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. -- @@ -1028,12 +983,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 @@ -1301,12 +1258,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] {- ************************************************************************ @@ -1485,3 +1444,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 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 |