diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-03-11 17:41:51 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-29 17:29:44 -0400 |
| commit | 1d03d8bef962e6789db44e8b6f2cfd9e34f3f5ad (patch) | |
| tree | d77ec6ba70bc70e87e954ecb2f56cfa39d12159e | |
| parent | c2541c49f162f1d03b0ae55f47b9c76cc96df76f (diff) | |
| download | haskell-1d03d8bef962e6789db44e8b6f2cfd9e34f3f5ad.tar.gz | |
Replace (ptext .. sLit) with `text`
1. `text` is as efficient as `ptext . sLit` thanks to the rewrite rules
2. `text` is visually nicer than `ptext . sLit`
3. `ptext . sLit` encourages using one `ptext` for several `sLit` as in:
ptext $ case xy of
... -> sLit ...
... -> sLit ...
which may allocate SDoc's TextBeside constructors at runtime instead
of sharing them into CAFs.
55 files changed, 789 insertions, 818 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 4d6c66066c..02d3f60ad6 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -1334,7 +1334,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] tempLabelPrefixOrUnderscore :: Platform -> SDoc tempLabelPrefixOrUnderscore platform = case sty of - AsmStyle -> ptext (asmTempLabelPrefix platform) + AsmStyle -> asmTempLabelPrefix platform CStyle -> char '_' @@ -1347,7 +1347,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u AsmTempDerivedLabel l suf - -> ptext (asmTempLabelPrefix platform) + -> asmTempLabelPrefix platform <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u _other -> pprCLabel platform sty l @@ -1370,7 +1370,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp" StringLitLabel u - -> maybe_underscore $ pprUniqueAlways u <> ptext (sLit "_str") + -> maybe_underscore $ pprUniqueAlways u <> text "_str" ForeignLabel fs (Just sz) _ _ | AsmStyle <- sty @@ -1389,7 +1389,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] isRandomGenerated = not (isExternalName name) internalNamePrefix = if isRandomGenerated - then ptext (asmTempLabelPrefix platform) + then asmTempLabelPrefix platform else empty CStyle -> ppr name <> ppIdFlavor flavor @@ -1400,38 +1400,38 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -> maybe_underscore $ ftext str <> text "_fast" RtsLabel (RtsSelectorInfoTable upd_reqd offset) - -> maybe_underscore $ hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) + -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + , if upd_reqd + then text "_upd_info" + else text "_noupd_info" ] RtsLabel (RtsSelectorEntry upd_reqd offset) - -> maybe_underscore $ hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) + -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + , if upd_reqd + then text "_upd_entry" + else text "_noupd_entry" ] RtsLabel (RtsApInfoTable upd_reqd arity) - -> maybe_underscore $ hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) + -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + , if upd_reqd + then text "_upd_info" + else text "_noupd_info" ] RtsLabel (RtsApEntry upd_reqd arity) - -> maybe_underscore $ hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) + -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + , if upd_reqd + then text "_upd_entry" + else text "_noupd_entry" ] RtsLabel (RtsPrimOp primop) -> maybe_underscore $ text "stg_" <> ppr primop RtsLabel (RtsSlowFastTickyCtr pat) - -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") + -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr" LargeBitmapLabel u -> maybe_underscore $ tempLabelPrefixOrUnderscore platform @@ -1441,7 +1441,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -- with a letter so the label will be legal assembly code. HpcTicksLabel mod - -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc") + -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc" CC_Label cc -> maybe_underscore $ ppr cc CCS_Label ccs -> maybe_underscore $ ppr ccs @@ -1528,11 +1528,11 @@ instance Outputable ForeignLabelSource where -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels +asmTempLabelPrefix :: Platform -> SDoc -- for formatting labels asmTempLabelPrefix !platform = case platformOS platform of - OSDarwin -> sLit "L" - OSAIX -> sLit "__L" -- follow IBM XL C's convention - _ -> sLit ".L" + OSDarwin -> text "L" + OSAIX -> text "__L" -- follow IBM XL C's convention + _ -> text ".L" pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index 469ae66dbc..b6a2e1992e 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -51,7 +51,6 @@ import GHC.Cmm.Ppr.Expr import GHC.Cmm import GHC.Utils.Outputable -import GHC.Data.FastString import Data.List (intersperse) @@ -160,15 +159,12 @@ pprSection platform (Section t suffix) = section = text "section" pprSectionType :: SectionType -> SDoc -pprSectionType s = doubleQuotes (ptext t) - where - t = case s of - Text -> sLit "text" - Data -> sLit "data" - ReadOnlyData -> sLit "readonly" - ReadOnlyData16 -> sLit "readonly16" - RelocatableReadOnlyData - -> sLit "relreadonly" - UninitialisedData -> sLit "uninitialised" - CString -> sLit "cstring" - OtherSection s' -> sLit s' -- Not actually a literal though. +pprSectionType s = doubleQuotes $ case s of + Text -> text "text" + Data -> text "data" + ReadOnlyData -> text "readonly" + ReadOnlyData16 -> text "readonly16" + RelocatableReadOnlyData -> text "relreadonly" + UninitialisedData -> text "uninitialised" + CString -> text "cstring" + OtherSection s' -> text s' diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index 954fc5fe80..c7e2a4069b 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -33,7 +33,6 @@ where import GHC.Prelude import GHC.Platform -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -172,18 +171,18 @@ isFloat64 _other = False -- Width ----------------------------------------------------------------------------- -data Width = W8 | W16 | W32 | W64 - | W128 - | W256 - | W512 - deriving (Eq, Ord, Show) +data Width + = W8 + | W16 + | W32 + | W64 + | W128 + | W256 + | W512 + deriving (Eq, Ord, Show) instance Outputable Width where - ppr rep = ptext (mrStr rep) - -mrStr :: Width -> PtrString -mrStr = sLit . show - + ppr rep = text (show rep) -------- Common Widths ------------ wordWidth :: Platform -> Width diff --git a/compiler/GHC/CmmToAsm/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs index 4de946686d..fa05bd0e59 100644 --- a/compiler/GHC/CmmToAsm/CPrim.hs +++ b/compiler/GHC/CmmToAsm/CPrim.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | Generating C symbol names emitted by the compiler. module GHC.CmmToAsm.CPrim ( atomicReadLabel @@ -15,130 +17,144 @@ module GHC.CmmToAsm.CPrim , word2FloatLabel ) where -import GHC.Prelude - import GHC.Cmm.Type import GHC.Cmm.MachOp +import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -popCntLabel :: Width -> String -popCntLabel w = "hs_popcnt" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) - -pdepLabel :: Width -> String -pdepLabel w = "hs_pdep" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "pdepLabel: Unsupported word width " (ppr w) - -pextLabel :: Width -> String -pextLabel w = "hs_pext" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "pextLabel: Unsupported word width " (ppr w) - -bSwapLabel :: Width -> String -bSwapLabel w = "hs_bswap" ++ pprWidth w - where - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) - -bRevLabel :: Width -> String -bRevLabel w = "hs_bitrev" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "bRevLabel: Unsupported word width " (ppr w) - -clzLabel :: Width -> String -clzLabel w = "hs_clz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) - -ctzLabel :: Width -> String -ctzLabel w = "hs_ctz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) - -word2FloatLabel :: Width -> String -word2FloatLabel w = "hs_word2float" ++ pprWidth w - where - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) - -atomicRMWLabel :: Width -> AtomicMachOp -> String -atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) - - pprFunName AMO_Add = "add" - pprFunName AMO_Sub = "sub" - pprFunName AMO_And = "and" - pprFunName AMO_Nand = "nand" - pprFunName AMO_Or = "or" - pprFunName AMO_Xor = "xor" - -xchgLabel :: Width -> String -xchgLabel w = "hs_xchg" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w) - -cmpxchgLabel :: Width -> String -cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) - -atomicReadLabel :: Width -> String -atomicReadLabel w = "hs_atomicread" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) - -atomicWriteLabel :: Width -> String -atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) +popCntLabel :: Width -> FastString +popCntLabel = \case + W8 -> fsLit "hs_popcnt8" + W16 -> fsLit "hs_popcnt16" + W32 -> fsLit "hs_popcnt32" + W64 -> fsLit "hs_popcnt64" + w -> pprPanic "popCntLabel: Unsupported word width " (ppr w) + +pdepLabel :: Width -> FastString +pdepLabel = \case + W8 -> fsLit "hs_pdep8" + W16 -> fsLit "hs_pdep16" + W32 -> fsLit "hs_pdep32" + W64 -> fsLit "hs_pdep64" + w -> pprPanic "pdepLabel: Unsupported word width " (ppr w) + +pextLabel :: Width -> FastString +pextLabel = \case + W8 -> fsLit "hs_pext8" + W16 -> fsLit "hs_pext16" + W32 -> fsLit "hs_pext32" + W64 -> fsLit "hs_pext64" + w -> pprPanic "pextLabel: Unsupported word width " (ppr w) + +bSwapLabel :: Width -> FastString +bSwapLabel = \case + W16 -> fsLit "hs_bswap16" + W32 -> fsLit "hs_bswap32" + W64 -> fsLit "hs_bswap64" + w -> pprPanic "bSwapLabel: Unsupported word width " (ppr w) + +bRevLabel :: Width -> FastString +bRevLabel = \case + W8 -> fsLit "hs_bitrev8" + W16 -> fsLit "hs_bitrev16" + W32 -> fsLit "hs_bitrev32" + W64 -> fsLit "hs_bitrev64" + w -> pprPanic "bRevLabel: Unsupported word width " (ppr w) + +clzLabel :: Width -> FastString +clzLabel = \case + W8 -> fsLit "hs_clz8" + W16 -> fsLit "hs_clz16" + W32 -> fsLit "hs_clz32" + W64 -> fsLit "hs_clz64" + w -> pprPanic "clzLabel: Unsupported word width " (ppr w) + +ctzLabel :: Width -> FastString +ctzLabel = \case + W8 -> fsLit "hs_ctz8" + W16 -> fsLit "hs_ctz16" + W32 -> fsLit "hs_ctz32" + W64 -> fsLit "hs_ctz64" + w -> pprPanic "ctzLabel: Unsupported word width " (ppr w) + +word2FloatLabel :: Width -> FastString +word2FloatLabel = \case + W32 -> fsLit "hs_word2float32" + W64 -> fsLit "hs_word2float64" + w -> pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> FastString +atomicRMWLabel w amop = case amop of + -- lots of boring cases, but we do it this way to get shared FastString + -- literals (compared to concatening strings and allocating FastStrings at + -- runtime) + AMO_Add -> case w of + W8 -> fsLit "hs_atomic_add8" + W16 -> fsLit "hs_atomic_add16" + W32 -> fsLit "hs_atomic_add32" + W64 -> fsLit "hs_atomic_add64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Sub -> case w of + W8 -> fsLit "hs_atomic_sub8" + W16 -> fsLit "hs_atomic_sub16" + W32 -> fsLit "hs_atomic_sub32" + W64 -> fsLit "hs_atomic_sub64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_And -> case w of + W8 -> fsLit "hs_atomic_and8" + W16 -> fsLit "hs_atomic_and16" + W32 -> fsLit "hs_atomic_and32" + W64 -> fsLit "hs_atomic_and64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Nand -> case w of + W8 -> fsLit "hs_atomic_nand8" + W16 -> fsLit "hs_atomic_nand16" + W32 -> fsLit "hs_atomic_nand32" + W64 -> fsLit "hs_atomic_nand64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Or -> case w of + W8 -> fsLit "hs_atomic_or8" + W16 -> fsLit "hs_atomic_or16" + W32 -> fsLit "hs_atomic_or32" + W64 -> fsLit "hs_atomic_or64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Xor -> case w of + W8 -> fsLit "hs_atomic_xor8" + W16 -> fsLit "hs_atomic_xor16" + W32 -> fsLit "hs_atomic_xor32" + W64 -> fsLit "hs_atomic_xor64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + +xchgLabel :: Width -> FastString +xchgLabel = \case + W8 -> fsLit "hs_xchg8" + W16 -> fsLit "hs_xchg16" + W32 -> fsLit "hs_xchg32" + W64 -> fsLit "hs_xchg64" + w -> pprPanic "xchgLabel: Unsupported word width " (ppr w) + +cmpxchgLabel :: Width -> FastString +cmpxchgLabel = \case + W8 -> fsLit "hs_cmpxchg8" + W16 -> fsLit "hs_cmpxchg16" + W32 -> fsLit "hs_cmpxchg32" + W64 -> fsLit "hs_cmpxchg64" + w -> pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> FastString +atomicReadLabel = \case + W8 -> fsLit "hs_atomicread8" + W16 -> fsLit "hs_atomicread16" + W32 -> fsLit "hs_atomicread32" + W64 -> fsLit "hs_atomicread64" + w -> pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> FastString +atomicWriteLabel = \case + W8 -> fsLit "hs_atomicwrite8" + W16 -> fsLit "hs_atomicwrite16" + W32 -> fsLit "hs_atomicwrite32" + W64 -> fsLit "hs_atomicwrite64" + w -> pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 9b48d25bf4..fcff4be74e 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -51,8 +51,8 @@ dwarfGen config modLoc us blocks = do , dwName = fromMaybe "" (ml_hs_file modLoc) , dwCompDir = addTrailingPathSeparator compPath , dwProducer = cProjectName ++ " " ++ cProjectVersion - , dwLowLabel = lowLabel - , dwHighLabel = highLabel + , dwLowLabel = pdoc platform lowLabel + , dwHighLabel = pdoc platform highLabel , dwLineLabel = dwarfLineLabel } @@ -69,7 +69,7 @@ dwarfGen config modLoc us blocks = do -- .debug_info section: Information records on procedures and blocks let -- unique to identify start and end compilation unit .debug_inf (unitU, us') = takeUniqFromSupply us - infoSct = vcat [ ptext dwarfInfoLabel <> colon + infoSct = vcat [ dwarfInfoLabel <> colon , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit @@ -79,12 +79,12 @@ dwarfGen config modLoc us blocks = do -- .debug_line section: Generated mainly by the assembler, but we -- need to label it let lineSct = dwarfLineSection platform $$ - ptext dwarfLineLabel <> colon + dwarfLineLabel <> colon -- .debug_frame section: Information about the layout of the GHC stack let (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$ - ptext dwarfFrameLabel <> colon $$ + dwarfFrameLabel <> colon $$ pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units @@ -114,7 +114,7 @@ compileUnitHeader platform unitU = in vcat [ pdoc platform cuLabel <> colon , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version - , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) + , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel -- abbrevs offset , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size ] diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs index ded0ea3237..e9047256e8 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -6,7 +6,6 @@ module GHC.CmmToAsm.Dwarf.Constants where import GHC.Prelude import GHC.Utils.Asm -import GHC.Data.FastString import GHC.Platform import GHC.Utils.Outputable @@ -165,11 +164,11 @@ dwarfSection platform name = -> text "\t.section .debug_" <> text name <> text ",\"dr\"" -- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString -dwarfInfoLabel = sLit ".Lsection_info" -dwarfAbbrevLabel = sLit ".Lsection_abbrev" -dwarfLineLabel = sLit ".Lsection_line" -dwarfFrameLabel = sLit ".Lsection_frame" +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc +dwarfInfoLabel = text ".Lsection_info" +dwarfAbbrevLabel = text ".Lsection_abbrev" +dwarfLineLabel = text ".Lsection_line" +dwarfFrameLabel = text ".Lsection_frame" -- | 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 43d902d106..b607d1d45e 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -59,9 +59,9 @@ data DwarfInfo , dwName :: String , dwProducer :: String , dwCompDir :: String - , dwLowLabel :: CLabel - , dwHighLabel :: CLabel - , dwLineLabel :: PtrString } + , dwLowLabel :: SDoc + , dwHighLabel :: SDoc + , dwLineLabel :: SDoc } | DwarfSubprogram { dwChildren :: [DwarfInfo] , dwName :: String , dwLabel :: CLabel @@ -111,7 +111,7 @@ pprAbbrevDecls platform haveDebugLine = , (dW_AT_frame_base, dW_FORM_block1) ] in dwarfAbbrevSection platform $$ - ptext dwarfAbbrevLabel <> colon $$ + dwarfAbbrevLabel <> colon $$ mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes ([(dW_AT_name, dW_FORM_string) , (dW_AT_producer, dW_FORM_string) @@ -178,10 +178,10 @@ pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowL $$ pprData4 dW_LANG_Haskell $$ pprString compDir -- Offset due to Note [Info Offset] - $$ pprWord platform (pdoc platform lowLabel <> text "-1") - $$ pprWord platform (pdoc platform highLabel) + $$ pprWord platform (lowLabel <> text "-1") + $$ pprWord platform highLabel $$ if haveSrc - then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) + then sectionOffset platform lineLbl dwarfLineLabel else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = pdoc platform (mkAsmTempDieLabel label) <> colon @@ -199,7 +199,7 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel) + pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode @@ -245,8 +245,7 @@ pprDwarfARanges platform arngs unitU = initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2 - $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) - (ptext dwarfInfoLabel) + $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel $$ pprByte (fromIntegral wordSize) $$ pprByte 0 $$ pad paddingSize @@ -364,8 +363,7 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel) , pdoc platform fdeLabel <> colon - , pprData4' (pdoc platform frameLbl <> char '-' <> - ptext dwarfFrameLabel) -- Reference to CIE + , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer , pprWord platform (pdoc platform procEnd <> char '-' <> pdoc platform procLbl <> ifInfo "+1") -- Block byte length diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index 42cb6c3cd3..7fe90c3ec6 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -570,7 +570,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of then vcat [ text ".symbol_stub", - text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"), + text "L" <> ppr_lbl lbl <> text "$stub:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tjmp *L" <> ppr_lbl lbl <> text "$lazy_ptr", @@ -584,7 +584,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of vcat [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25", - text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"), + text "L" <> ppr_lbl lbl <> text "$stub:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tcall ___i686.get_pc_thunk.ax", text "1:", @@ -601,7 +601,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if pic then int 2 else int 3) <> text ",lazy_symbol_pointers", - text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"), + text "L" <> ppr_lbl lbl <> text "$lazy_ptr:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\t.long L" <> ppr_lbl lbl <> text "$stub_binder"] @@ -679,14 +679,14 @@ pprImportedSymbol config importedLbl = case (arch,os) of -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> let symbolSize = case ncgWordWidth config of - W32 -> sLit "\t.long" - W64 -> sLit "\t.quad" + W32 -> text "\t.long" + W64 -> text "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" in vcat [ text ".section \".got2\", \"aw\"", text ".LC_" <> ppr_lbl lbl <> char ':', - ptext symbolSize <+> ppr_lbl lbl ] + symbolSize <+> ppr_lbl lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index f1a411ab27..953cb85ba9 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -2008,23 +2008,23 @@ genCCall' config gcp target dest_regs args MO_F64_Acosh -> (fsLit "acosh", False) MO_F64_Atanh -> (fsLit "atanh", False) - MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False) + MO_UF_Conv w -> (word2FloatLabel w, False) MO_Memcpy _ -> (fsLit "memcpy", False) MO_Memset _ -> (fsLit "memset", False) MO_Memmove _ -> (fsLit "memmove", False) MO_Memcmp _ -> (fsLit "memcmp", False) - MO_BSwap w -> (fsLit $ bSwapLabel w, False) - MO_BRev w -> (fsLit $ bRevLabel w, False) - MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_Pdep w -> (fsLit $ pdepLabel w, False) - MO_Pext w -> (fsLit $ pextLabel w, False) + MO_BSwap w -> (bSwapLabel w, False) + MO_BRev w -> (bRevLabel w, False) + MO_PopCnt w -> (popCntLabel w, False) + MO_Pdep w -> (pdepLabel w, False) + MO_Pext w -> (pextLabel w, False) MO_Clz _ -> unsupported MO_Ctz _ -> unsupported MO_AtomicRMW {} -> unsupported - MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) - MO_Xchg w -> (fsLit $ xchgLabel w, False) + MO_Cmpxchg w -> (cmpxchgLabel w, False) + MO_Xchg w -> (xchgLabel w, False) MO_AtomicRead _ -> unsupported MO_AtomicWrite _ -> unsupported diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 7ed13b298f..336e0d1804 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -217,24 +217,24 @@ pprReg r pprFormat :: Format -> SDoc pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd") + = case x of + II8 -> text "b" + II16 -> text "h" + II32 -> text "w" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" pprCond :: Cond -> SDoc pprCond c - = ptext (case c of { - ALWAYS -> sLit ""; - EQQ -> sLit "eq"; NE -> sLit "ne"; - LTT -> sLit "lt"; GE -> sLit "ge"; - GTT -> sLit "gt"; LE -> sLit "le"; - LU -> sLit "lt"; GEU -> sLit "ge"; - GU -> sLit "gt"; LEU -> sLit "le"; }) + = case c of { + ALWAYS -> text ""; + EQQ -> text "eq"; NE -> text "ne"; + LTT -> text "lt"; GE -> text "ge"; + GTT -> text "gt"; LE -> text "le"; + LU -> text "lt"; GEU -> text "ge"; + GU -> text "gt"; LEU -> text "le"; } pprImm :: Platform -> Imm -> SDoc @@ -284,26 +284,26 @@ pprSectionAlign config sec@(Section seg _) = pprAlignForSection :: Platform -> SectionType -> SDoc pprAlignForSection platform seg = let ppc64 = not $ target32Bit platform - in ptext $ case seg of - Text -> sLit ".align 2" + in case seg of + Text -> text ".align 2" Data - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" ReadOnlyData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" RelocatableReadOnlyData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" UninitialisedData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - ReadOnlyData16 -> sLit ".align 4" + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + ReadOnlyData16 -> text ".align 4" -- TODO: This is copied from the ReadOnlyData case, but it can likely be -- made more efficient. CString - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" pprDataItem :: Platform -> CmmLit -> SDoc @@ -380,13 +380,13 @@ pprInstr platform instr = case instr of -> hcat [ char '\t', text "l", - ptext (case fmt of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" + (case fmt of + II8 -> text "bz" + II16 -> text "hz" + II32 -> text "wz" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', @@ -422,13 +422,13 @@ pprInstr platform instr = case instr of -> hcat [ char '\t', text "l", - ptext (case fmt of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" + (case fmt of + II8 -> text "ba" + II16 -> text "ha" + II32 -> text "wa" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', @@ -643,7 +643,7 @@ pprInstr platform instr = case instr of ] ADD reg1 reg2 ri - -> pprLogic platform (sLit "add") reg1 reg2 ri + -> pprLogic platform (text "add") reg1 reg2 ri ADDIS reg1 reg2 imm -> hcat [ @@ -658,22 +658,22 @@ pprInstr platform instr = case instr of ] ADDO reg1 reg2 reg3 - -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3) ADDC reg1 reg2 reg3 - -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3) ADDE reg1 reg2 reg3 - -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3) ADDZE reg1 reg2 - -> pprUnary (sLit "addze") reg1 reg2 + -> pprUnary (text "addze") reg1 reg2 SUBF reg1 reg2 reg3 - -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3) SUBFO reg1 reg2 reg3 - -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri -> hcat [ @@ -691,7 +691,7 @@ pprInstr platform instr = case instr of ] SUBFE reg1 reg2 reg3 - -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3) MULL fmt reg1 reg2 ri -> pprMul platform fmt reg1 reg2 ri @@ -773,19 +773,19 @@ pprInstr platform instr = case instr of ] AND reg1 reg2 ri - -> pprLogic platform (sLit "and") reg1 reg2 ri + -> pprLogic platform (text "and") reg1 reg2 ri ANDC reg1 reg2 reg3 - -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3) NAND reg1 reg2 reg3 - -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3) + -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3) OR reg1 reg2 ri - -> pprLogic platform (sLit "or") reg1 reg2 ri + -> pprLogic platform (text "or") reg1 reg2 ri XOR reg1 reg2 ri - -> pprLogic platform (sLit "xor") reg1 reg2 ri + -> pprLogic platform (text "xor") reg1 reg2 ri ORIS reg1 reg2 imm -> hcat [ @@ -837,10 +837,10 @@ pprInstr platform instr = case instr of ] NEG reg1 reg2 - -> pprUnary (sLit "neg") reg1 reg2 + -> pprUnary (text "neg") reg1 reg2 NOT reg1 reg2 - -> pprUnary (sLit "not") reg1 reg2 + -> pprUnary (text "not") reg1 reg2 SR II32 reg1 reg2 (RIImm (ImmInt i)) -- Handle the case where we are asked to shift a 32 bit register by @@ -864,24 +864,24 @@ pprInstr platform instr = case instr of SL fmt reg1 reg2 ri -> let op = case fmt of - II32 -> "slw" - II64 -> "sld" + II32 -> text "slw" + II64 -> text "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) SR fmt reg1 reg2 ri -> let op = case fmt of - II32 -> "srw" - II64 -> "srd" + II32 -> text "srw" + II64 -> text "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) SRA fmt reg1 reg2 ri -> let op = case fmt of - II32 -> "sraw" - II64 -> "srad" + II32 -> text "sraw" + II64 -> text "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me -> hcat [ @@ -922,22 +922,22 @@ pprInstr platform instr = case instr of ] FADD fmt reg1 reg2 reg3 - -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 + -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3 FSUB fmt reg1 reg2 reg3 - -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 + -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3 FMUL fmt reg1 reg2 reg3 - -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 + -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3 FDIV fmt reg1 reg2 reg3 - -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 + -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3 FABS reg1 reg2 - -> pprUnary (sLit "fabs") reg1 reg2 + -> pprUnary (text "fabs") reg1 reg2 FNEG reg1 reg2 - -> pprUnary (sLit "fneg") reg1 reg2 + -> pprUnary (text "fneg") reg1 reg2 FCMP reg1 reg2 -> hcat [ @@ -956,16 +956,16 @@ pprInstr platform instr = case instr of ] FCTIWZ reg1 reg2 - -> pprUnary (sLit "fctiwz") reg1 reg2 + -> pprUnary (text "fctiwz") reg1 reg2 FCTIDZ reg1 reg2 - -> pprUnary (sLit "fctidz") reg1 reg2 + -> pprUnary (text "fctidz") reg1 reg2 FCFID reg1 reg2 - -> pprUnary (sLit "fcfid") reg1 reg2 + -> pprUnary (text "fcfid") reg1 reg2 FRSP reg1 reg2 - -> pprUnary (sLit "frsp") reg1 reg2 + -> pprUnary (text "frsp") reg1 reg2 CRNOR dst src1 src2 -> hcat [ @@ -1011,10 +1011,10 @@ pprInstr platform instr = case instr of NOP -> text "\tnop" -pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc +pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc pprLogic platform op reg1 reg2 ri = hcat [ char '\t', - ptext op, + op, case ri of RIReg _ -> empty RIImm _ -> char 'i', @@ -1064,10 +1064,10 @@ pprDiv fmt sgn reg1 reg2 reg3 = hcat [ ] -pprUnary :: PtrString -> Reg -> Reg -> SDoc +pprUnary :: SDoc -> Reg -> Reg -> SDoc pprUnary op reg1 reg2 = hcat [ char '\t', - ptext op, + op, char '\t', pprReg reg1, text ", ", @@ -1075,10 +1075,10 @@ pprUnary op reg1 reg2 = hcat [ ] -pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc +pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprBinaryF op fmt reg1 reg2 reg3 = hcat [ char '\t', - ptext op, + op, pprFFormat fmt, char '\t', pprReg reg1, diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index a2382705ae..e4e9d7708e 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -24,7 +24,6 @@ import GHC.Utils.Asm import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config -import GHC.Data.FastString import GHC.Utils.Outputable as SDoc import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic @@ -243,26 +242,23 @@ pprGNUSectionHeader config t suffix = -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections pprXcoffSectionHeader :: SectionType -> SDoc -pprXcoffSectionHeader t = text $ case t of - Text -> ".csect .text[PR]" - Data -> ".csect .data[RW]" - ReadOnlyData -> ".csect .text[PR] # ReadOnlyData" - RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData" - ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16" - CString -> ".csect .text[PR] # CString" - UninitialisedData -> ".csect .data[BS]" - OtherSection _ -> - panic "PprBase.pprXcoffSectionHeader: unknown section type" +pprXcoffSectionHeader t = case t of + Text -> text ".csect .text[PR]" + Data -> text ".csect .data[RW]" + ReadOnlyData -> text ".csect .text[PR] # ReadOnlyData" + RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData" + ReadOnlyData16 -> text ".csect .text[PR] # ReadOnlyData16" + CString -> text ".csect .text[PR] # CString" + UninitialisedData -> text ".csect .data[BS]" + OtherSection _ -> panic "pprXcoffSectionHeader: unknown section type" pprDarwinSectionHeader :: SectionType -> SDoc -pprDarwinSectionHeader t = - ptext $ case t of - Text -> sLit ".text" - Data -> sLit ".data" - ReadOnlyData -> sLit ".const" - RelocatableReadOnlyData -> sLit ".const_data" - UninitialisedData -> sLit ".data" - ReadOnlyData16 -> sLit ".const" - CString -> sLit ".section\t__TEXT,__cstring,cstring_literals" - OtherSection _ -> - panic "PprBase.pprDarwinSectionHeader: unknown section type" +pprDarwinSectionHeader t = case t of + Text -> text ".text" + Data -> text ".data" + ReadOnlyData -> text ".const" + RelocatableReadOnlyData -> text ".const_data" + UninitialisedData -> text ".data" + ReadOnlyData16 -> text ".const" + CString -> text ".section\t__TEXT,__cstring,cstring_literals" + OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type" diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index c06d4178ad..21313aa0bd 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -660,25 +660,25 @@ outOfLineMachOp_table mop MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" - MO_UF_Conv w -> fsLit $ word2FloatLabel w + MO_UF_Conv w -> word2FloatLabel w MO_Memcpy _ -> fsLit "memcpy" MO_Memset _ -> fsLit "memset" MO_Memmove _ -> fsLit "memmove" MO_Memcmp _ -> fsLit "memcmp" - MO_BSwap w -> fsLit $ bSwapLabel w - MO_BRev w -> fsLit $ bRevLabel w - MO_PopCnt w -> fsLit $ popCntLabel w - MO_Pdep w -> fsLit $ pdepLabel w - MO_Pext w -> fsLit $ pextLabel w - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz w -> fsLit $ ctzLabel w - MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop - MO_Cmpxchg w -> fsLit $ cmpxchgLabel w - MO_Xchg w -> fsLit $ xchgLabel w - MO_AtomicRead w -> fsLit $ atomicReadLabel w - MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + MO_BSwap w -> bSwapLabel w + MO_BRev w -> bRevLabel w + MO_PopCnt w -> popCntLabel w + MO_Pdep w -> pdepLabel w + MO_Pext w -> pextLabel w + MO_Clz w -> clzLabel w + MO_Ctz w -> ctzLabel w + MO_AtomicRMW w amop -> atomicRMWLabel w amop + MO_Cmpxchg w -> cmpxchgLabel w + MO_Xchg w -> xchgLabel w + MO_AtomicRead w -> atomicReadLabel w + MO_AtomicWrite w -> atomicWriteLabel w MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 20b3beea35..a45d05d6c6 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -141,7 +141,7 @@ pprGloblDecl platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object") + then text ".type " <> pdoc platform lbl <> text ", @object" else empty pprLabel :: Platform -> CLabel -> SDoc @@ -188,92 +188,88 @@ pprReg reg -- pprReg_ofRegNo :: Int -> SDoc pprReg_ofRegNo i - = ptext - (case i of { - 0 -> sLit "%g0"; 1 -> sLit "%g1"; - 2 -> sLit "%g2"; 3 -> sLit "%g3"; - 4 -> sLit "%g4"; 5 -> sLit "%g5"; - 6 -> sLit "%g6"; 7 -> sLit "%g7"; - 8 -> sLit "%o0"; 9 -> sLit "%o1"; - 10 -> sLit "%o2"; 11 -> sLit "%o3"; - 12 -> sLit "%o4"; 13 -> sLit "%o5"; - 14 -> sLit "%o6"; 15 -> sLit "%o7"; - 16 -> sLit "%l0"; 17 -> sLit "%l1"; - 18 -> sLit "%l2"; 19 -> sLit "%l3"; - 20 -> sLit "%l4"; 21 -> sLit "%l5"; - 22 -> sLit "%l6"; 23 -> sLit "%l7"; - 24 -> sLit "%i0"; 25 -> sLit "%i1"; - 26 -> sLit "%i2"; 27 -> sLit "%i3"; - 28 -> sLit "%i4"; 29 -> sLit "%i5"; - 30 -> sLit "%i6"; 31 -> sLit "%i7"; - 32 -> sLit "%f0"; 33 -> sLit "%f1"; - 34 -> sLit "%f2"; 35 -> sLit "%f3"; - 36 -> sLit "%f4"; 37 -> sLit "%f5"; - 38 -> sLit "%f6"; 39 -> sLit "%f7"; - 40 -> sLit "%f8"; 41 -> sLit "%f9"; - 42 -> sLit "%f10"; 43 -> sLit "%f11"; - 44 -> sLit "%f12"; 45 -> sLit "%f13"; - 46 -> sLit "%f14"; 47 -> sLit "%f15"; - 48 -> sLit "%f16"; 49 -> sLit "%f17"; - 50 -> sLit "%f18"; 51 -> sLit "%f19"; - 52 -> sLit "%f20"; 53 -> sLit "%f21"; - 54 -> sLit "%f22"; 55 -> sLit "%f23"; - 56 -> sLit "%f24"; 57 -> sLit "%f25"; - 58 -> sLit "%f26"; 59 -> sLit "%f27"; - 60 -> sLit "%f28"; 61 -> sLit "%f29"; - 62 -> sLit "%f30"; 63 -> sLit "%f31"; - _ -> sLit "very naughty sparc register" }) + = case i of { + 0 -> text "%g0"; 1 -> text "%g1"; + 2 -> text "%g2"; 3 -> text "%g3"; + 4 -> text "%g4"; 5 -> text "%g5"; + 6 -> text "%g6"; 7 -> text "%g7"; + 8 -> text "%o0"; 9 -> text "%o1"; + 10 -> text "%o2"; 11 -> text "%o3"; + 12 -> text "%o4"; 13 -> text "%o5"; + 14 -> text "%o6"; 15 -> text "%o7"; + 16 -> text "%l0"; 17 -> text "%l1"; + 18 -> text "%l2"; 19 -> text "%l3"; + 20 -> text "%l4"; 21 -> text "%l5"; + 22 -> text "%l6"; 23 -> text "%l7"; + 24 -> text "%i0"; 25 -> text "%i1"; + 26 -> text "%i2"; 27 -> text "%i3"; + 28 -> text "%i4"; 29 -> text "%i5"; + 30 -> text "%i6"; 31 -> text "%i7"; + 32 -> text "%f0"; 33 -> text "%f1"; + 34 -> text "%f2"; 35 -> text "%f3"; + 36 -> text "%f4"; 37 -> text "%f5"; + 38 -> text "%f6"; 39 -> text "%f7"; + 40 -> text "%f8"; 41 -> text "%f9"; + 42 -> text "%f10"; 43 -> text "%f11"; + 44 -> text "%f12"; 45 -> text "%f13"; + 46 -> text "%f14"; 47 -> text "%f15"; + 48 -> text "%f16"; 49 -> text "%f17"; + 50 -> text "%f18"; 51 -> text "%f19"; + 52 -> text "%f20"; 53 -> text "%f21"; + 54 -> text "%f22"; 55 -> text "%f23"; + 56 -> text "%f24"; 57 -> text "%f25"; + 58 -> text "%f26"; 59 -> text "%f27"; + 60 -> text "%f28"; 61 -> text "%f29"; + 62 -> text "%f30"; 63 -> text "%f31"; + _ -> text "very naughty sparc register" } -- | Pretty print a format for an instruction suffix. pprFormat :: Format -> SDoc pprFormat x - = ptext - (case x of - II8 -> sLit "ub" - II16 -> sLit "uh" - II32 -> sLit "" - II64 -> sLit "d" - FF32 -> sLit "" - FF64 -> sLit "d") + = case x of + II8 -> text "ub" + II16 -> text "uh" + II32 -> text "" + II64 -> text "d" + FF32 -> text "" + FF64 -> text "d" -- | Pretty print a format for an instruction suffix. -- eg LD is 32bit on sparc, but LDD is 64 bit. pprStFormat :: Format -> SDoc pprStFormat x - = ptext - (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "" - II64 -> sLit "x" - FF32 -> sLit "" - FF64 -> sLit "d") + = case x of + II8 -> text "b" + II16 -> text "h" + II32 -> text "" + II64 -> text "x" + FF32 -> text "" + FF64 -> text "d" -- | Pretty print a condition code. pprCond :: Cond -> SDoc pprCond c - = ptext - (case c of - ALWAYS -> sLit "" - NEVER -> sLit "n" - GEU -> sLit "geu" - LU -> sLit "lu" - EQQ -> sLit "e" - GTT -> sLit "g" - GE -> sLit "ge" - GU -> sLit "gu" - LTT -> sLit "l" - LE -> sLit "le" - LEU -> sLit "leu" - NE -> sLit "ne" - NEG -> sLit "neg" - POS -> sLit "pos" - VC -> sLit "vc" - VS -> sLit "vs") + = case c of + ALWAYS -> text "" + NEVER -> text "n" + GEU -> text "geu" + LU -> text "lu" + EQQ -> text "e" + GTT -> text "g" + GE -> text "ge" + GU -> text "gu" + LTT -> text "l" + LE -> text "le" + LEU -> text "leu" + NE -> text "ne" + NEG -> text "neg" + POS -> text "pos" + VC -> text "vc" + VS -> text "vs" -- | Pretty print an address mode. @@ -344,18 +340,17 @@ pprSectionAlign config sec@(Section seg _) = -- | Print appropriate alignment for the given section type. pprAlignForSection :: SectionType -> SDoc pprAlignForSection seg = - ptext (case seg of - Text -> sLit ".align 4" - Data -> sLit ".align 8" - ReadOnlyData -> sLit ".align 8" - RelocatableReadOnlyData - -> sLit ".align 8" - UninitialisedData -> sLit ".align 8" - ReadOnlyData16 -> sLit ".align 16" + case seg of + Text -> text ".align 4" + Data -> text ".align 8" + ReadOnlyData -> text ".align 8" + RelocatableReadOnlyData -> text ".align 8" + UninitialisedData -> text ".align 8" + ReadOnlyData16 -> text ".align 16" -- TODO: This is copied from the ReadOnlyData case, but it can likely be -- made more efficient. - CString -> sLit ".align 8" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section") + CString -> text ".align 8" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" -- | Pretty print a data item. pprDataItem :: Platform -> CmmLit -> SDoc @@ -447,7 +442,7 @@ pprInstr platform = \case -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise - -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 + -> pprRegRIReg platform (if x then text "addx" else text "add") cc reg1 ri reg2 SUB x cc reg1 ri reg2 @@ -458,11 +453,11 @@ pprInstr platform = \case -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise - -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 + -> pprRegRIReg platform (if x then text "subx" else text "sub") cc reg1 ri reg2 - AND b reg1 ri reg2 -> pprRegRIReg platform (sLit "and") b reg1 ri reg2 + AND b reg1 ri reg2 -> pprRegRIReg platform (text "and") b reg1 ri reg2 - ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2 + ANDN b reg1 ri reg2 -> pprRegRIReg platform (text "andn") b reg1 ri reg2 OR b reg1 ri reg2 | not b && reg1 == g0 @@ -472,16 +467,16 @@ pprInstr platform = \case _ -> doit | otherwise - -> pprRegRIReg platform (sLit "or") b reg1 ri reg2 + -> pprRegRIReg platform (text "or") b reg1 ri reg2 - ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2 + ORN b reg1 ri reg2 -> pprRegRIReg platform (text "orn") b reg1 ri reg2 - XOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor") b reg1 ri reg2 - XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2 + XOR b reg1 ri reg2 -> pprRegRIReg platform (text "xor") b reg1 ri reg2 + XNOR b reg1 ri reg2 -> pprRegRIReg platform (text "xnor") b reg1 ri reg2 - SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2 - SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2 - SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2 + SLL reg1 ri reg2 -> pprRegRIReg platform (text "sll") False reg1 ri reg2 + SRL reg1 ri reg2 -> pprRegRIReg platform (text "srl") False reg1 ri reg2 + SRA reg1 ri reg2 -> pprRegRIReg platform (text "sra") False reg1 ri reg2 RDY rd -> text "\trd\t%y," <> pprReg rd WRY reg1 reg2 @@ -492,10 +487,10 @@ pprInstr platform = \case <> char ',' <> text "%y" - SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul") b reg1 ri reg2 - UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul") b reg1 ri reg2 - SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2 - UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv") b reg1 ri reg2 + SMUL b reg1 ri reg2 -> pprRegRIReg platform (text "smul") b reg1 ri reg2 + UMUL b reg1 ri reg2 -> pprRegRIReg platform (text "umul") b reg1 ri reg2 + SDIV b reg1 ri reg2 -> pprRegRIReg platform (text "sdiv") b reg1 ri reg2 + UDIV b reg1 ri reg2 -> pprRegRIReg platform (text "udiv") b reg1 ri reg2 SETHI imm reg -> hcat [ @@ -508,48 +503,46 @@ pprInstr platform = \case NOP -> text "\tnop" FABS format reg1 reg2 - -> pprFormatRegReg (sLit "fabs") format reg1 reg2 + -> pprFormatRegReg (text "fabs") format reg1 reg2 FADD format reg1 reg2 reg3 - -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 + -> pprFormatRegRegReg (text "fadd") format reg1 reg2 reg3 FCMP e format reg1 reg2 - -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") + -> pprFormatRegReg (if e then text "fcmpe" else text "fcmp") format reg1 reg2 FDIV format reg1 reg2 reg3 - -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 + -> pprFormatRegRegReg (text "fdiv") format reg1 reg2 reg3 FMOV format reg1 reg2 - -> pprFormatRegReg (sLit "fmov") format reg1 reg2 + -> pprFormatRegReg (text "fmov") format reg1 reg2 FMUL format reg1 reg2 reg3 - -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 + -> pprFormatRegRegReg (text "fmul") format reg1 reg2 reg3 FNEG format reg1 reg2 - -> pprFormatRegReg (sLit "fneg") format reg1 reg2 + -> pprFormatRegReg (text "fneg") format reg1 reg2 FSQRT format reg1 reg2 - -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2 + -> pprFormatRegReg (text "fsqrt") format reg1 reg2 FSUB format reg1 reg2 reg3 - -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 + -> pprFormatRegRegReg (text "fsub") format reg1 reg2 reg3 FxTOy format1 format2 reg1 reg2 -> hcat [ text "\tf", - ptext (case format1 of - II32 -> sLit "ito" - FF32 -> sLit "sto" - FF64 -> sLit "dto" + II32 -> text "ito" + FF32 -> text "sto" + FF64 -> text "dto" _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - ptext (case format2 of - II32 -> sLit "i\t" - II64 -> sLit "x\t" - FF32 -> sLit "s\t" - FF64 -> sLit "d\t" + II32 -> text "i\t" + II64 -> text "x\t" + FF32 -> text "s\t" + FF64 -> text "d\t" _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), pprReg reg1, comma, pprReg reg2 ] @@ -589,11 +582,11 @@ pprRI platform = \case -- | Pretty print a two reg instruction. -pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc +pprFormatRegReg :: SDoc -> Format -> Reg -> Reg -> SDoc pprFormatRegReg name format reg1 reg2 = hcat [ char '\t', - ptext name, + name, (case format of FF32 -> text "s\t" FF64 -> text "d\t" @@ -606,11 +599,11 @@ pprFormatRegReg name format reg1 reg2 -- | Pretty print a three reg instruction. -pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc +pprFormatRegRegReg :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprFormatRegRegReg name format reg1 reg2 reg3 = hcat [ char '\t', - ptext name, + name, (case format of FF32 -> text "s\t" FF64 -> text "d\t" @@ -624,11 +617,11 @@ pprFormatRegRegReg name format reg1 reg2 reg3 -- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc +pprRegRIReg :: Platform -> SDoc -> Bool -> Reg -> RI -> Reg -> SDoc pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t', - ptext name, + name, if b then text "cc\t" else char '\t', pprReg reg1, comma, @@ -638,11 +631,11 @@ pprRegRIReg platform name b reg1 ri reg2 ] {- -pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc +pprRIReg :: SDoc -> Bool -> RI -> Reg -> SDoc pprRIReg name b ri reg1 = hcat [ char '\t', - ptext name, + name, if b then text "cc\t" else char '\t', pprRI ri, comma, diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 7b803b2708..97dcda5a5b 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2465,7 +2465,7 @@ genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall' config is32Bit target dest_regs args bid where format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) + lbl = mkCmmCodeLabel primUnitId (popCntLabel width) genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] args@[src, mask] bid = do @@ -2498,7 +2498,7 @@ genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] genCCall' config is32Bit target dest_regs args bid where format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) + lbl = mkCmmCodeLabel primUnitId (pdepLabel width) genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] args@[src, mask] bid = do @@ -2531,7 +2531,7 @@ genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] genCCall' config is32Bit target dest_regs args bid where format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) + lbl = mkCmmCodeLabel primUnitId (pextLabel width) genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid | is32Bit && width == W64 = do @@ -2576,7 +2576,7 @@ genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] -- took care of implicitly clearing the upper bits where bw = widthInBits width - lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) + lbl = mkCmmCodeLabel primUnitId (clzLabel width) genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do targetExpr <- cmmMakeDynamicReference config @@ -2586,7 +2586,7 @@ genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do CmmMayReturn) genCCall' config is32Bit target dest_regs args bid where - lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) + lbl = mkCmmCodeLabel primUnitId (word2FloatLabel width) genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do load_code <- intLoadCode (MOV (intFormat width)) addr @@ -3401,12 +3401,12 @@ outOfLineCmmOp bid mop res args {- Here the C implementation is used as there is no x86 instruction to reverse a word's bit order. -} - MO_BRev w -> fsLit $ bRevLabel w - MO_Clz w -> fsLit $ clzLabel w + MO_BRev w -> bRevLabel w + MO_Clz w -> clzLabel w MO_Ctz _ -> unsupported - MO_Pdep w -> fsLit $ pdepLabel w - MO_Pext w -> fsLit $ pextLabel w + MO_Pdep w -> pdepLabel w + MO_Pext w -> pextLabel w MO_AtomicRMW _ _ -> fsLit "atomicrmw" MO_AtomicRead _ -> fsLit "atomicread" diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 2d12e90443..a03a0bd82f 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -45,7 +45,6 @@ import GHC.Cmm.CLabel import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -100,7 +99,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprProcAlignment config $$ pprProcLabel config lbl $$ (if platformHasSubsectionsViaSymbols platform - then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' + then pdoc platform (mkDeadStripPreventer info_lbl) <> colon else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$ @@ -120,25 +119,25 @@ pprProcLabel :: NCGConfig -> CLabel -> SDoc pprProcLabel config lbl | ncgExposeInternalSymbols config , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl - = lbl' <> char ':' + = lbl' <> colon | otherwise = empty pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name -> SDoc pprProcEndLabel platform lbl = - pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':' + pdoc platform (mkAsmTempProcEndLabel lbl) <> colon pprBlockEndLabel :: Platform -> CLabel -- ^ Block name -> SDoc pprBlockEndLabel platform lbl = - pdoc platform (mkAsmTempEndLabel lbl) <> char ':' + pdoc platform (mkAsmTempEndLabel lbl) <> colon -- | Output the ELF .size directive. pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl + then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl else empty pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc @@ -163,7 +162,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$ - ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':') + ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon) -- Make sure the info table has the right .loc for the block -- coming right after it. See [Note: Info Offset] @@ -267,14 +266,14 @@ pprLabelType' platform lbl = pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl + then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pdoc platform lbl <> char ':') + $$ (pdoc platform lbl <> colon) pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment @@ -310,30 +309,30 @@ pprReg platform f r ppr32_reg_no II16 = ppr32_reg_word ppr32_reg_no _ = ppr32_reg_long - ppr32_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - _ -> sLit $ "very naughty I386 byte register: " ++ show i - }) - - ppr32_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - _ -> sLit "very naughty I386 word register" - }) - - ppr32_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + ppr32_reg_byte i = + case i of { + 0 -> text "%al"; 1 -> text "%bl"; + 2 -> text "%cl"; 3 -> text "%dl"; + _ -> text "very naughty I386 byte register: " <> int i + } + + ppr32_reg_word i = + case i of { + 0 -> text "%ax"; 1 -> text "%bx"; + 2 -> text "%cx"; 3 -> text "%dx"; + 4 -> text "%si"; 5 -> text "%di"; + 6 -> text "%bp"; 7 -> text "%sp"; + _ -> text "very naughty I386 word register" + } + + ppr32_reg_long i = + case i of { + 0 -> text "%eax"; 1 -> text "%ebx"; + 2 -> text "%ecx"; 3 -> text "%edx"; + 4 -> text "%esi"; 5 -> text "%edi"; + 6 -> text "%ebp"; 7 -> text "%esp"; _ -> ppr_reg_float i - }) + } ppr64_reg_no :: Format -> Int -> SDoc ppr64_reg_no II8 = ppr64_reg_byte @@ -341,101 +340,97 @@ pprReg platform f r ppr64_reg_no II32 = ppr64_reg_long ppr64_reg_no _ = ppr64_reg_quad - ppr64_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! - 6 -> sLit "%bpl"; 7 -> sLit "%spl"; - 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; - 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; - 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; - 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; - _ -> sLit $ "very naughty x86_64 byte register: " ++ show i - }) - - ppr64_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; - 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; - 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; - 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; - _ -> sLit "very naughty x86_64 word register" - }) - - ppr64_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; - 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; - 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; - 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; - _ -> sLit "very naughty x86_64 register" - }) - - ppr64_reg_quad i = ptext - (case i of { - 0 -> sLit "%rax"; 1 -> sLit "%rbx"; - 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; - 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; - 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; - 8 -> sLit "%r8"; 9 -> sLit "%r9"; - 10 -> sLit "%r10"; 11 -> sLit "%r11"; - 12 -> sLit "%r12"; 13 -> sLit "%r13"; - 14 -> sLit "%r14"; 15 -> sLit "%r15"; + ppr64_reg_byte i = + case i of { + 0 -> text "%al"; 1 -> text "%bl"; + 2 -> text "%cl"; 3 -> text "%dl"; + 4 -> text "%sil"; 5 -> text "%dil"; -- new 8-bit regs! + 6 -> text "%bpl"; 7 -> text "%spl"; + 8 -> text "%r8b"; 9 -> text "%r9b"; + 10 -> text "%r10b"; 11 -> text "%r11b"; + 12 -> text "%r12b"; 13 -> text "%r13b"; + 14 -> text "%r14b"; 15 -> text "%r15b"; + _ -> text "very naughty x86_64 byte register: " <> int i + } + + ppr64_reg_word i = + case i of { + 0 -> text "%ax"; 1 -> text "%bx"; + 2 -> text "%cx"; 3 -> text "%dx"; + 4 -> text "%si"; 5 -> text "%di"; + 6 -> text "%bp"; 7 -> text "%sp"; + 8 -> text "%r8w"; 9 -> text "%r9w"; + 10 -> text "%r10w"; 11 -> text "%r11w"; + 12 -> text "%r12w"; 13 -> text "%r13w"; + 14 -> text "%r14w"; 15 -> text "%r15w"; + _ -> text "very naughty x86_64 word register" + } + + ppr64_reg_long i = + case i of { + 0 -> text "%eax"; 1 -> text "%ebx"; + 2 -> text "%ecx"; 3 -> text "%edx"; + 4 -> text "%esi"; 5 -> text "%edi"; + 6 -> text "%ebp"; 7 -> text "%esp"; + 8 -> text "%r8d"; 9 -> text "%r9d"; + 10 -> text "%r10d"; 11 -> text "%r11d"; + 12 -> text "%r12d"; 13 -> text "%r13d"; + 14 -> text "%r14d"; 15 -> text "%r15d"; + _ -> text "very naughty x86_64 register" + } + + ppr64_reg_quad i = + case i of { + 0 -> text "%rax"; 1 -> text "%rbx"; + 2 -> text "%rcx"; 3 -> text "%rdx"; + 4 -> text "%rsi"; 5 -> text "%rdi"; + 6 -> text "%rbp"; 7 -> text "%rsp"; + 8 -> text "%r8"; 9 -> text "%r9"; + 10 -> text "%r10"; 11 -> text "%r11"; + 12 -> text "%r12"; 13 -> text "%r13"; + 14 -> text "%r14"; 15 -> text "%r15"; _ -> ppr_reg_float i - }) + } -ppr_reg_float :: Int -> PtrString +ppr_reg_float :: Int -> SDoc ppr_reg_float i = case i of - 16 -> sLit "%xmm0" ; 17 -> sLit "%xmm1" - 18 -> sLit "%xmm2" ; 19 -> sLit "%xmm3" - 20 -> sLit "%xmm4" ; 21 -> sLit "%xmm5" - 22 -> sLit "%xmm6" ; 23 -> sLit "%xmm7" - 24 -> sLit "%xmm8" ; 25 -> sLit "%xmm9" - 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11" - 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13" - 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15" - _ -> sLit "very naughty x86 register" + 16 -> text "%xmm0" ; 17 -> text "%xmm1" + 18 -> text "%xmm2" ; 19 -> text "%xmm3" + 20 -> text "%xmm4" ; 21 -> text "%xmm5" + 22 -> text "%xmm6" ; 23 -> text "%xmm7" + 24 -> text "%xmm8" ; 25 -> text "%xmm9" + 26 -> text "%xmm10"; 27 -> text "%xmm11" + 28 -> text "%xmm12"; 29 -> text "%xmm13" + 30 -> text "%xmm14"; 31 -> text "%xmm15" + _ -> text "very naughty x86 register" pprFormat :: Format -> SDoc -pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "w" - II32 -> sLit "l" - II64 -> sLit "q" - FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) - FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) - ) +pprFormat x = case x of + II8 -> text "b" + II16 -> text "w" + II32 -> text "l" + II64 -> text "q" + FF32 -> text "ss" -- "scalar single-precision float" (SSE2) + FF64 -> text "sd" -- "scalar double-precision float" (SSE2) pprFormat_x87 :: Format -> SDoc -pprFormat_x87 x - = ptext $ case x of - FF32 -> sLit "s" - FF64 -> sLit "l" - _ -> panic "X86.Ppr.pprFormat_x87" +pprFormat_x87 x = case x of + FF32 -> text "s" + FF64 -> text "l" + _ -> panic "X86.Ppr.pprFormat_x87" pprCond :: Cond -> SDoc -pprCond c - = ptext (case c of { - GEU -> sLit "ae"; LU -> sLit "b"; - EQQ -> sLit "e"; GTT -> sLit "g"; - GE -> sLit "ge"; GU -> sLit "a"; - LTT -> sLit "l"; LE -> sLit "le"; - LEU -> sLit "be"; NE -> sLit "ne"; - NEG -> sLit "s"; POS -> sLit "ns"; - CARRY -> sLit "c"; OFLO -> sLit "o"; - PARITY -> sLit "p"; NOTPARITY -> sLit "np"; - ALWAYS -> sLit "mp"}) +pprCond c = case c of { + GEU -> text "ae"; LU -> text "b"; + EQQ -> text "e"; GTT -> text "g"; + GE -> text "ge"; GU -> text "a"; + LTT -> text "l"; LE -> text "le"; + LEU -> text "be"; NE -> text "ne"; + NEG -> text "s"; POS -> text "ns"; + CARRY -> text "c"; OFLO -> text "o"; + PARITY -> text "p"; NOTPARITY -> text "np"; + ALWAYS -> text "mp"} pprImm :: Platform -> Imm -> SDoc @@ -624,70 +619,70 @@ pprInstr platform i = case i of _ -> format MOV format src dst - -> pprFormatOpOp (sLit "mov") format src dst + -> pprFormatOpOp (text "mov") format src dst CMOV cc format src dst - -> pprCondOpReg (sLit "cmov") format cc src dst + -> pprCondOpReg (text "cmov") format cc src dst MOVZxL II32 src dst - -> pprFormatOpOp (sLit "mov") II32 src dst + -> pprFormatOpOp (text "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. MOVZxL formats src dst - -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst + -> pprFormatOpOpCoerce (text "movz") formats II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. MOVSxL formats src dst - -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst + -> pprFormatOpOpCoerce (text "movs") formats (archWordFormat (target32Bit platform)) src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) | reg1 == reg3 - -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst + -> pprFormatOpOp (text "add") format (OpReg reg2) dst LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) | reg2 == reg3 - -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst + -> pprFormatOpOp (text "add") format (OpReg reg1) dst LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3) | reg1 == reg3 -> pprInstr platform (ADD format (OpImm displ) dst) LEA format src dst - -> pprFormatOpOp (sLit "lea") format src dst + -> pprFormatOpOp (text "lea") format src dst ADD format (OpImm (ImmInt (-1))) dst - -> pprFormatOp (sLit "dec") format dst + -> pprFormatOp (text "dec") format dst ADD format (OpImm (ImmInt 1)) dst - -> pprFormatOp (sLit "inc") format dst + -> pprFormatOp (text "inc") format dst ADD format src dst - -> pprFormatOpOp (sLit "add") format src dst + -> pprFormatOpOp (text "add") format src dst ADC format src dst - -> pprFormatOpOp (sLit "adc") format src dst + -> pprFormatOpOp (text "adc") format src dst SUB format src dst - -> pprFormatOpOp (sLit "sub") format src dst + -> pprFormatOpOp (text "sub") format src dst SBB format src dst - -> pprFormatOpOp (sLit "sbb") format src dst + -> pprFormatOpOp (text "sbb") format src dst IMUL format op1 op2 - -> pprFormatOpOp (sLit "imul") format op1 op2 + -> pprFormatOpOp (text "imul") format op1 op2 ADD_CC format src dst - -> pprFormatOpOp (sLit "add") format src dst + -> pprFormatOpOp (text "add") format src dst SUB_CC format src dst - -> pprFormatOpOp (sLit "sub") format src dst + -> pprFormatOpOp (text "sub") format src dst -- Use a 32-bit instruction when possible as it saves a byte. -- Notably, extracting the tag bits of a pointer has this form. @@ -698,86 +693,86 @@ pprInstr platform i = case i of -> pprInstr platform (AND II32 src dst) AND FF32 src dst - -> pprOpOp (sLit "andps") FF32 src dst + -> pprOpOp (text "andps") FF32 src dst AND FF64 src dst - -> pprOpOp (sLit "andpd") FF64 src dst + -> pprOpOp (text "andpd") FF64 src dst AND format src dst - -> pprFormatOpOp (sLit "and") format src dst + -> pprFormatOpOp (text "and") format src dst OR format src dst - -> pprFormatOpOp (sLit "or") format src dst + -> pprFormatOpOp (text "or") format src dst XOR FF32 src dst - -> pprOpOp (sLit "xorps") FF32 src dst + -> pprOpOp (text "xorps") FF32 src dst XOR FF64 src dst - -> pprOpOp (sLit "xorpd") FF64 src dst + -> pprOpOp (text "xorpd") FF64 src dst XOR format src dst - -> pprFormatOpOp (sLit "xor") format src dst + -> pprFormatOpOp (text "xor") format src dst POPCNT format src dst - -> pprOpOp (sLit "popcnt") format src (OpReg dst) + -> pprOpOp (text "popcnt") format src (OpReg dst) LZCNT format src dst - -> pprOpOp (sLit "lzcnt") format src (OpReg dst) + -> pprOpOp (text "lzcnt") format src (OpReg dst) TZCNT format src dst - -> pprOpOp (sLit "tzcnt") format src (OpReg dst) + -> pprOpOp (text "tzcnt") format src (OpReg dst) BSF format src dst - -> pprOpOp (sLit "bsf") format src (OpReg dst) + -> pprOpOp (text "bsf") format src (OpReg dst) BSR format src dst - -> pprOpOp (sLit "bsr") format src (OpReg dst) + -> pprOpOp (text "bsr") format src (OpReg dst) PDEP format src mask dst - -> pprFormatOpOpReg (sLit "pdep") format src mask dst + -> pprFormatOpOpReg (text "pdep") format src mask dst PEXT format src mask dst - -> pprFormatOpOpReg (sLit "pext") format src mask dst + -> pprFormatOpOpReg (text "pext") format src mask dst PREFETCH NTA format src - -> pprFormatOp_ (sLit "prefetchnta") format src + -> pprFormatOp_ (text "prefetchnta") format src PREFETCH Lvl0 format src - -> pprFormatOp_ (sLit "prefetcht0") format src + -> pprFormatOp_ (text "prefetcht0") format src PREFETCH Lvl1 format src - -> pprFormatOp_ (sLit "prefetcht1") format src + -> pprFormatOp_ (text "prefetcht1") format src PREFETCH Lvl2 format src - -> pprFormatOp_ (sLit "prefetcht2") format src + -> pprFormatOp_ (text "prefetcht2") format src NOT format op - -> pprFormatOp (sLit "not") format op + -> pprFormatOp (text "not") format op BSWAP format op - -> pprFormatOp (sLit "bswap") format (OpReg op) + -> pprFormatOp (text "bswap") format (OpReg op) NEGI format op - -> pprFormatOp (sLit "neg") format op + -> pprFormatOp (text "neg") format op SHL format src dst - -> pprShift (sLit "shl") format src dst + -> pprShift (text "shl") format src dst SAR format src dst - -> pprShift (sLit "sar") format src dst + -> pprShift (text "sar") format src dst SHR format src dst - -> pprShift (sLit "shr") format src dst + -> pprShift (text "shr") format src dst BT format imm src - -> pprFormatImmOp (sLit "bt") format imm src + -> pprFormatImmOp (text "bt") format imm src CMP format src dst - | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 - | otherwise -> pprFormatOpOp (sLit "cmp") format src dst + | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2 + | otherwise -> pprFormatOpOp (text "cmp") format src dst TEST format src dst - -> pprFormatOpOp (sLit "test") format' src dst + -> pprFormatOpOp (text "test") format' src dst where -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. -- We can replace them by equivalent, but smaller instructions @@ -800,10 +795,10 @@ pprInstr platform i = case i of minSizeOfReg _ _ = format -- other PUSH format op - -> pprFormatOp (sLit "push") format op + -> pprFormatOp (text "push") format op POP format op - -> pprFormatOp (sLit "pop") format op + -> pprFormatOp (text "pop") format op -- both unused (SDM): -- PUSHA -> text "\tpushal" @@ -828,17 +823,17 @@ pprInstr platform i = case i of -> panic $ "pprInstr: CLTD " ++ show x SETCC cond op - -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op) + -> pprCondInstr (text "set") cond (pprOperand platform II8 op) XCHG format src val - -> pprFormatOpReg (sLit "xchg") format src val + -> pprFormatOpReg (text "xchg") format src val JXX cond blockid - -> pprCondInstr (sLit "j") cond (pdoc platform lab) + -> pprCondInstr (text "j") cond (pdoc platform lab) where lab = blockLbl blockid JXX_GBL cond imm - -> pprCondInstr (sLit "j") cond (pprImm platform imm) + -> pprCondInstr (text "j") cond (pprImm platform imm) JMP (OpImm imm) _ -> text "\tjmp " <> pprImm platform imm @@ -856,44 +851,44 @@ pprInstr platform i = case i of -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg IDIV fmt op - -> pprFormatOp (sLit "idiv") fmt op + -> pprFormatOp (text "idiv") fmt op DIV fmt op - -> pprFormatOp (sLit "div") fmt op + -> pprFormatOp (text "div") fmt op IMUL2 fmt op - -> pprFormatOp (sLit "imul") fmt op + -> pprFormatOp (text "imul") fmt op -- x86_64 only MUL format op1 op2 - -> pprFormatOpOp (sLit "mul") format op1 op2 + -> pprFormatOpOp (text "mul") format op1 op2 MUL2 format op - -> pprFormatOp (sLit "mul") format op + -> pprFormatOp (text "mul") format op FDIV format op1 op2 - -> pprFormatOpOp (sLit "div") format op1 op2 + -> pprFormatOpOp (text "div") format op1 op2 SQRT format op1 op2 - -> pprFormatOpReg (sLit "sqrt") format op1 op2 + -> pprFormatOpReg (text "sqrt") format op1 op2 CVTSS2SD from to - -> pprRegReg (sLit "cvtss2sd") from to + -> pprRegReg (text "cvtss2sd") from to CVTSD2SS from to - -> pprRegReg (sLit "cvtsd2ss") from to + -> pprRegReg (text "cvtsd2ss") from to CVTTSS2SIQ fmt from to - -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to + -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to CVTTSD2SIQ fmt from to - -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to + -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to CVTSI2SS fmt from to - -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to + -> pprFormatOpReg (text "cvtsi2ss") fmt from to CVTSI2SD fmt from to - -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to + -> pprFormatOpReg (text "cvtsi2sd") fmt from to -- FETCHGOT for PIC on ELF platforms FETCHGOT reg @@ -925,10 +920,10 @@ pprInstr platform i = case i of -> text "\tmfence" XADD format src dst - -> pprFormatOpOp (sLit "xadd") format src dst + -> pprFormatOpOp (text "xadd") format src dst CMPXCHG format src dst - -> pprFormatOpOp (sLit "cmpxchg") format src dst + -> pprFormatOpOp (text "cmpxchg") format src dst where @@ -945,7 +940,7 @@ pprInstr platform i = case i of = (char '#' <> pprX87Instr fake) $$ actual pprX87Instr :: Instr -> SDoc - pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst + pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" pprDollImm :: Imm -> SDoc @@ -959,17 +954,17 @@ pprInstr platform i = case i of OpAddr ea -> pprAddr platform ea - pprMnemonic_ :: PtrString -> SDoc + pprMnemonic_ :: SDoc -> SDoc pprMnemonic_ name = - char '\t' <> ptext name <> space + char '\t' <> name <> space - pprMnemonic :: PtrString -> Format -> SDoc + pprMnemonic :: SDoc -> Format -> SDoc pprMnemonic name format = - char '\t' <> ptext name <> pprFormat format <> space + char '\t' <> name <> pprFormat format <> space - pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc + pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc pprFormatImmOp name format imm op1 = hcat [ pprMnemonic name format, @@ -980,14 +975,14 @@ pprInstr platform i = case i of ] - pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc + pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc pprFormatOp_ name format op1 = hcat [ pprMnemonic_ name , pprOperand platform format op1 ] - pprFormatOp :: PtrString -> Format -> Operand -> SDoc + pprFormatOp :: SDoc -> Format -> Operand -> SDoc pprFormatOp name format op1 = hcat [ pprMnemonic name format, @@ -995,7 +990,7 @@ pprInstr platform i = case i of ] - pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc pprFormatOpOp name format op1 op2 = hcat [ pprMnemonic name format, @@ -1005,7 +1000,7 @@ pprInstr platform i = case i of ] - pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc pprOpOp name format op1 op2 = hcat [ pprMnemonic_ name, @@ -1014,7 +1009,7 @@ pprInstr platform i = case i of pprOperand platform format op2 ] - pprRegReg :: PtrString -> Reg -> Reg -> SDoc + pprRegReg :: SDoc -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2 = hcat [ pprMnemonic_ name, @@ -1024,7 +1019,7 @@ pprInstr platform i = case i of ] - pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc + pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc pprFormatOpReg name format op1 reg2 = hcat [ pprMnemonic name format, @@ -1033,11 +1028,11 @@ pprInstr platform i = case i of pprReg platform (archWordFormat (target32Bit platform)) reg2 ] - pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc + pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc pprCondOpReg name format cond op1 reg2 = hcat [ char '\t', - ptext name, + name, pprCond cond, space, pprOperand platform format op1, @@ -1045,7 +1040,7 @@ pprInstr platform i = case i of pprReg platform format reg2 ] - pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc + pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc pprFormatFormatOpReg name format1 format2 op1 reg2 = hcat [ pprMnemonic name format2, @@ -1054,7 +1049,7 @@ pprInstr platform i = case i of pprReg platform format2 reg2 ] - pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc + pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc pprFormatOpOpReg name format op1 op2 reg3 = hcat [ pprMnemonic name format, @@ -1067,7 +1062,7 @@ pprInstr platform i = case i of - pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc + pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc pprFormatAddr name format op = hcat [ pprMnemonic name format, @@ -1075,7 +1070,7 @@ pprInstr platform i = case i of pprAddr platform op ] - pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc + pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc pprShift name format src dest = hcat [ pprMnemonic name format, @@ -1085,15 +1080,15 @@ pprInstr platform i = case i of ] - pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc + pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, + = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, pprOperand platform format1 op1, comma, pprOperand platform format2 op2 ] - pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc + pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc pprCondInstr name cond arg - = hcat [ char '\t', ptext name, pprCond cond, space, arg] + = hcat [ char '\t', name, pprCond cond, space, arg] diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 5f6c0486bc..9b8832ff80 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -46,7 +46,6 @@ import GHC.Cmm.Switch import GHC.CmmToAsm.CPrim import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform @@ -207,7 +206,7 @@ pprStmt :: Platform -> CmmNode e x -> SDoc pprStmt platform stmt = case stmt of CmmEntry{} -> empty - CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") + CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/" -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when -- some debugging option is on. They can get quite @@ -221,7 +220,7 @@ pprStmt platform stmt = CmmStore dest src | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" - else ptext (sLit ("ASSIGN_Word64"))) <> + else text "ASSIGN_Word64") <> parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise @@ -828,19 +827,20 @@ pprCallishMachOp_for_C mop MO_Memset _ -> text "memset" MO_Memmove _ -> text "memmove" MO_Memcmp _ -> text "memcmp" - (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) - (MO_BRev w) -> ptext (sLit $ bRevLabel w) - (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - (MO_Pext w) -> ptext (sLit $ pextLabel w) - (MO_Pdep w) -> ptext (sLit $ pdepLabel w) - (MO_Clz w) -> ptext (sLit $ clzLabel w) - (MO_Ctz w) -> ptext (sLit $ ctzLabel w) - (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) - (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) - (MO_Xchg w) -> ptext (sLit $ xchgLabel w) - (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) - (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) - (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) + + MO_BSwap w -> ftext (bSwapLabel w) + MO_BRev w -> ftext (bRevLabel w) + MO_PopCnt w -> ftext (popCntLabel w) + MO_Pext w -> ftext (pextLabel w) + MO_Pdep w -> ftext (pdepLabel w) + MO_Clz w -> ftext (clzLabel w) + MO_Ctz w -> ftext (ctzLabel w) + MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop) + MO_Cmpxchg w -> ftext (cmpxchgLabel w) + MO_Xchg w -> ftext (xchgLabel w) + MO_AtomicRead w -> ftext (atomicReadLabel w) + MO_AtomicWrite w -> ftext (atomicWriteLabel w) + MO_UF_Conv w -> ftext (word2FloatLabel w) MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index a5da50bd1d..74b6ca7e9a 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -76,7 +76,6 @@ import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Data.FastString import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) @@ -1324,9 +1323,7 @@ lintCaseExpr scrut var alt_ty alts = ; let isLitPat (Alt (LitAlt _) _ _) = True isLitPat _ = False ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) - (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ - "expression with literal pattern in case " ++ - "analysis (see #9238).") + (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." $$ text "scrut" <+> ppr scrut) ; case tyConAppTyCon_maybe (idType var) of diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 72cffdbfa9..cd92848a30 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -598,7 +598,7 @@ data FloatBind instance Outputable FloatBind where ppr (FloatLet b) = text "LET" <+> ppr b - ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) 2 (ppr c <+> ppr bs) wrapFloat :: FloatBind -> CoreExpr -> CoreExpr diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 3c6ff07a65..a8bf796af0 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -193,12 +193,12 @@ instance Outputable SimplMode where = text "SimplMode" <+> braces ( sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (sLit "inline") <> comma - , pp_flag r (sLit "rules") <> comma - , pp_flag eta (sLit "eta-expand") <> comma - , pp_flag cc (sLit "case-of-case") ]) + , pp_flag i (text "inline") <> comma + , pp_flag r (text "rules") <> comma + , pp_flag eta (text "eta-expand") <> comma + , pp_flag cc (text "case-of-case") ]) where - pp_flag f s = ppUnless f (text "no") <+> ptext s + pp_flag f s = ppUnless f (text "no") <+> s data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index c5e89b2ba9..89d5e9fd22 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1111,8 +1111,8 @@ data Call = Call Id [CoreArg] ValueEnv instance Outputable ScUsage where ppr (SCU { scu_calls = calls, scu_occs = occs }) - = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls - , text "occs =" <+> ppr occs ]) + = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls + , text "occs =" <+> ppr occs ]) instance Outputable Call where ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index fd183fba20..cec4814441 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -44,7 +44,6 @@ import GHC.Types.Basic import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Data.FastString import GHC.Types.SrcLoc ( pprUserRealSpan ) import GHC.Types.Tickish @@ -599,7 +598,7 @@ instance Outputable Unfolding where ppr BootUnfolding = text "No unfolding (from boot)" ppr (OtherCon cs) = text "OtherCon" <+> ppr cs ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (text "DFun:" <+> ptext (sLit "\\") + = hang (text "DFun:" <+> char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (ppr con <+> sep (map ppr args)) ppr (CoreUnfolding { uf_src = src diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index ff89358809..cee7d4f68b 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -306,7 +306,7 @@ applyTypeToArgs e op_ty args mkCast :: CoreExpr -> CoercionR -> CoreExpr mkCast e co | ASSERT2( coercionRole co == Representational - , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") + , text "coercion" <+> ppr co <+> text "passed to mkCast" <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) isReflCo co = e diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs index 9ba933f336..590f043d4b 100644 --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -31,7 +31,8 @@ -- * Pointer and size of a Latin-1 encoded string. -- * Practically no operations. -- * Outputting them is fast. --- * Generated by 'sLit'. +-- * Generated by 'mkPtrString'. +-- * Length of string literals (mkPtrString "abc") is computed statically -- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext' -- * Requires manual memory management. -- Improper use may lead to memory leaks or dangling pointers. @@ -101,7 +102,6 @@ module GHC.Data.FastString PtrString (..), -- ** Construction - sLit, mkPtrString#, mkPtrString, @@ -675,7 +675,7 @@ mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) -- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 -- encoding. The original string must not contain non-Latin-1 characters -- (above codepoint @0xff@). -{-# INLINE mkPtrString #-} +{-# NOINLINE[0] mkPtrString #-} -- see rules below mkPtrString :: String -> PtrString mkPtrString s = -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks @@ -693,6 +693,9 @@ mkPtrString s = return (PtrString p len) ) +{-# RULES "mkPtrString" + forall x . mkPtrString (unpackCString# x) = mkPtrString# x #-} + -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String @@ -714,15 +717,9 @@ ptrStrLength :: Ptr Word8 -> Int {-# INLINE ptrStrLength #-} ptrStrLength (Ptr a) = I# (cstringLength# a) -{-# NOINLINE sLit #-} -sLit :: String -> PtrString -sLit x = mkPtrString x - {-# NOINLINE fsLit #-} fsLit :: String -> FastString fsLit x = mkFastString x -{-# RULES "slit" - forall x . sLit (unpackCString# x) = mkPtrString# x #-} {-# RULES "fslit" forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 6acc547202..f49dca22ad 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -405,7 +405,7 @@ dumpModCycles logger dflags module_graph cycles = [ c | CyclicSCC c <- topoSort ] - pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------") $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 6c2ed3c167..e909303c25 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -43,7 +43,6 @@ import GHC.Types.Basic import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Data.Bag -import GHC.Data.FastString import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.Name.Reader import GHC.Types.Name @@ -515,7 +514,7 @@ instance (OutputableBndrId l, OutputableBndrId r) ppr_rhs = case dir of Unidirectional -> ppr_simple (text "<-") ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ + ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$ (nest 2 $ pprFunBind mg) pprTicks :: SDoc -> SDoc -> SDoc diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index bf415f7264..fb523bb74a 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -545,14 +545,14 @@ ppr_expr (HsLamCase _ matches) nest 2 (pprMatches matches) ] ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts })) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], pp_alts ] where pp_alts | null alts = text "{}" | otherwise = nest 2 (pprMatches matches) ppr_expr (HsIf _ e1 e2 e3) - = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], + = sep [hsep [text "if", nest 2 (ppr e1), text "then"], nest 4 (ppr e2), text "else", nest 4 (ppr e3)] @@ -570,7 +570,7 @@ ppr_expr (HsMultiIf _ alts) -- special case: let ... in let ... ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lexpr expr] ppr_expr (HsLet _ binds expr) @@ -616,7 +616,7 @@ ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps) ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] + = hsep [text "proc", ppr pat, text "->", ppr cmd] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] @@ -1076,21 +1076,21 @@ ppr_cmd (HsCmdLam _ matches) = pprMatches matches ppr_cmd (HsCmdCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], nest 2 (pprMatches matches) ] ppr_cmd (HsCmdLamCase _ matches) = sep [ text "\\case", nest 2 (pprMatches matches) ] ppr_cmd (HsCmdIf _ _ e ct ce) - = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], + = sep [hsep [text "if", nest 2 (ppr e), text "then"], nest 4 (ppr ct), text "else", nest 4 (ppr ce)] -- special case: let ... in let ... ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lcmd cmd] ppr_cmd (HsCmdLet _ binds cmd) @@ -1459,7 +1459,7 @@ pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc pprTransStmt by using ThenForm = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] pprTransStmt by using GroupForm - = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)] pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty @@ -1702,7 +1702,7 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> pp_body <+> text "|]" thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") +thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" instance Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 55b5af7bc9..05e176d9f7 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -25,7 +25,6 @@ import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString import GHC.Types.SrcLoc import Language.Haskell.Syntax.Extension import GHC.Hs.Extension @@ -164,7 +163,7 @@ instance (OutputableBndrId p 4 (pp_spec spec) where pp_implicit False = empty - pp_implicit True = ptext (sLit ("(implicit)")) + pp_implicit True = text "(implicit)" pp_pkg Nothing = empty pp_pkg (Just (StringLiteral st p _)) diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 10eee59112..933e8241e2 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -664,9 +664,9 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc text "rts_apply" <> parens ( cap <> text "(HaskellObj)" - <> ptext (if is_IO_res_ty - then (sLit "runIO_closure") - else (sLit "runNonIO_closure")) + <> (if is_IO_res_ty + then text "runIO_closure" + else text "runNonIO_closure") <> comma <> expr_to_run ) <+> comma diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 16c0d6c2c6..a3cc8f44af 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -351,14 +351,14 @@ warnAboutOverflowedLiterals dflags lit diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is negative but" <+> ppr tc - <+> ptext (sLit "only supports positive numbers") + <+> text "only supports positive numbers" ]) check i tc minB maxB = when (i < minB || i > maxB) $ diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") + <+> text "is out of the" <+> ppr tc <+> text "range" <+> integer minB <> text ".." <> integer maxB , sug ]) where diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs index 6cfa09f99d..9e0df9a9d8 100644 --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -16,7 +16,6 @@ module GHC.Iface.Errors import GHC.Platform.Profile import GHC.Platform.Ways import GHC.Utils.Panic.Plain -import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Env.Types import GHC.Data.Maybe @@ -69,12 +68,12 @@ homeModError mod location -- Error messages cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") +cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") + (text "Ambiguous interface for") cantFindInstalledErr - :: PtrString - -> PtrString + :: SDoc + -> SDoc -> UnitState -> HomeUnit -> Profile @@ -83,7 +82,7 @@ cantFindInstalledErr -> InstalledFindResult -> SDoc cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) + = cannot_find <+> quotes (ppr mod_name) $$ more_info where build_tag = waysBuildTag (profileWays profile) @@ -153,8 +152,8 @@ cannotFindModule hsc_env = cannotFindModule' cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $ cantFindErr (gopt Opt_BuildingCabalPackage dflags) - (sLit cannotFindMsg) - (sLit "Ambiguous module name") + cannotFindMsg + (text "Ambiguous module name") unit_env profile (mayShowLocations dflags) @@ -167,13 +166,13 @@ cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units u , fr_pkgs_hidden = hidden_pkgs , fr_unusables = unusables } | not (null hidden_mods && null hidden_pkgs && null unusables) - -> "Could not load module" - _ -> "Could not find module" + -> text "Could not load module" + _ -> text "Could not find module" cantFindErr :: Bool -- ^ Using Cabal? - -> PtrString - -> PtrString + -> SDoc + -> SDoc -> UnitEnv -> Profile -> ([FilePath] -> SDoc) @@ -182,12 +181,12 @@ cantFindErr -> SDoc cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) | Just pkgs <- unambiguousPackages - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [text "it was found in multiple packages:", hsep (map ppr pkgs) ] ) | otherwise - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( vcat (map pprMod mods) ) where @@ -210,7 +209,7 @@ cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) ) cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) + = cannot_find <+> quotes (ppr mod_name) $$ more_info where mhome_unit = ue_home_unit unit_env diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 9c3417825b..99fcfcd4dd 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -800,7 +800,7 @@ wantHiBootFile home_unit eps mod from badSourceImport :: Module -> SDoc badSourceImport mod = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") + 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs index 3cc4ab5394..eb48179330 100644 --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -43,7 +43,6 @@ import Data.List ( intersperse ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Unique -import GHC.Data.FastString -------------------------------------------------------------------------------- -- * Top Level Print functions @@ -151,9 +150,9 @@ ppLlvmFunction opts fun = ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" align = case a of Just a' -> text " align " <> ppr a' Nothing -> empty @@ -161,7 +160,7 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args <> ftext n) (zip p args) in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> - (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align + (hsep $ punctuate comma args') <> varg' <> rparen <> align -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc @@ -173,16 +172,16 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" align = case a of Just a' -> text " align" <+> ppr a' Nothing -> empty args = hcat $ intersperse (comma <> space) $ map (\(t,a) -> ppr t <+> ppSpaceJoin a) p in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> - ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine + ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks. @@ -577,8 +576,8 @@ ppStatic opts st = case st of LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' - LMAdd s1 s2 -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd" - LMSub s1 s2 -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub" + LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd") + LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc @@ -592,15 +591,15 @@ pprSpecialStatic opts stat = case stat of _ -> ppStatic opts stat -pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString - -> String -> SDoc +pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc + -> SDoc -> SDoc pprStaticArith opts s1 s2 int_op float_op op_name = let ty1 = getStatType s1 op = if isFloat ty1 then float_op else int_op in if ty1 == getStatType s2 - then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen + then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen else pprPanic "pprStaticArith" $ - text op_name <> text " with different types! s1: " <> ppStatic opts s1 + op_name <> text " with different types! s1: " <> ppStatic opts s1 <> text", s2: " <> ppStatic opts s2 diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs index f1638ba5b6..a30605d3cd 100644 --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -88,12 +88,12 @@ ppType t = case t of ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc ppParams varg p = let varg' = case varg of - VarArgs | null args -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" + VarArgs | null args -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" -- by default we don't print param attributes args = map fst p - in ppCommaJoin args <> ptext varg' + in ppCommaJoin args <> varg' -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 3b73e068b4..8decaddfbe 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -537,9 +537,9 @@ pp_err = \case PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where -> vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> what - <+> ptext (sLit "declaration for") <+> quotes tc' + <+> text "declaration for" <+> quotes tc' , vcat[ (text "A" <+> what - <+> ptext (sLit "declaration should have form")) + <+> text "declaration should have form") , nest 2 (what <+> tc' diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 67b3d0d8c0..d204e6ed0e 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1531,7 +1531,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss }) occ = greOccName gre name = greMangledName gre name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" mk_msg imp_spec txt = sep [ sep [ text "In the use of" @@ -1845,7 +1845,7 @@ lookupBindGroupOcc ctxt what rdr_name , nest 2 $ text "lacks an accompanying binding"] $$ nest 2 msg)) - local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") + local_msg = parens $ text "The" <+> what <+> text "must be given where" <+> quotes (ppr rdr_name) <+> text "is declared" -- Identify all similar names and produce a message listing them diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index bbf52be2f8..0ddd207148 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -2360,7 +2360,7 @@ checkStmt ctxt (L _ stmt) IsValid -> return () NotValid extra -> addErr (msg $$ extra) } where - msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") + msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" , text "in" <+> pprAStmtContext ctxt ] pprStmtCat :: Stmt (GhcPass a) body -> SDoc diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index f92100ffe2..e9ee8bb31b 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -68,7 +68,6 @@ import GHC.Types.Fixity ( compareFixity, negateFixity import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -831,7 +830,7 @@ rnHsTyOp env overall_ty (L loc op) -------------- notAllowed :: SDoc -> SDoc notAllowed doc - = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") + = text "Wildcard" <+> quotes doc <+> text "not allowed" checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () checkWildCard env (Just doc) @@ -1593,7 +1592,7 @@ precParseErr op1@(n1,_) op2@(n2,_) = return () -- Avoid error cascade | otherwise = addErr $ hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), + 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", ppr_opfix op2, text "in the same infix expression"]) @@ -1602,7 +1601,7 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), + = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", nest 4 (sep [text "must have lower precedence than that of the operand,", nest 2 (text "namely" <+> ppr_opfix arg_op)]), nest 4 (text "in the section:" <+> quotes (ppr section))] @@ -1655,7 +1654,7 @@ warnUnusedForAll doc (L loc tv) used_names opTyErr :: Outputable a => RdrName -> a -> SDoc opTyErr op overall_ty - = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) + = hang (text "Illegal operator" <+> quotes (ppr op) <+> text "in type" <+> quotes (ppr overall_ty)) 2 (text "Use TypeOperators to allow operators in types") {- diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 32d9bd0da8..2abc65e001 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -356,8 +356,7 @@ rnImportDecl this_mod (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (text "safe import can't be used as Safe Haskell isn't on!" - $+$ ptext (sLit $ "please enable Safe Haskell through either " - ++ "Safe, Trustworthy or Unsafe")) + $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) let qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name @@ -2012,7 +2011,7 @@ dodgyImportWarn item dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc dodgyMsg kind tc ie - = sep [ text "The" <+> kind <+> ptext (sLit "item") + = sep [ text "The" <+> kind <+> text "item" -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) <+> quotes (ppr ie) <+> text "suggests that", @@ -2047,15 +2046,15 @@ addDupDeclErr gres@(gre : _) missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod - = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" missingImportListItem :: IE GhcPs -> SDoc missingImportListItem ie - = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") + = text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list" moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), + = sep [ text "Module" <+> quotes (ppr mod) <> colon, nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 9ebd15e5f6..ab651b93a7 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -417,7 +417,7 @@ there are 2 cases, where we hide the last "no module is imported" line: exactNameErr :: Name -> SDoc exactNameErr name = - hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + hang (text "The exact Name" <+> quotes (ppr name) <+> text "is not in scope") 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " , text "perhaps via newName, but did not bind it" , text "If that's it, then -ddump-splices might be useful" ]) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index e5d27fa234..e87721edaf 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -451,7 +451,7 @@ warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") + msg = text "Imported from" <+> pp_mod <+> text "but not used" -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. @@ -618,7 +618,7 @@ checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + = addErr (sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), nest 2 (text "Workaround: use nested tuples or define a data type")]) diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index d3acf5ffed..dc01a161af 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -267,10 +267,10 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) + return (char '_' <+> whenPprDebug (dcolon <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} --- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>") - | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty +-- | Just _ <- splitFunTy_maybe ty = return$ text "<function>" + | otherwise = return$ parens$ ppr n <> dcolon <> ppr ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 2d402ae27a..b81b3adc64 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -50,7 +50,6 @@ import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile -import GHC.Data.FastString import GHC.StgToCmm.Types import GHC.Utils.Outputable @@ -534,8 +533,8 @@ pprTypeInfo (Constr tag descr) pprTypeInfo (Fun arity args) = text "Fun" <+> - braces (sep [ text "arity:" <+> ppr arity - , ptext (sLit ("fun_type:")) <+> ppr args ]) + braces (sep [ text "arity:" <+> ppr arity + , text "fun_type:" <+> ppr args ]) pprTypeInfo (ThunkSelector offset) = text "ThunkSel" <+> ppr offset diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index a1386b7937..648f80c571 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -60,8 +60,6 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Data.FastString - import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) @@ -289,10 +287,10 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do doc = text "contains a name used in an invocation of lookupRdrNameInModule" wrongTyThingError :: Name -> TyThing -> SDoc -wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] +wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing] missingTyThingError :: Name -> SDoc -missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] +missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"] throwCmdLineErrorS :: DynFlags -> SDoc -> IO a throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index abbf4131d7..cd25a36c0d 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -754,10 +754,10 @@ pprStgExpr opts e = case e of StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) -> ($$) - (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), + (hang (hcat [text "let { ", ppr bndr, text " = ", ppr cc, pp_binder_info bi, - text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"), + text " [", whenPprDebug (interppSP free_vars), text "] \\", ppr upd_flag, text " [", interppSP args, char ']']) 8 (sep [hsep [ppr rhs, text "} in"]])) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index c71ad4b7b8..fa8817b36a 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -62,7 +62,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger -import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt @@ -251,10 +250,10 @@ tcDeriving deriv_infos deriv_decls = hang (text "Derived class instances:") 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) - $$ hangP "Derived type family instances:" + $$ hangP (text "Derived type family instances:") (vcat (map pprRepTy (bagToList repFamInsts))) - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + hangP s x = text "" $$ hang s 2 x -- Apply the suspended computations given by genInst calls. -- See Note [Staging of tcDeriving] @@ -2293,7 +2292,7 @@ derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why derivingHiddenErr :: TyCon -> SDoc derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + = hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") 2 (text "so you cannot derive an instance for it") standaloneCtxt :: LHsSigWcType GhcRn -> SDoc diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index d9d7232595..04bd4da157 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -25,7 +25,6 @@ import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt tcDefaults :: [LDefaultDecl GhcRn] @@ -114,5 +113,5 @@ dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + = hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index ecd07c6059..98d8e8c278 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -77,7 +77,6 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) @@ -1466,7 +1465,7 @@ Boring and alphabetical: fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") + = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs @@ -1552,15 +1551,14 @@ a decent stab, no more. See #7989. mixedSelectors :: [Id] -> [Id] -> SDoc mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = ptext - (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ + = text "Cannot use a mixture of pattern synonym and record selectors" $$ text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc)) - <> text ":" + <> colon <+> pprWithCommas ppr data_sels $$ text "Pattern synonym selectors defined by" <+> quotes (ppr (patSynName rep_ps)) - <> text ":" + <> colon <+> pprWithCommas ppr pat_syn_sels where RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 5a7fb93f48..26bb301361 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -4279,7 +4279,7 @@ promotionErr name err -- Used for both expressions and types. funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), + = hang (hsep [ text "In the", speakNth arg_no, text "argument of", quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 7124dcd52e..58f8e59b37 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1242,7 +1242,7 @@ instance TH.Quasi TcM where bindName name = addErr $ - hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") qAddForeignFilePath lang fp = do @@ -2358,11 +2358,11 @@ reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty) + | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty) | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) +reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty) reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy @@ -2617,8 +2617,8 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: PtrString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> +noTH :: SDoc -> SDoc -> TcM a +noTH s d = failWithTc (hsep [text "Can't represent" <+> s <+> text "in Template Haskell:", nest 2 d]) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 72de8f0652..a55a774069 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -65,7 +65,6 @@ import GHC.Core.TyCon import GHC.Data.Maybe import GHC.Types.Basic import GHC.Data.Bag -import GHC.Data.FastString import GHC.Data.BooleanFormula import GHC.Utils.Misc @@ -469,7 +468,7 @@ dupGenericInsts tc_inst_infos -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") + = addErrTc (text "The" <+> hsSigDoc prag <+> text "for default method" <+> quotes (ppr sel_id) <+> text "lacks an accompanying binding") diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 642429d61b..6f8e1ef901 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -648,7 +648,7 @@ addPatSynCtxt (L loc name) thing_inside wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing = failWithTc $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") + hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" <+> speakNOf decl_arity (text "argument")) 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index ce88ddeade..b71e5afbd1 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1669,7 +1669,7 @@ cvtTypeKind ty_str ty ; returnLA (HsIParamTy noAnn n' t') } - _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) + _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty)) } hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 04fb58324f..eccffc8525 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -840,9 +840,9 @@ boxityTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") +tupleParens UnboxedTuple p = text "(#" <+> p <+> text "#)" tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + = ifPprDebug (text "(%" <+> p <+> text "%)") (parens p) {- @@ -854,7 +854,7 @@ tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) -} sumParens :: SDoc -> SDoc -sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") +sumParens p = text "(#" <+> p <+> text "#)" -- | Pretty print an alternative in an unboxed sum e.g. "| a | |". pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index c14a0865ee..7ec1356939 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -817,7 +817,7 @@ instance Outputable GlobalRdrElt where pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)") <+> lbrace , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] <+> rbrace) ] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 4f126b92b3..c2dbb64a5a 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1508,7 +1508,7 @@ withSandboxOnly cmd this = do dflags <- getDynFlags if not (gopt Opt_GhciSandbox dflags) then printForUser (text cmd <+> - ptext (sLit "is not supported with -fno-ghci-sandbox")) + text "is not supported with -fno-ghci-sandbox") else this ----------------------------------------------------------------------------- @@ -3344,12 +3344,12 @@ showContext = do printForUser $ vcat (map pp_resume (reverse resumes)) where pp_resume res = - ptext (sLit "--> ") <> text (GHC.resumeStmt res) + text "--> " <> text (GHC.resumeStmt res) $$ nest 2 (pprStopped res) pprStopped :: GHC.Resume -> SDoc pprStopped res = - ptext (sLit "Stopped in") + text "Stopped in" <+> ((case mb_mod_name of Nothing -> empty Just mod_name -> text (moduleNameString mod_name) <> char '.') @@ -3957,7 +3957,7 @@ backCmd arg where back num = withSandboxOnly ":back" $ do (names, _, pan, _) <- GHC.back num - printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan + printForUser $ text "Logged breakpoint at" <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState @@ -3972,8 +3972,8 @@ forwardCmd arg forward num = withSandboxOnly ":forward" $ do (names, ix, pan, _) <- GHC.forward num printForUser $ (if (ix == 0) - then ptext (sLit "Stopped at") - else ptext (sLit "Logged breakpoint at")) <+> ppr pan + then text "Stopped at" + else text "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState |