diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2022-10-28 21:05:34 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-11-05 00:29:57 -0400 |
commit | 3c0e379322965aa87b14923f6d8e1ef5cd677925 (patch) | |
tree | c7db820ab9cd898e3539b4704d041bbaf0d6954f | |
parent | bdc8cbb3a0808632fc6b33a7e3c10212f5d8a5e9 (diff) | |
download | haskell-3c0e379322965aa87b14923f6d8e1ef5cd677925.tar.gz |
Minor refactor around FastStrings
Pass FastStrings to functions directly, to make sure the rule
for fsLit "literal" fires.
Remove SDoc indirection in GHCi.UI.Tags and GHC.Unit.Module.Graph.
36 files changed, 102 insertions, 95 deletions
diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs index e6396c8e83..ec52a3842a 100644 --- a/compiler/GHC/Cmm/BlockId.hs +++ b/compiler/GHC/Cmm/BlockId.hs @@ -11,6 +11,7 @@ module GHC.Cmm.BlockId import GHC.Prelude import GHC.Cmm.CLabel +import GHC.Data.FastString import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique @@ -43,4 +44,4 @@ blockLbl label = mkLocalBlockLabel (getUnique label) infoTblLbl :: BlockId -> CLabel infoTblLbl label - = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs + = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index bf4214fed2..22c1c9ef05 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -300,19 +300,19 @@ instance Show CLabel where show = showPprUnsafe . pprDebugCLabel genericPlatform data ModuleLabelKind - = MLK_Initializer String + = MLK_Initializer LexicalFastString | MLK_InitializerArray - | MLK_Finalizer String + | MLK_Finalizer LexicalFastString | MLK_FinalizerArray | MLK_IPEBuffer deriving (Eq, Ord) instance Outputable ModuleLabelKind where - ppr MLK_InitializerArray = text "init_arr" - ppr (MLK_Initializer s) = text ("init__" ++ s) - ppr MLK_FinalizerArray = text "fini_arr" - ppr (MLK_Finalizer s) = text ("fini__" ++ s) - ppr MLK_IPEBuffer = text "ipe_buf" + ppr MLK_InitializerArray = text "init_arr" + ppr (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s + ppr MLK_FinalizerArray = text "fini_arr" + ppr (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s + ppr MLK_IPEBuffer = text "ipe_buf" isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True @@ -885,15 +885,15 @@ mkDeadStripPreventer lbl = DeadStripPreventer lbl mkStringLitLabel :: Unique -> CLabel mkStringLitLabel = StringLitLabel -mkInitializerStubLabel :: Module -> String -> CLabel -mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer s) +mkInitializerStubLabel :: Module -> FastString -> CLabel +mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer (LexicalFastString s)) mkInitializerArrayLabel :: Module -> CLabel mkInitializerArrayLabel mod = ModuleLabel mod MLK_InitializerArray -mkFinalizerStubLabel :: Module -> String -> CLabel -mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer s) +mkFinalizerStubLabel :: Module -> FastString -> CLabel +mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer (LexicalFastString s)) mkFinalizerArrayLabel :: Module -> CLabel mkFinalizerArrayLabel mod = ModuleLabel mod MLK_FinalizerArray diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs index 5ca443f08e..54cf73d55e 100644 --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -232,7 +232,7 @@ pprImm _ (ImmInt i) = int i pprImm _ (ImmInteger i) = integer i pprImm p (ImmCLbl l) = pprAsmLabel p l pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i -pprImm _ (ImmLit s) = text s +pprImm _ (ImmLit s) = ftext s -- TODO: See pprIm below for why this is a bad idea! pprImm _ (ImmFloat f) diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs index d3650c96f0..4895d2b092 100644 --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -2,6 +2,7 @@ module GHC.CmmToAsm.AArch64.Regs where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -59,7 +60,7 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit String + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational @@ -67,7 +68,7 @@ data Imm | ImmConstantDiff Imm Imm deriving (Eq, Show) -strImmLit :: String -> Imm +strImmLit :: FastString -> Imm strImmLit s = ImmLit s diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index f8563004b5..abad5d0427 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -407,7 +407,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) | OSAIX <- platformOS platform = do let code dst = toOL [ LD II32 dst tocAddr ] - tocAddr = AddrRegImm toc (ImmLit "ghc_toc_table[TC]") + tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) return (Any II32 code) | target32Bit platform = do reg <- getPicBaseNat $ archWordFormat (target32Bit platform) diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 19de3cd1e2..78abfcb0a3 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -240,7 +240,7 @@ pprImm platform = \case ImmInteger i -> integer i ImmCLbl l -> pprAsmLabel platform l ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i - ImmLit s -> text s + ImmLit s -> ftext s ImmFloat f -> float $ fromRational f ImmDouble d -> double $ fromRational d ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs index 901913f7d9..5b4e179f1a 100644 --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -47,6 +47,7 @@ module GHC.CmmToAsm.PPC.Regs ( where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -133,7 +134,7 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit String + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational @@ -146,7 +147,7 @@ data Imm | HIGHESTA Imm -strImmLit :: String -> Imm +strImmLit :: FastString -> Imm strImmLit s = ImmLit s diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs index 42b9543204..06fc3f6c7e 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -38,6 +38,7 @@ module GHC.CmmToAsm.X86.Instr where import GHC.Prelude +import GHC.Data.FastString import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs @@ -868,7 +869,7 @@ mkStackAllocInstr platform amount case platformArch platform of ArchX86 | needs_probe_call platform amount -> [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax) - , CALL (Left $ strImmLit "___chkstk_ms") [eax] + , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [eax] , SUB II32 (OpReg eax) (OpReg esp) ] | otherwise -> @@ -877,7 +878,7 @@ mkStackAllocInstr platform amount ] ArchX86_64 | needs_probe_call platform amount -> [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax) - , CALL (Left $ strImmLit "___chkstk_ms") [rax] + , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [rax] , SUB II64 (OpReg rax) (OpReg rsp) ] | otherwise -> diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 6c16160ce8..32b163357d 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -432,7 +432,7 @@ pprImm platform = \case ImmInteger i -> integer i ImmCLbl l -> pprAsmLabel platform l ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i - ImmLit s -> text s + ImmLit s -> ftext s ImmFloat f -> float $ fromRational f ImmDouble d -> double $ fromRational d ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs index ab5558d8e1..25746f9deb 100644 --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -48,6 +48,7 @@ module GHC.CmmToAsm.X86.Regs ( where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Regs import GHC.Platform.Reg @@ -110,14 +111,14 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit String + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational | ImmConstantSum Imm Imm | ImmConstantDiff Imm Imm -strImmLit :: String -> Imm +strImmLit :: FastString -> Imm strImmLit s = ImmLit s diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index 5f585ef866..ea5884405e 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -110,8 +110,8 @@ llvmCodeGen' cfg cmm_stream header = let target = llvmCgLlvmTarget cfg llvmCfg = llvmCgLlvmConfig cfg - in text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"") - $+$ text ("target triple = \"" ++ target ++ "\"") + in (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"") + $+$ (text "target triple = \"" <> text target <> text "\"") getDataLayout :: LlvmConfig -> String -> String getDataLayout config target = diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 06bc235913..1449e2331d 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -146,6 +146,7 @@ import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) import GHC.Types.Basic import GHC.Types.Unique +import GHC.Data.FastString import GHC.Data.Pair import GHC.Types.SrcLoc import GHC.Builtin.Names @@ -286,7 +287,7 @@ tidyCoAxBndrsForUser init_env tcvs (env', bndr') = tidyVarBndr env bndr env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOcc "_") + tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) -- Tidy the binder to "_" is_wildcard :: Var -> Bool diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 844f753957..e955e5befd 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -50,6 +50,7 @@ import GHC.Core.RoughMap import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name +import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc @@ -686,7 +687,7 @@ mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc -- See Note [Tidy axioms when we build them] -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom - init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")] init_tidy_env = mkEmptyTidyEnv init_occ_env -- See Note [Always number wildcard types in CoAxBranch] diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index 36f1bb015a..2cbebbd411 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -17,6 +17,7 @@ module GHC.Core.TyCo.Tidy ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) @@ -70,7 +71,7 @@ getHelpfulOccName :: TyCoVar -> OccName -- this way is a helpful clue for users getHelpfulOccName tv | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") + = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0") | otherwise = occ where diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 448c4c864e..2e56336cba 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -17,6 +17,7 @@ where import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang +import GHC.Data.FastString import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -331,7 +332,7 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs) initializerCStub platform fn_name decls body where pdocC = pprCLabel platform - fn_name = mkInitializerStubLabel this_mod "prof_init" + fn_name = mkInitializerStubLabel this_mod (fsLit "prof_init") decls = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs @@ -374,7 +375,7 @@ ipInitCode do_info_table platform this_mod | not do_info_table = mempty | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body where - fn_nm = mkInitializerStubLabel this_mod "ip_init" + fn_nm = mkInitializerStubLabel this_mod (fsLit "ip_init") body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 9e2619db65..146a1a2125 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -116,7 +116,7 @@ hpcInitCode _ _ (NoHpcInfo {}) = mempty hpcInitCode platform this_mod (HpcInfo tickCount hashNo) = initializerCStub platform fn_name decls body where - fn_name = mkInitializerStubLabel this_mod "hpc" + fn_name = mkInitializerStubLabel this_mod (fsLit "hpc") decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi body = text "hs_hpc_module" <> parens (hcat (punctuate comma [ diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 60212b0d23..8257fea3bb 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -16,6 +16,7 @@ module GHC.HsToCore.Foreign.Decl where import GHC.Prelude +import GHC.Data.FastString import GHC.Tc.Utils.Monad -- temp @@ -184,7 +185,7 @@ foreignExportsInitialiser platform mod hs_fns = -- See Note [Tracking foreign exports] in rts/ForeignExports.c initializerCStub platform fn_nm list_decl fn_body where - fn_nm = mkInitializerStubLabel mod "fexports" + fn_nm = mkInitializerStubLabel mod (fsLit "fexports") mod_str = pprModuleName (moduleName mod) fn_body = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi list_symbol = text "stg_exports_" <> mod_str diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 896f32df0a..db923a0982 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -19,6 +19,7 @@ module GHC.Iface.Recomp where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Backend import GHC.Driver.Config.Finder @@ -168,7 +169,7 @@ instance Monoid RecompileRequired where data RecompReason = UnitDepRemoved UnitId - | ModulePackageChanged String + | ModulePackageChanged FastString | SourceFileChanged | ThisUnitIdChanged | ImpurePlugin @@ -200,7 +201,7 @@ data RecompReason instance Outputable RecompReason where ppr = \case UnitDepRemoved uid -> ppr uid <+> text "removed" - ModulePackageChanged s -> text s <+> text "package changed" + ModulePackageChanged s -> ftext s <+> text "package changed" SourceFileChanged -> text "Source file changed" ThisUnitIdChanged -> text "-this-unit-id changed" ImpurePlugin -> text "Impure plugin forced recompilation" @@ -596,7 +597,7 @@ checkDependencies hsc_env summary iface -> [(t, GenLocated l ModuleName)] -> IfG [Either - CompileReason (Either (UnitId, ModuleName) (String, UnitId))] + CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))] classify_import find_import imports = liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = ModuleChanged mod @@ -612,9 +613,9 @@ checkDependencies hsc_env summary iface prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) (dep_plugin_pkgs (mi_deps iface))) - bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) + bkpk_units = map ((fsLit "Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) - implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) + implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) -- GHC.Prim is very special and doesn't appear in ms_textual_imps but -- ghc-prim will appear in the package dependencies still. In order to not confuse @@ -623,12 +624,12 @@ checkDependencies hsc_env summary iface Just home_unit | homeUnitId home_unit == primUnitId -> Left (primUnitId, mkModuleName "GHC.Prim") - _ -> Right ("GHC.Prim", primUnitId) + _ -> Right (fsLit "GHC.Prim", primUnitId) classify _ (Found _ mod) | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) - | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) + | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired @@ -649,7 +650,7 @@ checkDependencies hsc_env summary iface text " not among previous dependencies" return $ needsRecompileBecause $ ModuleAdded new - check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired + check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired check_packages [] [] = return UpToDate check_packages [] (old:_) = do trace_hi_diffs logger $ @@ -661,7 +662,7 @@ checkDependencies hsc_env summary iface , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds' | otherwise = do trace_hi_diffs logger $ - text "imported package" <+> text new_name <+> ppr new_unit <+> + text "imported package" <+> ftext new_name <+> ppr new_unit <+> text "not among previous dependencies" return $ needsRecompileBecause $ ModulePackageChanged new_name @@ -1243,7 +1244,7 @@ addFingerprints hsc_env iface0 iface_hash <- computeFingerprint putNameLiterally (mod_hash, mi_src_hash iface0, - ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache + ann_fn (mkVarOccFS (fsLit "module")), -- See mkIfaceAnnCache mi_usages iface0, sorted_deps, mi_hpc iface0) @@ -1638,7 +1639,7 @@ mkIfaceAnnCache anns pair (IfaceAnnotation target value) = (case target of NamedTarget occn -> occn - ModuleTarget _ -> mkVarOcc "module" + ModuleTarget _ -> mkVarOccFS (fsLit "module") , [value]) -- flipping (++), so the first argument is always short env = mkOccEnv_C (flip (++)) (map pair anns) diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index cf37095041..d53fddb943 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -144,6 +144,7 @@ import GHC.Linker.Types import GHC.Types.Id import GHC.Types.ForeignStubs import GHC.Data.Maybe +import GHC.Data.FastString import Control.Monad.Trans.State.Strict import Data.List (intercalate) @@ -244,7 +245,7 @@ sptModuleInitCode platform this_mod entries = initializerCStub platform init_fn_nm empty init_fn_body `mappend` finalizerCStub platform fini_fn_nm empty fini_fn_body where - init_fn_nm = mkInitializerStubLabel this_mod "spt" + init_fn_nm = mkInitializerStubLabel this_mod (fsLit "spt") init_fn_body = vcat [ text "static StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi @@ -260,7 +261,7 @@ sptModuleInitCode platform this_mod entries = | (i, SptEntry n fp) <- zip [0..] entries ] - fini_fn_nm = mkFinalizerStubLabel this_mod "spt" + fini_fn_nm = mkFinalizerStubLabel this_mod (fsLit "spt") fini_fn_body = vcat [ text "StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 7b7ab4f4c8..cc2dcf2749 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -67,7 +67,7 @@ import GHC.Prelude import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS, occNameString) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error ( GhcHint(..) ) @@ -3885,8 +3885,7 @@ modid :: { LocatedA ModuleName } : CONID { sL1a $1 $ mkModuleNameFS (getCONID $1) } | QCONID { sL1a $1 $ let (mod,c) = getQCONID $1 in mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) + (concatFS [mod, fsLit ".", c]) } commas :: { ([SrcSpan],Int) } -- One or more commas diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 8e08a8c874..2dd8e06b3e 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1816,7 +1816,7 @@ instance DisambECP (HsExpr GhcPs) where rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs -hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") +hsHoleExpr anns = HsUnboundVar anns (mkVarOccFS (fsLit "_")) type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 9e7decb2ff..4d22a994e9 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -28,6 +28,7 @@ module GHC.Rename.Expr ( ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS , rnMatchGroup, rnGRHS, makeMiniFixityEnv) @@ -2692,7 +2693,7 @@ getMonadFailOp ctxt | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName - let arg_lit = mkVarOcc "arg" + let arg_lit = mkVarOccFS (fsLit "arg") arg_name <- newSysName arg_lit let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 3acebb5894..75a6123891 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1048,7 +1048,7 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do -- Get all the constraints required of a dictionary binding getDictionaryBindings :: PredType -> TcM CtEvidence getDictionaryBindings theta = do - dictName <- newName (mkDictOcc (mkVarOcc "magic")) + dictName <- newName (mkDictOcc (mkVarOccFS (fsLit "magic"))) let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 5189e5bec4..e578c25357 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -21,6 +21,7 @@ module GHC.Runtime.Loader ( ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Ppr @@ -46,7 +47,7 @@ import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing -import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) +import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName , greMangledName, mkRdrQual ) @@ -136,14 +137,14 @@ loadPlugins hsc_env where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env (plugin, _iface, links, pkgs) - <- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName + <- loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName hsc_env mod_name return (plugin, links, pkgs) diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 8ec874da41..5590e29454 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -82,7 +82,7 @@ import GHC.Builtin.Utils (knownKeyNames) import GHC.Tc.Errors.Hole.FitTypes import qualified Data.Set as Set import GHC.Types.SrcLoc -import GHC.Data.FastString (unpackFS) +import GHC.Data.FastString (NonDetFastString(..)) import GHC.Types.Unique.Map @@ -482,15 +482,16 @@ addHoleFitDocs fits = Just m -> Right m Nothing -> Left $ case nameSrcLoc name of - RealSrcLoc r _ -> unpackFS $ srcLocFile r - UnhelpfulLoc s -> unpackFS $ s + -- Nondeterminism is fine, this is used only to display a warning + RealSrcLoc r _ -> NonDetFastString $ srcLocFile r + UnhelpfulLoc s -> NonDetFastString s report mods = do { let warning = text "WARNING: Couldn't find any documentation for the following modules:" $+$ nest 2 - (pprWithCommas (either text ppr) (Set.toList mods) $+$ + (pprWithCommas (either ppr ppr) (Set.toList mods) $+$ text "Make sure the modules are compiled with '-haddock'.") - ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ()) + ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ()) } -- For pretty printing hole fits, we display the name and type of the fit, diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index cfc5454e54..6b141d9173 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -26,6 +26,7 @@ module GHC.Tc.Gen.Sig( ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Backend @@ -246,7 +247,7 @@ tcUserTypeSig loc hs_sig_ty mb_name where name = case mb_name of Just n -> n - Nothing -> mkUnboundName (mkVarOcc "<expression>") + Nothing -> mkUnboundName (mkVarOccFS (fsLit "<expression>")) ctxt_rrc = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty) ctxt_no_rrc = ctxt_fn NoRRC diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index 3c5343722e..e0bcfa8428 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -190,7 +190,7 @@ mkModIdBindings :: TcM TcGblEnv mkModIdBindings = do { mod <- getModule ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc + ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc ; trModuleTyCon <- tcLookupTyCon trModuleTyConName ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 2e9b3c1809..a448d550ac 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -787,8 +787,8 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty = do { let loc' = locA loc - ; rr_name <- newNameAt (mkTyVarOcc "rep") loc' - ; tv_name <- newNameAt (mkTyVarOcc "r") loc' + ; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc' + ; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (mkTYPEapp rr) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 8319212147..2f61ff8777 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1921,7 +1921,7 @@ emitAnonTypeHole extra_constraints tv , hole_loc = ct_loc } ; emitHole hole } where - occ = mkTyVarOcc "_" + occ = mkTyVarOccFS (fsLit "_") sort | YesExtraConstraint <- extra_constraints = ConstraintHole | otherwise = TypeHole diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 4dc4161664..97f9a8384f 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -21,6 +21,7 @@ module GHC.Tc.Validity ( ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Data.Maybe @@ -2274,7 +2275,7 @@ checkConsistentFamInst (InClsInst { ai_class = clas tidyTypes tidy_env2 ax_arg_tys mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan + tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan -- For check_match, bind_me, see -- Note [Matching in the consistent-instantiation check] diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index b38cde14a1..99ea5dddb0 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1320,7 +1320,7 @@ mkFCallId uniq fcall ty -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! - name = mkFCallName uniq occ_str + name = mkFCallName uniq (mkFastString occ_str) info = noCafIdInfo `setArityInfo` arity diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 9f82fd42a8..8176bec011 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -493,8 +493,8 @@ mkSysTvName :: Unique -> FastString -> Name mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) -- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan +mkFCallName :: Unique -> FastString -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOccFS str) noSrcSpan -- The encoded string completely describes the ccall -- When we renumber/rename things, we need to be diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index fcd6a63a28..c2d36c5c0e 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -49,7 +49,6 @@ import GHC.Data.Maybe import GHC.Data.Graph.Directed import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Types.SourceFile ( hscSourceString ) @@ -278,8 +277,8 @@ showModMsg dflags recomp (ModuleNode _ mod_summary) = where op = normalise - mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = moduleNameString (moduleName (ms_mod mod_summary)) ++ + hscSourceString (ms_hsc_src mod_summary) dyn_file = op $ msDynObjFilePath mod_summary obj_file = op $ msObjFilePath mod_summary files = [ obj_file ] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index f697073763..3e1bc227d1 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -2554,7 +2554,7 @@ isSafeModule m = do (GHC.moduleNameString $ GHC.moduleName m)) (msafe, pkgs) <- GHC.moduleTrustReqs m - let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface + let trust = show $ getSafeMode $ GHC.mi_trust $ fromJust iface pkg = if packageTrusted hsc_env m then "trusted" else "untrusted" (good, bad) = tallyPkgs hsc_env pkgs @@ -2998,7 +2998,7 @@ showOptions show_all then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) - getDynFlags >>= liftIO . showDynFlags show_all + liftIO $ showDynFlags show_all dflags showDynFlags :: Bool -> DynFlags -> IO () @@ -3215,9 +3215,9 @@ unsetOptions str no_flag ('-':'X':rest) = return ("-XNo" ++ rest) no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f)) - in if (not (null rest3)) - then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'")) - else do + in case rest3 of + opt:_ -> liftIO (putStrLn ("unknown option: '" ++ opt ++ "'")) + [] -> do mapM_ (fromJust.flip lookup defaulters) other_opts mapM_ unsetOpt plus_opts diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index aae605efa8..3e6b834e11 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -502,8 +502,8 @@ initInterpBuffering = do mkHelperExpr occ = GHC.compileParsedExprRemote $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ - nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering" - flush <- mkHelperExpr $ mkVarOcc "flushAll" + nobuf <- mkHelperExpr $ mkVarOccFS (fsLit "disableBuffering") + flush <- mkHelperExpr $ mkVarOccFS (fsLit "flushAll") return (nobuf, flush) -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter @@ -532,7 +532,7 @@ mkEvalWrapper progname' args' = where nlHsString = nlHsLit . mkHsString evalWrapper' = - GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper") + GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper")) -- | Run a 'GhcMonad' action to compile an expression for internal usage. runInternal :: GhcMonad m => m a -> m a diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs index f1d55eab15..ebf2d5ebab 100644 --- a/ghc/GHCi/UI/Tags.hs +++ b/ghc/GHCi/UI/Tags.hs @@ -16,16 +16,14 @@ module GHCi.UI.Tags ( import GHC.Utils.Exception import GHC import GHCi.UI.Monad -import GHC.Utils.Outputable -- ToDo: figure out whether we need these, and put something appropriate -- into the GHC API instead import GHC.Types.Name (nameOccName) -import GHC.Types.Name.Occurrence (pprOccName) +import GHC.Types.Name.Occurrence (occNameString) import GHC.Core.ConLike import GHC.Utils.Monad -import GHC.Unit.State -import GHC.Driver.Env +import GHC.Data.FastString import Control.Monad import Data.Function @@ -34,7 +32,6 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ord import GHC.Driver.Phases -import GHC.Driver.Ppr import GHC.Utils.Panic import Prelude import System.Directory @@ -97,14 +94,10 @@ listModuleTags m = do case mbModInfo of Nothing -> return [] Just mInfo -> do - dflags <- getDynFlags - unit_state <- hsc_units <$> getSession - mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo - let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual let names = fromMaybe [] $ GHC.modInfoTopLevelScope mInfo let localNames = filter ((m==) . nameModule) names mbTyThings <- mapM GHC.lookupName localNames - return $! [ tagInfo dflags unit_state unqual exported kind name realLoc + return $! [ tagInfo exported kind name realLoc | tyThing <- catMaybes mbTyThings , let name = getName tyThing , let exported = GHC.modInfoIsExportedName mInfo name @@ -133,13 +126,12 @@ data TagInfo = TagInfo -- get tag info, for later translation into Vim or Emacs style -tagInfo :: DynFlags -> UnitState -> PrintUnqualified - -> Bool -> Char -> Name -> RealSrcLoc +tagInfo :: Bool -> Char -> Name -> RealSrcLoc -> TagInfo -tagInfo dflags unit_state unqual exported kind name loc +tagInfo exported kind name loc = TagInfo exported kind - (showSDocForUser dflags unit_state unqual $ pprOccName (nameOccName name)) - (showSDocForUser dflags unit_state unqual $ ftext (srcLocFile loc)) + (occNameString $ nameOccName name) + (unpackFS (srcLocFile loc)) (srcLocLine loc) (srcLocCol loc) Nothing -- throw an exception when someone tries to overwrite existing source file (fix for #10989) |