[project @ 2000-10-12 15:26:48 by simonpj]

Work on initialisation of persistent compiler state

4 files changed, 46 insertions, 50 deletions

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 8de66e1b1e..9259a52b96 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 8535b67150..f18b11e396 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 168d04c7cf..0e16ea4f0f 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 37639feb47..6f8c17cb86 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 ()