From: simonpj Date: Thu, 12 Oct 2000 15:05:59 +0000 (+0000) Subject: [project @ 2000-10-12 15:05:59 by simonpj] X-Git-Tag: Approximately_9120_patches~3612 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=db7db1b4dc4d6b7aa2f8c6f57794ac7f3d6ebe2e;p=ghc-hetmet.git [project @ 2000-10-12 15:05:59 by simonpj] More of Simon --- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index b0c64d2..8de66e1 100644 --- 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 diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 34e37a1..8535b67 100644 --- 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 } diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index d80dd25..37639fe 100644 --- 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''; diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 61f1437..fd3d9c1 100644 --- 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} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 2be87cf..8997884 100644 --- 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' ->