From 7c068acee32d0d6e346fb71c4efaeacbf756c496 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 31 Oct 2000 09:58:13 +0000 Subject: [PATCH] [project @ 2000-10-31 09:58:13 by simonpj] Make it work again! --- ghc/compiler/typecheck/TcClassDcl.lhs | 10 +++--- ghc/compiler/typecheck/TcEnv.lhs | 51 +++++++++++++++++-------------- ghc/compiler/typecheck/TcIfaceSig.lhs | 20 ++++++------ ghc/compiler/typecheck/TcModule.lhs | 20 ++++++------ ghc/compiler/typecheck/TcTyClsDecls.lhs | 8 ++--- 5 files changed, 58 insertions(+), 51 deletions(-) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3af7420..d7da12c 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -26,7 +26,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) -import TcEnv ( TcId, TcEnv, TyThingDetails(..), tcAddImportedIdInfo, +import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName ) @@ -101,7 +101,7 @@ Death to "ExpandingDicts". %************************************************************************ \begin{code} -tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) tcClassDecl1 rec_env (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods @@ -237,7 +237,7 @@ tcSuperClasses clas context sc_sel_names is_tyvar other = False -tcClassSig :: TcEnv -- Knot tying only! +tcClassSig :: RecTcEnv -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only -> [FunDep TyVar] @@ -251,7 +251,7 @@ tcClassSig :: TcEnv -- Knot tying only! -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the -- Class.DefMeth data structure. -tcClassSig rec_env clas clas_tyvars fds dm_info +tcClassSig unf_env clas clas_tyvars fds dm_info (ClassOpSig op_name maybe_dm op_ty src_loc) = tcAddSrcLoc src_loc $ @@ -274,7 +274,7 @@ tcClassSig rec_env clas clas_tyvars fds dm_info dm_info_id = case dm_info_name of NoDefMeth -> NoDefMeth GenDefMeth -> GenDefMeth - DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id) + DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id) where dm_id = mkDefaultMethodId dm_name clas global_ty in diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 3dfdb2e..04e679b 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -16,7 +16,7 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, + tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment tcExtendKindEnv, @@ -27,14 +27,14 @@ module TcEnv( tcGetGlobalTyVars, tcExtendGlobalTyVars, -- Random useful things - tcAddImportedIdInfo, tcInstId, + RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId, -- New Ids newLocalId, newSpecPragmaId, newDefaultMethodName, newDFunName, -- Misc - isLocalThing, tcSetEnv, explicitLookupId + isLocalThing, tcSetEnv ) where #include "HsVersions.h" @@ -44,7 +44,7 @@ import TcMonad import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, tcInstTyVars, zonkTcTyVars, ) -import Id ( mkUserLocal, isDataConWrapId_maybe ) +import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( vanillaIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) @@ -193,13 +193,30 @@ lookup_local env name Nothing -> case lookup_global env name of Just thing -> Just (AGlobal thing) Nothing -> Nothing - -explicitLookupId :: TcEnv -> Name -> Maybe Id -explicitLookupId env name = case lookup_global env name of - Just (AnId id) -> Just id - other -> Nothing \end{code} +\begin{code} +type RecTcEnv = TcEnv +-- This environment is used for getting the 'right' IdInfo +-- on imported things and for looking up Ids in unfoldings +-- The environment doesn't have any local Ids in it + +tcAddImportedIdInfo :: RecTcEnv -> Id -> Id +tcAddImportedIdInfo env id + = id `lazySetIdInfo` new_info + -- The Id must be returned without a data dependency on maybe_id + where + new_info = case tcLookupRecId env (idName id) of + Nothing -> vanillaIdInfo + Just imported_id -> idInfo imported_id + -- ToDo: could check that types are the same + +tcLookupRecId :: RecTcEnv -> Name -> Maybe Id +tcLookupRecId env name = case lookup_global env name of + Just (AnId id) -> Just id + other -> Nothing + +\end{code} %************************************************************************ %* * @@ -225,20 +242,6 @@ tcInstId id (theta', tau') = splitRhoTy rho' in returnNF_Tc (tyvars', theta', tau') - -tcAddImportedIdInfo :: TcEnv -> Id -> Id -tcAddImportedIdInfo unf_env id - | isLocallyDefined id -- Don't look up locally defined Ids, because they - -- have explicit local definitions, so we get a black hole! - = id - | otherwise - = id `lazySetIdInfo` new_info - -- The Id must be returned without a data dependency on maybe_id - where - new_info = case explicitLookupId unf_env (getName id) of - Nothing -> vanillaIdInfo - Just imported_id -> idInfo imported_id - -- ToDo: could check that types are the same \end{code} @@ -276,6 +279,8 @@ newDFunName mod clas (ty:_) loc -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) +newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc) + newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name newDefaultMethodName op_name loc = tcGetUnique `thenNF_Tc` \ uniq -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 247b3b8..ed543f6 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -15,9 +15,9 @@ import TcMonoType ( tcHsType ) -- so tcHsType will do the Right Thing without -- having to mess about with zonking -import TcEnv ( TcEnv, tcExtendTyVarEnv, +import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetEnv, - tcLookupGlobal_maybe, explicitLookupId, tcEnvIds + tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds ) import RnHsSyn ( RenamedHsDecl ) @@ -51,7 +51,7 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings +tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls -> TcM [Id] @@ -60,7 +60,9 @@ tcInterfaceSigs unf_env decls = listTc [ do_one name ty id_infos src_loc | TyClD (IfaceSig name ty id_infos src_loc) <- decls] where - in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env) + in_scope_vars = [] -- I think this will be OK + -- If so, don't pass it around + -- Was: filter isLocallyDefined (tcEnvIds unf_env) do_one name ty id_infos src_loc = tcAddSrcLoc src_loc $ @@ -108,11 +110,11 @@ tcWorkerInfo unf_env ty info worker_name = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! - info' = case explicitLookupId unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) - `setWorkerInfo` HasWorker worker_id arity + info' = case tcLookupRecId unf_env worker_name of + Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) + `setWorkerInfo` HasWorker worker_id arity - Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info + Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info in returnTc info' where @@ -143,7 +145,7 @@ tcPragExpr unf_env name in_scope_vars expr where doc = text "unfolding of" <+> ppr name -tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) +tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) tcDelay unf_env doc thing_inside = forkNF_Tc ( recoverNF_Tc bad_value ( diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1387888..53de077 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -27,7 +27,7 @@ import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcEnvTyCons, tcEnvClasses, isLocalThing, - tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv + RecTcEnv, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) @@ -41,13 +41,12 @@ import CoreUnfold ( unfoldingTemplate ) import Type ( funResultTy, splitForAllTys ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn ) -import Id ( idType, idName, idUnfolding ) +import Id ( idType, idUnfolding ) import Module ( Module ) -import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, +import Name ( Name, isLocallyDefined, toRdrName, nameEnvElts, lookupNameEnv, ) import TyCon ( tyConGenInfo, isClassTyCon ) -import OccName ( isSysOcc ) import Maybes ( thenMaybe ) import Util import BasicTypes ( EP(..), Fixity ) @@ -104,7 +103,7 @@ typecheckModule dflags this_mod pcs hst hit decls else return Nothing where - tc_module :: TcM (TcEnv, TcResults) + tc_module :: TcM (RecTcEnv, TcResults) tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env) pit = pcs_PIT pcs @@ -121,10 +120,10 @@ tcModule :: PersistentCompilerState -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] - -> TcEnv -- The knot-tied environment + -> RecTcEnv -- The knot-tied environment -> TcM (TcEnv, TcResults) - -- (unf_env :: TcEnv) is used for type-checking interface pragmas + -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas -- which is done lazily [ie failure just drops the pragma -- without having any global-failure effect]. -- @@ -147,8 +146,8 @@ tcModule pcs hst get_fixity this_mod decls unf_env tcSetInstEnv inst_env $ -- Default declarations - tcDefaults decls `thenTc` \ defaulting_tys -> - tcSetDefaultTys defaulting_tys $ + tcDefaults decls `thenTc` \ defaulting_tys -> + tcSetDefaultTys defaulting_tys $ -- Interface type signatures -- We tie a knot so that the Ids read out of interfaces are in scope @@ -161,6 +160,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- imported tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> tcExtendGlobalValEnv sig_ids $ + tcGetEnv `thenTc` \ unf_env -> -- Create any necessary record selector Ids and their bindings -- "Necessary" includes data and newtype declarations @@ -246,7 +246,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env pcs_rules = new_pcs_rules } in - returnTc (final_env, + returnTc (unf_env, TcResults { tc_pcs = final_pcs, tc_env = local_type_env, tc_binds = all_binds', diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index db58f67..4f4ac88 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -21,7 +21,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad -import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), +import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), tcExtendKindEnv, tcLookup, tcExtendGlobalEnv ) import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) import TcClassDcl ( tcClassDecl1 ) @@ -61,7 +61,7 @@ import CmdLineOpts ( DynFlags ) The main function ~~~~~~~~~~~~~~~~~ \begin{code} -tcTyAndClassDecls :: TcEnv -- Knot tying stuff +tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff -> [RenamedHsDecl] -> TcM TcEnv @@ -75,7 +75,7 @@ tcGroups unf_env [] tcGroups unf_env (group:groups) = tcGroup unf_env group `thenTc` \ env -> - tcSetEnv env $ + tcSetEnv env $ tcGroups unf_env groups \end{code} @@ -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 :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv +tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv tcGroup unf_env scc = getDOptsTc `thenTc` \ dflags -> -- Step 1 -- 1.7.10.4