From 1d03d8bef962e6789db44e8b6f2cfd9e34f3f5ad Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 11 Mar 2021 17:41:51 +0100 Subject: 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. --- compiler/GHC/CmmToAsm/CPrim.hs | 260 ++++++++++---------- compiler/GHC/CmmToAsm/Dwarf.hs | 12 +- compiler/GHC/CmmToAsm/Dwarf/Constants.hs | 11 +- compiler/GHC/CmmToAsm/Dwarf/Types.hs | 22 +- compiler/GHC/CmmToAsm/PIC.hs | 12 +- compiler/GHC/CmmToAsm/PPC/CodeGen.hs | 16 +- compiler/GHC/CmmToAsm/PPC/Ppr.hs | 162 ++++++------- compiler/GHC/CmmToAsm/Ppr.hs | 40 ++- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs | 26 +- compiler/GHC/CmmToAsm/SPARC/Ppr.hs | 235 +++++++++--------- compiler/GHC/CmmToAsm/X86/CodeGen.hs | 18 +- compiler/GHC/CmmToAsm/X86/Ppr.hs | 405 +++++++++++++++---------------- 12 files changed, 608 insertions(+), 611 deletions(-) (limited to 'compiler/GHC/CmmToAsm') 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] -- cgit v1.2.1