diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 45b8b4260ba0c7b5aa7efe1e9b78d04e0d869b59..2ef248a02ac03197359d5d9294baf0fc826c5440 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -9,7 +9,7 @@ module Id ( -- Simple construction mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, - mkSysLocal, mkUserLocal, mkVanillaGlobal, + mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkWorkerId, @@ -99,7 +99,7 @@ import IdInfo import qualified Demand ( Demand ) import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) import Name ( Name, OccName, - mkSystemName, mkInternalName, + mkSystemName, mkSystemNameEncoded, mkInternalName, getOccName, getSrcLoc ) import OccName ( EncodedFS, mkWorkerOcc ) @@ -162,7 +162,11 @@ mkVanillaGlobal :: Name -> Type -> IdInfo -> Id -- for SysLocal, we assume the base name is already encoded, to avoid -- re-encoding the same string over and over again. -mkSysLocal fs uniq ty = mkLocalId (mkSystemName uniq fs) ty +mkSysLocal fs uniq ty = mkLocalId (mkSystemNameEncoded uniq fs) ty + +-- version to use when the faststring needs to be encoded +mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs) ty + mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 6993cec2f740abb2a983a1711598f0e9d1210aab..035a499b4c5f5422489c1621e5bee25e500841be 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,7 +10,8 @@ module Name ( -- The Name type Name, -- Abstract - mkInternalName, mkSystemName, mkFCallName, + mkInternalName, mkSystemName, + mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName, mkIPName, mkExternalName, mkKnownKeyExternalName, mkWiredInName, @@ -175,9 +176,21 @@ mkKnownKeyExternalName rdr_name uniq mkWiredInName :: Module -> OccName -> Unique -> Name mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc -mkSystemName :: Unique -> EncodedFS -> Name +mkSystemName :: Unique -> UserFS -> Name mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, - n_occ = mkVarOcc fs, n_loc = noSrcLoc } + n_occ = mkVarOcc fs, n_loc = noSrcLoc } + +-- Use this version when the string is already encoded. Avoids duplicating +-- the string each time a new name is created. +mkSystemNameEncoded :: Unique -> EncodedFS -> Name +mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkSysOccFS varName fs, + n_loc = noSrcLoc } + +mkSystemTvNameEncoded :: Unique -> EncodedFS -> Name +mkSystemTvNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkSysOccFS tvName fs, + n_loc = noSrcLoc } mkFCallName :: Unique -> EncodedString -> Name -- The encoded string completely describes the ccall diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index deff82acda7222770ce1dbb87b6bfaa77ed6cb50..8002471377ccc7de852373870ef94e2ec85e4c09 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -41,7 +41,7 @@ import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, - mkSystemName + mkSystemTvNameEncoded, ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import FastTypes @@ -195,7 +195,7 @@ mkSysTyVar uniq kind = Var { varName = name , varInfo = pprPanic "mkSysTyVar" (ppr name) } where - name = mkSystemName uniq FSLIT("t") + name = mkSystemTvNameEncoded uniq FSLIT("t") newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar newMutTyVar name kind details diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 5c9cb1e15bffa375d1766ae71f46d15c7d2901dc..6108b8ba9973c27a95063b7fe95b84a2acce45a1 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -58,7 +58,8 @@ import CmdLineOpts ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes ) import CoreFVs -- all of it import Subst -import Id ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo, +import Id ( Id, idType, mkSysLocalUnencoded, + isOneShotLambda, zapDemandIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) import IdInfo ( workerExists, vanillaIdInfo, ) @@ -771,7 +772,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs in returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) where - mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty + mk_poly_bndr bndr uniq = mkSysLocalUnencoded (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameUserString (getOccName bndr) poly_ty = mkPiTypes abs_vars (idType bndr) @@ -782,7 +783,7 @@ newLvlVar :: String -> LvlM Id newLvlVar str vars body_ty = getUniqueUs `thenLvl` \ uniq -> - returnUs (mkSysLocal (mkFastString str) uniq (mkPiTypes vars body_ty)) + returnUs (mkSysLocalUnencoded (mkFastString str) uniq (mkPiTypes vars body_ty)) -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index faa782746be9760c5b43e4ebc2ef5dbcac13d513..c13993a808e39a2a91ba17536bff10d0453f1464 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -82,8 +82,9 @@ import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) import ForeignCall ( Safety(..) ) import FunDeps ( grow ) import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred ) -import Name ( Name, NamedThing(..), setNameUnique, mkSystemName, - mkInternalName, mkDerivedTyConOcc +import Name ( Name, NamedThing(..), setNameUnique, + mkInternalName, mkDerivedTyConOcc, + mkSystemTvNameEncoded, ) import VarSet import BasicTypes ( Boxity(Boxed) ) @@ -106,7 +107,7 @@ import Outputable newTyVar :: Kind -> NF_TcM TcTyVar newTyVar kind = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSystemName uniq FSLIT("t")) kind VanillaTv + tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv newTyVarTy :: Kind -> NF_TcM TcType newTyVarTy kind @@ -119,7 +120,7 @@ newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) newKindVar :: NF_TcM TcKind newKindVar = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSystemName uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv -> + tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv -> returnNF_Tc (TyVarTy kv) newKindVars :: Int -> NF_TcM [TcKind] @@ -128,7 +129,7 @@ newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) newBoxityVar :: NF_TcM TcKind newBoxityVar = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSystemName uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv -> + tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv -> returnNF_Tc (TyVarTy kv) \end{code} @@ -142,7 +143,7 @@ newBoxityVar \begin{code} newHoleTyVarTy :: NF_TcM TcType = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSystemName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv -> + tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv -> returnNF_Tc (TyVarTy tv) readHoleResult :: TcType -> NF_TcM TcType