From 9fc29e6eedbb0cee53960a0664d99c0b2c33f3d7 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 7 Dec 2000 08:22:53 +0000 Subject: [PATCH] [project @ 2000-12-07 08:22:53 by simonpj] Tidy up the Persistent Renamer State structure a little --- ghc/compiler/main/HscMain.lhs | 8 ++++---- ghc/compiler/main/HscTypes.lhs | 7 ++++--- ghc/compiler/rename/RnEnv.lhs | 41 ++++++++++++++++++++++----------------- ghc/compiler/rename/RnMonad.lhs | 34 +++++++++++++------------------- 4 files changed, 44 insertions(+), 46 deletions(-) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 3302937..aa407b1 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -27,7 +27,7 @@ import StringBuffer ( hGetStringBuffer ) import Parser import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) -import Rename +import Rename ( checkOldIface, renameModule, renameExpr, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelNames ( knownKeyNames ) @@ -525,12 +525,12 @@ initPersistentCompilerState initPersistentRenamerState :: IO PersistentRenamerState = do ns <- mkSplitUniqSupply 'r' return ( - PRS { prsOrig = Orig { origNames = initOrigNames, + PRS { prsOrig = Orig { origNS = ns, + origNames = initOrigNames, origIParam = emptyFM }, prsDecls = (emptyNameEnv, 0), prsInsts = (emptyBag, 0), - prsRules = (emptyBag, 0), - prsNS = ns + prsRules = (emptyBag, 0) } ) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index e2a83c6..8284e2f 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -460,8 +460,7 @@ data PersistentRenamerState = PRS { prsOrig :: OrigNameEnv, prsDecls :: DeclsMap, prsInsts :: IfaceInsts, - prsRules :: IfaceRules, - prsNS :: UniqSupply + prsRules :: IfaceRules } \end{code} @@ -479,7 +478,9 @@ we just store junk. Then when we find the binding site, we fix it up. \begin{code} data OrigNameEnv - = Orig { origNames :: OrigNameNameEnv, + = Orig { origNS :: UniqSupply, + -- Supply of uniques + origNames :: OrigNameNameEnv, -- Ensures that one original name gets one unique origIParam :: OrigNameIParamEnv -- Ensures that one implicit parameter name gets one unique diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 40dc61a..0dc76fe 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -16,7 +16,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ImportReason(..), GlobalRdrEnv, AvailEnv, - AvailInfo, Avails, GenAvailInfo(..) ) + AvailInfo, Avails, GenAvailInfo(..), OrigNameEnv(..) ) import RnMonad import Name ( Name, NamedThing(..), getSrcLoc, @@ -67,10 +67,11 @@ newTopBinder mod rdr_name loc returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + getNameSupplyRn `thenRn` \ name_supply -> let occ = rdrNameOcc rdr_name key = (moduleName mod, occ) + cache = origNames name_supply in case lookupFM cache key of @@ -85,7 +86,7 @@ newTopBinder mod rdr_name loc new_name = setNameModuleAndLoc name mod loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us, new_cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {origNames = new_cache}) `thenRn_` traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name @@ -94,12 +95,12 @@ newTopBinder mod rdr_name loc -- Even for locally-defined names we use implicitImportProvenance; -- updateProvenances will set it to rights Nothing -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (origNS name_supply) uniq = uniqFromSupply us1 new_name = mkGlobalName uniq mod occ loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us', new_cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {origNS = us', origNames = new_cache}) `thenRn_` traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -123,32 +124,36 @@ newGlobalName :: ModuleName -> OccName -> RnM d Name -- (but since it affects DLL-ery it does matter that we get it right -- in the end). newGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + = getNameSupplyRn `thenRn` \ name_supply -> let key = (mod_name, occ) + cache = origNames name_supply in case lookupFM cache key of Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` returnRn name - Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_` - -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` + Nothing -> setNameSupplyRn (name_supply {origNS = us', origNames = new_cache}) `thenRn_` + -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` returnRn name where - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (origNS name_supply) uniq = uniqFromSupply us1 mod = mkVanillaModule mod_name name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name newIPName rdr_name - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + = getNameSupplyRn `thenRn` \ name_supply -> + let + ipcache = origIParam name_supply + in case lookupFM ipcache key of Just name -> returnRn name - Nothing -> setNameSupplyRn (us', cache, new_ipcache) `thenRn_` + Nothing -> setNameSupplyRn (name_supply {origNS = us', origIParam = new_ipcache}) `thenRn_` returnRn name where - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (origNS name_supply) uniq = uniqFromSupply us1 name = mkIPName uniq key new_ipcache = addToFM ipcache key name @@ -298,16 +303,16 @@ lookupSysBinder rdr_name newLocalsRn :: [(RdrName,SrcLoc)] -> RnMS [Name] newLocalsRn rdr_names_w_loc - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + = getNameSupplyRn `thenRn` \ name_supply -> let n = length rdr_names_w_loc - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (origNS name_supply) uniqs = uniqsFromSupply n us1 names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (us', cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {origNS = us'}) `thenRn_` returnRn names @@ -353,13 +358,13 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a bindCoreLocalRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + getNameSupplyRn `thenRn` \ name_supply -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (origNS name_supply) uniq = uniqFromSupply us1 name = mkLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {origNS = us'}) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 51319d1..2fae263 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -37,7 +37,7 @@ import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) import HscTypes ( AvailEnv, lookupType, - OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, + OrigNameEnv(..), WhetherHasOrphans, ImportVersion, PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, IfaceInsts, IfaceRules, @@ -141,9 +141,7 @@ data RnDown -- so it has a Module, so it can be looked up rn_errs :: IORef Messages, - - -- The second and third components are a flattened-out OrigNameEnv - rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv), + rn_ns :: IORef OrigNameEnv, rn_ifaces :: IORef Ifaces } @@ -333,10 +331,7 @@ initRn dflags hit hst pcs mod do_rn -- and we don't want thereby to try to suck it in! iVSlurp = (emptyModuleSet, emptyNameSet) } - let uniqs = prsNS prs - - names_var <- newIORef (uniqs, origNames (prsOrig prs), - origIParam (prsOrig prs)) + names_var <- newIORef (prsOrig prs) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef ifaces let rn_down = RnDown { rn_mod = mod, @@ -355,15 +350,13 @@ initRn dflags hit hst pcs mod do_rn res <- do_rn rn_down () -- Grab state and record it - (warns, errs) <- readIORef errs_var - new_ifaces <- readIORef iface_var - (new_NS, new_origN, new_origIP) <- readIORef names_var - let new_orig = Orig { origNames = new_origN, origIParam = new_origIP } + (warns, errs) <- readIORef errs_var + new_ifaces <- readIORef iface_var + new_orig <- readIORef names_var let new_prs = prs { prsOrig = new_orig, prsDecls = iDecls new_ifaces, prsInsts = iInsts new_ifaces, - prsRules = iRules new_ifaces, - prsNS = new_NS } + prsRules = iRules new_ifaces } let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } @@ -409,8 +402,7 @@ renameDerivedCode dflags mod prs thing_inside -- and that doesn't happen in pragmas etc do { us <- mkSplitUniqSupply 'r' - ; names_var <- newIORef (us, origNames (prsOrig prs), - origIParam (prsOrig prs)) + ; names_var <- newIORef ((prsOrig prs) { origNS = us }) ; errs_var <- newIORef (emptyBag,emptyBag) ; let rn_down = RnDown { rn_dflags = dflags, @@ -613,21 +605,21 @@ getTypeEnvRn down l_down = return (rn_done down) %===================== \begin{code} -getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) +getNameSupplyRn :: RnM d OrigNameEnv getNameSupplyRn rn_down l_down = readIORef (rn_ns rn_down) -setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d () +setNameSupplyRn :: OrigNameEnv -> RnM d () setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeIORef names_var names' getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, cache, ipcache) -> + = readIORef names_var >>= \ ns -> let - (us1,us') = splitUniqSupply us + (us1,us') = splitUniqSupply (origNS ns) in - writeIORef names_var (us', cache, ipcache) >> + writeIORef names_var (ns {origNS = us'}) >> return (uniqFromSupply us1) \end{code} -- 1.7.10.4