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

Work on initialisation of persistent compiler state

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 8de66e1..9259a52 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 ()