From 0a25e90a913d0381b7e706bd59aff4c787bad3db Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 12 Oct 2000 15:26:48 +0000 Subject: [PATCH 1/1] [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 8de66e1..9259a52 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 8535b67..f18b11e 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 168d04c..0e16ea4 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 37639fe..6f8c17c 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 () -- 1.7.10.4