Commit 9fc29e6e authored by simonpj's avatar simonpj
Browse files

[project @ 2000-12-07 08:22:53 by simonpj]

Tidy up the Persistent Renamer State structure a little
parent 27508567
......@@ -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)
}
)
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment