From 5bca72372c6596012685063cb14cc4c6848fbc74 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 29 Jul 2002 10:50:44 +0000 Subject: [PATCH] [project @ 2002-07-29 10:50:43 by simonmar] Type variables created by the typechecker didn't have the correct NameSpace: they were in the Var namespace rather than the TyVar namespace, which can lead to strange warnings about quantified type variables being not mentioned in the type when DEBUG is on. Name: - added mkSystemNameEncoded for use when the string is already encoded (saves re-encoding the string every time) - added mkSystemTvNameEncoded for making a type variable name, as above Var: - use mkSystemTvNameEncoded when making type variables Id: - add mkSysLocalUnencoded for the (rare) case when the string needs encoding TcMType: - use mkSystemTvNameEncoded rather than mkSystemName for making type variables SetLevels: - use mkSysLocalUnencoded since the names generated here need encoding. --- ghc/compiler/basicTypes/Id.lhs | 10 +++++++--- ghc/compiler/basicTypes/Name.lhs | 19 ++++++++++++++++--- ghc/compiler/basicTypes/Var.lhs | 4 ++-- ghc/compiler/simplCore/SetLevels.lhs | 7 ++++--- ghc/compiler/typecheck/TcMType.lhs | 13 +++++++------ 5 files changed, 36 insertions(+), 17 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 45b8b42..2ef248a 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 6993cec..035a499 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 deff82a..8002471 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 5c9cb1e..6108b8b 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 faa7827..c13993a 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 -- 1.7.10.4