From: simonpj Date: Tue, 17 Oct 2000 09:33:41 +0000 (+0000) Subject: [project @ 2000-10-17 09:33:41 by simonpj] X-Git-Tag: Approximately_9120_patches~3555 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a180ee15dfe2eb0da03cd92ca89475765cd080d9;p=ghc-hetmet.git [project @ 2000-10-17 09:33:41 by simonpj] Environments in typechecker --- diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index d32e750..8b61bbb 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -50,9 +50,9 @@ presumably include source-file location information: \begin{code} type DsM result = UniqSupply - -> ValueEnv - -> SrcLoc -- to put in pattern-matching error msgs - -> Module -- module: for SCC profiling + -> (Name -> Id) -- Lookup well-known Ids + -> SrcLoc -- to put in pattern-matching error msgs + -> Module -- module: for SCC profiling -> DsWarnings -> (result, DsWarnings) @@ -66,13 +66,28 @@ type DsWarnings = Bag WarnMsg -- The desugarer reports matches which a -- initDs returns the UniqSupply out the end (not just the result) initDs :: UniqSupply - -> ValueEnv + -> (HomeSymbolTable, PersistentCompilerState, TypeEnv) -> Module -- module name: for profiling -> DsM a -> (a, DsWarnings) -initDs init_us genv mod action - = action init_us genv noSrcLoc mod emptyBag +initDs init_us (hst,pcs,local_type_env) mod action + = action init_us lookup noSrcLoc mod emptyBag + where + -- This lookup is used for well-known Ids, + -- such as fold, build, cons etc, so the chances are + -- it'll be found in the package symbol table. That's + -- why we don't merge all these tables + pst = pcsPST pcs + lookup n = case lookupTypeEnv pst n of { + Just (AnId v) -> v ; + other -> + case lookupTypeEnv hst n of { + Just (AnId v) -> v ; + other -> + case lookupNameEnv local_type_env n of + Just (AnId v) -> v ; + other -> pprPanic "initDS: lookup:" (ppr n) thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a @@ -198,11 +213,13 @@ getModuleDs us genv loc mod warns = (mod, warns) \end{code} \begin{code} -dsLookupGlobalValue :: Unique -> DsM Id +dsLookupGlobalValue :: Name -> DsM Id dsLookupGlobalValue key us genv loc mod warns - = (lookupWithDefaultUFM_Directly genv def key, warns) + = (result, warns) where - def = pprPanic "dsLookupGlobalValue:" (ppr key) + result = case lookupNameEnv genv name of + Just (AnId v) -> v + Nothing -> pprPanic "dsLookupGlobalValue:" (ppr name) \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 324038c..4c038e7 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -25,7 +25,7 @@ import RnHsSyn ( RenamedTyClDecl, import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) -import TcEnv ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo, +import TcEnv ( TcId, TcEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo, tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName ) @@ -99,7 +99,7 @@ Death to "ExpandingDicts". %************************************************************************ \begin{code} -tcClassDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) tcClassDecl1 rec_env (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas @@ -232,7 +232,7 @@ tcSuperClasses clas context sc_sel_names is_tyvar other = False -tcClassSig :: ValueEnv -- Knot tying only! +tcClassSig :: TcEnv -- Knot tying only! -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only -> NameEnv (DefMeth Name) -- Info about default methods diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 96a0601..228a688 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -93,7 +93,7 @@ data TcEnv tcInsts :: InstEnv, -- All instances (both imported and in this module) tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while - -- compiling this module: + {- TypeEnv -} -- compiling this module: -- types and classes (both imported and local) -- imported Ids -- (Ids defined in this module are in the local envt) @@ -141,12 +141,12 @@ data TcTyThing -- 3. Then we zonk the kind variable. -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment -initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv +initTcEnv :: GlobalSymbolTable -> IO TcEnv initTcEnv gst inst_env = do { gtv_var <- newIORef emptyVarSet ; return (TcEnv { tcGST = gst, tcGEnv = emptyNameEnv, - tcInsts = inst_env, + tcInsts = emptyInstEnv, tcLEnv = emptyNameEnv, tcTyVars = gtv_var })} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5bdec50..459160d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -28,7 +28,7 @@ import Inst ( InstOrigin(..), newDicts, newClassDicts, LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) -import TcEnv ( ValueEnv, tcExtendGlobalValEnv, +import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, TyThing (..), tcAddImportedIdInfo, tcInstId, tcLookupClass, newDFunName, tcExtendTyVarEnv @@ -226,7 +226,7 @@ addInstDFuns dfuns infos \end{code} \begin{code} -tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM [InstInfo] +tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo] -- Deal with a single instance declaration tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9bb9fbf..150b266 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -85,7 +85,7 @@ typecheckModule -> IO (Maybe (PersistentCompilerState, TcResults)) typecheckModule pcs hst (HsModule mod_name _ _ _ decls _ src_loc) - = do { env <- initTcEnv global_symbol_table global_inst_env ; + = do { env <- initTcEnv global_symbol_table ; (_, (maybe_result, msgs)) <- initTc env src_loc tc_module diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 736f619..ae7e4d2 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -20,7 +20,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad -import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind, +import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..), tyThingKind, tcExtendTypeEnv, tcExtendKindEnv, tcLookupGlobal ) import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) @@ -61,7 +61,7 @@ import Generics ( mkTyConGenInfo ) The main function ~~~~~~~~~~~~~~~~~ \begin{code} -tcTyAndClassDecls :: ValueEnv -- Knot tying stuff +tcTyAndClassDecls :: TcEnv -- Knot tying stuff -> [RenamedHsDecl] -> TcM TcEnv @@ -111,7 +111,7 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM TcEnv +tcGroup :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv tcGroup unf_env scc = -- Step 1 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->