From 0a25e90a913d0381b7e706bd59aff4c787bad3db Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 12 Oct 2000 15:26:48 +0000
Subject: [PATCH] [project @ 2000-10-12 15:26:48 by simonpj] Work on
initialisation of persistent compiler state
---
ghc/compiler/main/HscMain.lhs | 21 ++++++++-----------
ghc/compiler/main/HscTypes.lhs | 8 ++++----
ghc/compiler/prelude/PrelInfo.lhs | 33 +++++++++++++++---------------
ghc/compiler/rename/RnMonad.lhs | 34 +++++++++++++++----------------
4 files changed, 46 insertions(+), 50 deletions(-)
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 8de66e1b1e21..9259a52b96a5 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -98,7 +98,6 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface
(ppSourceStats False rdr_module) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
- mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
@@ -248,24 +247,22 @@ initPersistentCompilerState
pcsPRS = initPersistentRenamerState }
initPackageDetails :: PackageSymbolTable
-initPackageDetails = extendTypeEnv emptyModuleEnv (map ATyCon wiredInTyCons)
+initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
initPersistentRenamerState :: PersistentRenamerState
- = PRS { prsNS = NS { nsNames = initRenamerNames,
- nsIParam = emptyFM },
+ = PRS { prsOrig = Orig { origNames = initOrigNames,
+ origIParam = emptyFM },
prsDecls = emptyNameEnv,
prsInsts = emptyBag,
prsRules = emptyBag
}
-initRenamerNames :: FiniteMap (ModuleName,OccName) Name
-initRenamerNames = grag wiredIn_in `plusFM` listToFM known_key
- where
- wired_in = [ ((moduleName (nameModule name), nameOccName name), name)
- | name <- wiredInNames ]
-
- known_key = [ ((rdrNameModule rdr_name, rdrNameOcc rdr_name), mkKnownKeyGlobal rdr_name uniq)
- | (rdr_name, uniq) <- knownKeyRdrNames ]
+initOrigNames :: FiniteMap (ModuleName,OccName) Name
+initOrigNames = grab knownKeyNames `plusFM` grab wiredInNames
+ where
+ grab names = foldl add emptyFM names
+ add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
+\end{code}
%************************************************************************
%* *
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 8535b671507a..f18b11e396f8 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -232,15 +232,15 @@ It contains:
\begin{code}
data PersistentRenamerState
- = PRS { prsNS :: NameSupply,
+ = PRS { prsOrig :: OrigNameEnv,
prsDecls :: DeclsMap,
prsInsts :: IfaceInsts,
prsRules :: IfaceRules,
}
-data NameSupply
- = NS { nsNames :: FiniteMap (Module,OccName) Name -- Ensures that one original name gets one unique
- nsIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique
+data OrigNameEnv
+ = Orig { origNames :: FiniteMap (Module,OccName) Name -- Ensures that one original name gets one unique
+ origIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique
}
type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl))
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 168d04c7cff6..0e16ea4f0ff3 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -9,6 +9,7 @@ module PrelInfo (
module MkId,
wiredInNames, -- Names of wired in things
+ wiredInThings,
-- Primop RdrNames
@@ -59,30 +60,28 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and
@Classes@, the other to look up values.
\begin{code}
-wiredInNames :: [Name]
-wiredInNames
- = bagToList $ unionManyBags
+wiredInThings :: [TyThing]
+wiredInThings
+ = concat
[ -- Wired in TyCons
- unionManyBags (map getTyConNames ([funTyCon] ++ primTyCons ++ wiredInTyCons))
+ map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons)
-- Wired in Ids
- , listToBag (map getName wiredInIds)
+ , map AnId wiredInIds
-- PrimOps
- , listToBag (map (getName . mkPrimOpId) allThePrimOps)
+ , map (AnId . mkPrimOpId)) allThePrimOps
]
-\end{code}
-
-\begin{code}
-getTyConNames :: TyCon -> Bag Name
-getTyConNames tycon
- = getName tycon `consBag`
- unionManyBags (map get_data_con_names (tyConDataConsIfAvailable tycon))
- -- Synonyms return empty list of constructors
- where
- get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker
- getName (dataConWrapId dc)] -- Wrapper
+wiredInNames :: [Name]
+wiredInNames = [n | thing <- wiredInThings, n <- tyThingNames]
+
+tyThingNames :: TyCon -> [Name]
+tyThingNames (AnClass cl) = pprPanic "tyThingNames" (ppr cl) -- Not used
+tyThingNames (AnId id) = [getName id]
+tyThingNames (ATyCon tc) = getName tycon : [ getName n | dc <- tyConDataConsIfAvailable tycon,
+ n <- [dataConId dc, dataConWrapId dc] ]
+ -- Synonyms return empty list of constructors
\end{code}
We let a lot of "non-standard" values be visible, so that we can make
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 37639feb473d..6f8c17cb864a 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -115,7 +115,7 @@ data RnDown
-- this module
rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
- rn_ns :: IORef NameSupply,
+ rn_ns :: IORef (UniqSupply, OrigNameEnv),
rn_ifaces :: IORef Ifaces
}
@@ -328,22 +328,22 @@ initRn :: DynFlags -> Finder -> GlobalSymbolTable
-> PersistentRenamerState
-> Module -> SrcLoc
-initRn dflags finder gst prs mod loc do_rn = do
- names_var <- newIORef (prsNS pcs)
- errs_var <- newIORef (emptyBag,emptyBag)
- iface_var <- newIORef (initIfaces prs)
- let
- rn_down = RnDown { rn_mod = mod,
- rn_loc = loc,
-
- rn_finder = finder,
- rn_dflags = dflags,
- rn_gst = gst,
-
- rn_ns = names_var,
- rn_errs = errs_var,
- rn_ifaces = iface_var,
- }
+initRn dflags finder gst prs mod loc do_rn
+ = do { uniqs <- mkSplitUniqSupply 'r'
+ names_var <- newIORef (uniqs, prsOrig pcs)
+ errs_var <- newIORef (emptyBag,emptyBag)
+ iface_var <- newIORef (initIfaces prs)
+ let rn_down = RnDown { rn_mod = mod,
+ rn_loc = loc,
+
+ rn_finder = finder,
+ rn_dflags = dflags,
+ rn_gst = gst,
+
+ rn_ns = names_var,
+ rn_errs = errs_var,
+ rn_ifaces = iface_var,
+ }
-- do the business
res <- do_rn rn_down ()
--
GitLab