[project @ 2000-10-12 15:05:59 by simonpj]

More of Simon

[project @ 2000-10-12 15:05:59 by simonpj]
More of Simon
db7db1b4 · simonpj · 90a24e7d · db7db1b4 · db7db1b4 · db7db1b4
Commit db7db1b4 authored Oct 12, 2000 by simonpj
5 changed files
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -49,6 +49,13 @@ import NativeInfo       ( os, arch )
 import StgInterp	( runStgI )
 \end{code}

+
+%************************************************************************
+%*									*
+\subsection{The main compiler pipeline}
+%*									*
+%************************************************************************
+
 \begin{code}
 hscMain
  :: DynFlags	
@@ -223,7 +230,50 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface
      = if opt_D_show_passes
 	then \ what -> hPutStr stderr ("*** "++what++":\n")
 	else \ what -> return ()
+\end{code}
+

+%************************************************************************
+%*									*
+\subsection{Initial persistent state}
+%*									*
+%************************************************************************
+
+\begin{code}
+initPersistentCompilerState :: PersistentCompilerState
+initPersistentCompilerState 
+  = PCS { pcsPST   = initPackageDetails,
+	  pcsInsts = emptyInstEnv,
+	  pcsRules = emptyRuleEnv,
+	  pcsPRS   = initPersistentRenamerState }
+
+initPackageDetails :: PackageSymbolTable
+initPackageDetails = extendTypeEnv emptyModuleEnv (map ATyCon wiredInTyCons)
+
+initPersistentRenamerState :: PersistentRenamerState
+  = PRS { prsNS    = NS { nsNames  = initRenamerNames,
+			  nsIParam = 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 ]
+
+%************************************************************************
+%*									*
+\subsection{Statistics}
+%*									*
+%************************************************************************
+
+\begin{code}
 ppSourceStats short (HsModule name version exports imports decls _ src_loc)
 = (if short then hcat else vcat)
        (map pp_val

--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -22,16 +22,29 @@ A @ModDetails@ summarises everything we know about a compiled module
 \begin{code}
 data ModDetails
   = ModDetails {
+	moduleId      :: Module,
        moduleExports :: Avails,		-- What it exports
        moduleEnv     :: GlobalRdrEnv,		-- Its top level environment

        fixityEnv     :: NameEnv Fixity,
 	deprecEnv     :: NameEnv DeprecTxt,
-        typeEnv       :: NameEnv TyThing,	-- TyThing is in TcEnv.lhs
+        typeEnv       :: TypeEnv,

        instEnv       :: InstEnv,
-        ruleEnv       :: IdEnv [CoreRule]	-- Domain includes Ids from other modules
+        ruleEnv       :: RuleEnv		-- Domain may include Id from other modules
     }
+
+emptyModDetails :: Module -> ModuleDetails
+emptyModDetails mod
+  = ModDetails { moduleId      = mod,
+		 moduleExports = [],
+		 moduleEnv     = emptyRdrEnv,
+		 fixityEnv     = emptyNameEnv,
+		 deptecEnv     = emptyNameEnv,
+		 typeEnv       = emptyNameEnv,
+		 instEnv       = emptyInstEnv,
+    }		 ruleEnv       = emptyRuleEnv
+		
 \end{code}

 Symbol tables map modules to ModDetails:
@@ -55,12 +68,60 @@ lookupFixityEnv tbl name
 	Just details -> case lookupNameEnv (fixityEnv details) name of
 				Just fixity -> fixity
 				Nothing	    -> defaultFixity
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Type environment stuff}
+%*									*
+%************************************************************************
+
+\begin{code}
+type TypeEnv = NameEnv TyThing
+
+data TyThing = AnId   Id
+	     | ATyCon TyCon
+	     | AClass Class

+instance NamedThing TyThing where
+  getName (AnId id)   = getName id
+  getName (ATyCon tc) = getName tc
+  getName (AClass cl) = getName cl
+\end{code}
+
+
+\begin{code}
 lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
 lookupTypeEnv tbl name
  = case lookupModuleEnv tbl (nameModule name) of
 	Just details -> lookupNameEnv (typeEnv details) name
 	Nothing	     -> Nothing
+
+
+groupTyThings :: [TyThing] -> [(Module, TypeEnv)]
+groupTyThings things
+  = fmToList (foldl add emptyFM things)
+  where
+    add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
+    add tbl thing = addToFM tbl mod new_env
+		  where
+		    name    = getName thing
+		    mod     = nameModule name
+		    new_env = case lookupFM tbl mod of
+				Nothing  -> unitNameEnv name thing
+				Just env -> extendNameEnv env name thing
+		
+extendTypeEnv :: SymbolTable -> [TyThing] -> SymbolTable
+extendTypeEnv tbl things
+  = foldl add tbl (groupTyThings things)
+  where
+    add tbl (mod,type_env)
+	= extendModuleEnv mod new_details
+	where
+	  new_details = case lookupModuleEnv tbl mod of
+			    Nothing      -> emptyModDetails mod {typeEnv = type_env}
+			    Just details -> details {typeEnv = typeEnv details `plusNameEnv` type_env})
 \end{code}


@@ -74,10 +135,6 @@ These types are defined here because they are mentioned in ModDetails,
 but they are mostly elaborated elsewhere

 \begin{code}
-data TyThing = AnId   Id
-	     | ATyCon TyCon
-	     | AClass Class
-
 type DeprecationEnv = NameEnv DeprecTxt		-- Give reason for deprecation

 type GlobalRdrEnv = RdrNameEnv [Name]	-- The list is because there may be name clashes
@@ -86,6 +143,8 @@ type GlobalRdrEnv = RdrNameEnv [Name]	-- The list is because there may be name c

 type InstEnv    = UniqFM ClsInstEnv		-- Maps Class to instances for that class
 type ClsInstEnv = [(TyVarSet, [Type], Id)]	-- The instances for a particular class
+
+type RuleEnv    = IdEnv [CoreRule]
 \end{code}


@@ -143,6 +202,11 @@ data ModIFace
 data PersistentCompilerState 
   = PCS {
        pcsPST :: PackageSymbolTable,		-- Domain = non-home-package modules
+						--   except that the InstEnv components is empty
+	pcsInsts :: InstEnv			-- The total InstEnv accumulated from all
+						--   the non-home-package modules
+	pcsRules :: RuleEnv			-- Ditto RuleEnv
+
        pcsPRS :: PersistentRenamerState
     }
 \end{code}
@@ -151,10 +215,19 @@ The @PersistentRenamerState@ persists across successive calls to the
 compiler.

 It contains:
-  * a name supply, which deals with allocating unique names to
+  * A name supply, which deals with allocating unique names to
    (Module,OccName) original names, 
 
-  * a "holding pen" for declarations that have been read out of
+  * An accumulated InstEnv from all the modules in pcsPST
+    The point is that we don't want to keep recreating it whenever
+    we compile a new module.  The InstEnv component of pcPST is empty.
+    (This means we might "see" instances that we shouldn't "really" see;
+    but the Haskell Report is vague on what is meant to be visible, 
+    so we just take the easy road here.)
+
+  * Ditto for rules
+
+  * A "holding pen" for declarations that have been read out of
    interface files but not yet sucked in, renamed, and typechecked

 \begin{code}
@@ -166,8 +239,7 @@ data PersistentRenamerState
    }

 data NameSupply
- = NS { nsUniqs  :: UniqSupply,
-	nsNames  :: FiniteMap (Module,OccName) Name	-- Ensures that one original name gets one unique
+ = 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
   }


--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -386,14 +386,6 @@ initIfaceRnMS mod thing_inside
  = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
    setModuleRn mod thing_inside

-builtins :: FiniteMap (ModuleName,OccName) Name
-builtins = listToFM wired_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 ]
 \end{code}

 @renameSourceCode@ is used to rename stuff ``out-of-line'';

--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -87,7 +87,7 @@ data TcEnv
  = TcEnv {
 	tcGST  	 :: GlobalSymbolTable,	-- The symbol table at the moment we began this compilation

-	tcInst 	 :: InstEnv,		-- All instances (both imported and in this module)
+	tcInsts	 :: InstEnv,		-- All instances (both imported and in this module)

 	tcGEnv	 :: NameEnv TyThing	-- The global type environment we've accumulated while
 					-- compiling this module:
@@ -141,10 +141,10 @@ data TcTyThing
 initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv
 initTcEnv gst inst_env
  = do { gtv_var <- newIORef emptyVarSet
-	 return (TcEnv { tcGST = gst,
-		      	 tcGEnv = emptyNameEnv, 
-		      	 tcInst = inst_env,
-		      	 tcLEnv = emptyNameEnv,
+	 return (TcEnv { tcGST    = gst,
+		      	 tcGEnv   = emptyNameEnv,
+		      	 tcInsts  = inst_env,
+		      	 tcLEnv   = emptyNameEnv,
 		      	 tcTyVars = gtv_var
 	 })}

@@ -469,12 +469,12 @@ tcGetGlobalTyVars
 \begin{code}
 tcGetInstEnv :: NF_TcM InstEnv
 tcGetInstEnv = tcGetEnv 	`thenNF_Tc` \ env -> 
-	       returnNF_Tc (tcInst env)
+	       returnNF_Tc (tcInsts env)

 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 tcSetInstEnv ie thing_inside
  = tcGetEnv 	`thenNF_Tc` \ env ->
-    tcSetEnv (env {tcInst = ie}) thing_inside
+    tcSetEnv (env {tcInsts = ie}) thing_inside
 \end{code}    



--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -68,6 +68,8 @@ Outside-world interface:
 -- Convenient type synonyms first:
 data TcResults
  = TcResults {
+	tc_prs	   :: PersistentCompilerState,	-- Augmented with imported information,
+						-- (but not stuff from this module)
 	tc_binds   :: TypecheckedMonoBinds,
 	tc_tycons  :: [TyCon],
 	tc_classes :: [Class],
@@ -87,7 +89,7 @@ typecheckModule
 typecheckModule pcs hst mod
  = do { us <- mkSplitUniqSupply 'a' ;

-	 env <- initTcEnv gst inst_env ;
+	 env <- initTcEnv global_symbol_table global_inst_env ;

 	 (maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod)
 		
@@ -106,6 +108,10 @@ typecheckModule pcs hst mod
    }
  where
    global_symbol_table = pcsPST pcs `plusModuleEnv` hst
+
+    global_inst_env	= foldModuleEnv (plusInstEnv . instEnv) (pcsInsts pcs) gst
+	-- For now, make the total instance envt by simply
+	-- folding together all the instances we can find anywhere
 \end{code}

 The internal monster:
@@ -118,15 +124,15 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
  = tcAddSrcLoc src_loc $	-- record where we're starting

    fixTc (\ ~(unf_env ,_) ->
-	-- unf_env is used for type-checking interface pragmas
+	-- (unf_env :: TcEnv) is used for type-checking interface pragmas
 	-- which is done lazily [ie failure just drops the pragma
 	-- without having any global-failure effect].
 	-- 
-	-- unf_env is also used to get the pragam info
+	-- unf_env is also used to get the pragama info
 	-- for imported dfuns and default methods

 		 -- Type-check the type and class decls
-	tcTyAndClassDecls unf_env decls	`thenTc` \ env ->
+	tcTyAndClassDecls unf_env decls		`thenTc` \ env ->
 	tcSetEnv env $

    		 -- Typecheck the instance decls, includes deriving
@@ -183,7 +189,7 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
    	tcExtendGlobalValEnv cls_ids		$

 	    -- foreign import declarations next.
-	tcForeignImports decls		`thenTc`    \ (fo_ids, foi_decls) ->
+	tcForeignImports decls			`thenTc`    \ (fo_ids, foi_decls) ->
 	tcExtendGlobalValEnv fo_ids		$

 	-- Value declarations next.
@@ -192,7 +198,6 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
 	    (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
 	    (get_val_decls decls `ThenBinds` deriv_binds)
 	    (	tcGetEnv				`thenNF_Tc` \ env ->
-		tcGetUnique				`thenNF_Tc` \ uniq ->
 		returnTc ((EmptyMonoBinds, env), emptyLIE)
 	    )				`thenTc` \ ((val_binds, final_env), lie_valdecls) ->
 	tcSetEnv final_env $
@@ -245,6 +250,8 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
 	in
 	zonkTopBinds all_binds		`thenNF_Tc` \ (all_binds', really_final_env)  ->
 	tcSetEnv really_final_env	$
+		-- zonkTopBinds puts all the top-level Ids into the tcGEnv
+
 	zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 	zonkRules rules			`thenNF_Tc` \ rules' ->