X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=b1a9084060441da9d41aac8240533083f70b4cad;hb=a63bd8f558fedec86451f36d86833c9afb934ae8;hp=feb9442c4695658e128fae66f0216229d3226bc0;hpb=ea659be5faea43df1b2c113d2f22947dff23367e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index feb9442..b1a9084 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -5,7 +5,7 @@ module TcEnv( -- Getting stuff from the environment TcEnv, initTcEnv, - tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars, + tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts, getTcGEnv, -- Instance environment, and InstInfo type @@ -14,24 +14,24 @@ module TcEnv( simpleInstInfoTy, simpleInstInfoTyCon, -- Global environment - tcExtendGlobalEnv, tcExtendGlobalValEnv, + tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment - tcExtendKindEnv, - tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, tcLookup, + tcExtendKindEnv, tcInLocalScope, + tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendLocalValEnv, tcExtendLocalValEnv2, + tcLookup, tcLookupLocalIds, tcLookup_maybe, tcLookupId, -- Global type variables - tcGetGlobalTyVars, tcExtendGlobalTyVars, + tcGetGlobalTyVars, -- Random useful things - RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId, + RecTcEnv, tcLookupRecId, tcLookupRecId_maybe, -- New Ids - newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName, + newLocalName, newDFunName, -- Misc isLocalThing, tcSetEnv @@ -41,38 +41,36 @@ module TcEnv( import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, - tcInstTyVars, zonkTcTyVars, +import TcMType ( zonkTcTyVarsAndFV ) +import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, + tyVarsOfTypes, tcSplitDFunTy, + getDFunTyKey, tcTyConAppTyCon ) -import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( constantIdInfo ) -import MkId ( mkSpecPragmaId ) -import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) +import Id ( idName, isDataConWrapId_maybe ) +import Var ( TyVar, Id, idType ) import VarSet -import Type ( Type, - tyVarsOfTypes, splitDFunTy, - splitForAllTys, splitRhoTy, - getDFunTyKey, tyConAppTyCon - ) import DataCon ( DataCon ) -import TyCon ( TyCon ) -import Class ( Class, ClassOpItem, ClassContext ) -import Subst ( substTy ) -import Name ( Name, OccName, NamedThing(..), - nameOccName, nameModule, getSrcLoc, mkGlobalName, - isLocalName, nameModule_maybe +import TyCon ( TyCon, DataConDetails ) +import Class ( Class, ClassOpItem ) +import Name ( Name, NamedThing(..), + getSrcLoc, mkInternalName, isInternalName, nameIsLocalOrFrom + ) +import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv, + extendNameEnvList, emptyNameEnv, plusNameEnv ) +import OccName ( mkDFunOcc, occNameString ) +import HscTypes ( DFunId, + PackageTypeEnv, TypeEnv, + extendTypeEnvList, extendTypeEnvWithIds, + typeEnvTyCons, typeEnvClasses, typeEnvIds, + HomeSymbolTable ) -import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) -import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv ) import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) import HscTypes ( lookupType, TyThing(..) ) -import Util ( zipEqual ) import SrcLoc ( SrcLoc ) import Outputable -import IOExts ( newIORef ) +import DATA_IOREF ( newIORef ) \end{code} %************************************************************************ @@ -95,7 +93,8 @@ data TcEnv {- NameEnv TyThing-} -- compiling this module: -- types and classes (both imported and local) -- imported Ids - -- (Ids defined in this module are in the local envt) + -- (Ids defined in this module start in the local envt, + -- though they move to the global envt during zonking) tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module @@ -128,18 +127,6 @@ used thus: \begin{code} -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - | ATcId TcId -- Ids defined in this module - | ATyVar TyVar -- Type variables - | AThing TcKind -- Used temporarily, during kind checking --- Here's an example of how the AThing guy is used --- Suppose we are checking (forall a. T a Int): --- 1. We first bind (a -> AThink kv), where kv is a kind variable. --- 2. Then we kind-check the (T a Int) part. --- 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 :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv initTcEnv hst pte = do { gtv_var <- newIORef emptyVarSet ; @@ -150,25 +137,45 @@ initTcEnv hst pte tcTyVars = gtv_var })} where - lookup name | isLocalName name = Nothing - | otherwise = lookupType hst pte name + lookup name | isInternalName name = Nothing + | otherwise = lookupType hst pte name -tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)] -tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] -tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)] -tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)] -tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)] +tcEnvClasses env = typeEnvClasses (tcGEnv env) +tcEnvTyCons env = typeEnvTyCons (tcGEnv env) +tcEnvIds env = typeEnvIds (tcGEnv env) +tcLEnvElts env = nameEnvElts (tcLEnv env) getTcGEnv (TcEnv { tcGEnv = genv }) = genv --- This data type is used to help tie the knot --- when type checking type and class declarations -data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] - | ClassDetails ClassContext [Id] [ClassOpItem] DataCon +tcInLocalScope :: TcEnv -> Name -> Bool +tcInLocalScope env v = v `elemNameEnv` (tcLEnv env) \end{code} +\begin{code} +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + | ATcId TcId -- Ids defined in this module + | ATyVar TyVar -- Type variables + | AThing TcKind -- Used temporarily, during kind checking +-- Here's an example of how the AThing guy is used +-- Suppose we are checking (forall a. T a Int): +-- 1. We first bind (a -> AThink kv), where kv is a kind variable. +-- 2. Then we kind-check the (T a Int) part. +-- 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 + +\end{code} + +This data type is used to help tie the knot + when type checking type and class declarations + +\begin{code} +data TyThingDetails = SynTyDetails Type + | DataTyDetails ThetaType (DataConDetails DataCon) [Id] + | ClassDetails ThetaType [Id] [ClassOpItem] DataCon + | ForeignTyDetails -- Nothing yet +\end{code} %************************************************************************ %* * @@ -200,50 +207,17 @@ type RecTcEnv = TcEnv -- 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 -> constantIdInfo - Just imported_id -> idInfo imported_id - -- ToDo: could check that types are the same +tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id +tcLookupRecId_maybe env name = case lookup_global env name of + Just (AnId id) -> Just id + other -> Nothing -tcLookupRecId :: RecTcEnv -> Name -> Maybe Id +tcLookupRecId :: RecTcEnv -> Name -> Id tcLookupRecId env name = case lookup_global env name of - Just (AnId id) -> Just id - other -> Nothing - -\end{code} - -%************************************************************************ -%* * -\subsection{Random useful functions} -%* * -%************************************************************************ - - -\begin{code} --- A useful function that takes an occurrence of a global thing --- and instantiates its type with fresh type variables -tcInstId :: Id - -> NF_TcM ([TcTyVar], -- It's instantiated type - TcThetaType, -- - TcType) -- -tcInstId id - = let - (tyvars, rho) = splitForAllTys (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - let - rho' = substTy tenv rho - (theta', tau') = splitRhoTy rho' - in - returnNF_Tc (tyvars', theta', tau') + Just (AnId id) -> id + Nothing -> pprPanic "tcLookupRecId" (ppr name) \end{code} - %************************************************************************ %* * \subsection{Making new Ids} @@ -253,48 +227,31 @@ tcInstId id Constructing new Ids \begin{code} -newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId -newLocalId name ty loc +newLocalName :: Name -> NF_TcM Name +newLocalName name -- Make a clone = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkUserLocal name uniq ty loc) - -newSpecPragmaId :: Name -> TcType -> NF_TcM TcId -newSpecPragmaId name ty - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) + returnNF_Tc (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} -Make a name for the dict fun for an instance decl +Make a name for the dict fun for an instance decl. +It's a *local* name for the moment. The CoreTidy pass +will externalise it. \begin{code} -newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name -newDFunName mod clas (ty:_) loc - = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> - tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq mod - (mkDFunOcc dfun_string inst_uniq) - loc) +newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName clas (ty:_) loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkInternalName uniq (mkDFunOcc dfun_string) loc) where -- 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 -> - returnNF_Tc (mkGlobalName uniq (nameModule op_name) - (mkDefaultMethodOcc (getOccName op_name)) - loc) +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} \begin{code} isLocalThing :: NamedThing a => Module -> a -> Bool - -- True if the thing has a Local name, - -- or a Global name from the specified module -isLocalThing mod thing = case nameModule_maybe (getName thing) of - Nothing -> True -- A local name - Just m -> m == mod -- A global thing +isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) \end{code} %************************************************************************ @@ -304,17 +261,30 @@ isLocalThing mod thing = case nameModule_maybe (getName thing) of %************************************************************************ \begin{code} -tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r -tcExtendGlobalEnv bindings thing_inside +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r +tcExtendGlobalEnv things thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = extendTypeEnvList (tcGEnv env) things + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside + + +tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r +tcExtendGlobalTypeEnv extra_env thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) bindings + ge' = tcGEnv env `plusNameEnv` extra_env in tcSetEnv (env {tcGEnv = ge'}) thing_inside tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = extendTypeEnvWithIds (tcGEnv env) ids + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside \end{code} @@ -339,8 +309,8 @@ tcLookupGlobalId :: Name -> NF_TcM Id tcLookupGlobalId name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of - Just (AnId clas) -> returnNF_Tc clas - other -> notFound "tcLookupGlobalId" name + Just (AnId id) -> returnNF_Tc id + other -> notFound "tcLookupGlobalId" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name @@ -363,6 +333,23 @@ tcLookupTyCon name case maybe_tc of Just (ATyCon tc) -> returnNF_Tc tc other -> notFound "tcLookupTyCon" name + +tcLookupId :: Name -> NF_TcM Id +tcLookupId name + = tcLookup name `thenNF_Tc` \ thing -> + case thing of + ATcId tc_id -> returnNF_Tc tc_id + AGlobal (AnId id) -> returnNF_Tc id + other -> pprPanic "tcLookupId" (ppr name) + +tcLookupLocalIds :: [Name] -> NF_TcM [TcId] +tcLookupLocalIds ns + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (map (lookup (tcLEnv env)) ns) + where + lookup lenv name = case lookupNameEnv lenv name of + Just (ATcId id) -> id + other -> pprPanic "tcLookupLocalIds" (ppr name) \end{code} @@ -399,10 +386,19 @@ tcExtendKindEnv pairs thing_inside tcSetEnv (env {tcLEnv = le'}) thing_inside tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tyvars thing_inside +tcExtendTyVarEnv tvs thing_inside + = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside + +tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r +tcExtendTyVarEnv2 tv_pairs thing_inside + = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs] + [tv | (_,tv) <- tv_pairs] + thing_inside + +tc_extend_tv_env binds tyvars thing_inside = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) -> let - le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars] + le' = extendNameEnvList le binds new_tv_set = mkVarSet tyvars in -- It's important to add the in-scope tyvars to the global tyvar set @@ -413,29 +409,23 @@ tcExtendTyVarEnv tyvars thing_inside -- when typechecking the methods. tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' -> tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside +\end{code} --- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars: --- the signature tyvars contain the original names --- the instance tyvars are what those names should be mapped to --- It's needed when typechecking the method bindings of class and instance decls --- It does *not* extend the global tyvars; tcMethodBind does that for itself -tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r -tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside - = tcGetEnv `thenNF_Tc` \ env -> +\begin{code} +tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a +tcExtendLocalValEnv ids thing_inside + = tcGetEnv `thenNF_Tc` \ env -> let - le' = extendNameEnvList (tcLEnv env) stuff - stuff = [ (getName sig_tv, ATyVar inst_tv) - | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars - ] + extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids] + extra_env = [(idName id, ATcId id) | id <- ids] + le' = extendNameEnvList (tcLEnv env) extra_env in - tcSetEnv (env {tcLEnv = le'}) thing_inside -\end{code} - + tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' -> + tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside -\begin{code} -tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendLocalValEnv names_w_ids thing_inside +tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendLocalValEnv2 names_w_ids thing_inside = tcGetEnv `thenNF_Tc` \ env -> let extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids] @@ -454,11 +444,6 @@ tcExtendLocalValEnv names_w_ids thing_inside %************************************************************************ \begin{code} -tcExtendGlobalTyVars extra_global_tvs thing_inside - = tcGetEnv `thenNF_Tc` \ env -> - tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' -> - tcSetEnv (env {tcTyVars = gtvs'}) thing_inside - tc_extend_gtvs gtvs extra_global_tvs = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs) @@ -472,13 +457,10 @@ the environment. tcGetGlobalTyVars :: NF_TcM TcTyVarSet tcGetGlobalTyVars = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) -> - tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs -> - zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' -> - let - global_tvs' = (tyVarsOfTypes global_tys') - in - tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_` - returnNF_Tc global_tvs' + tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs -> + zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' -> + tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_` + returnNF_Tc gbl_tvs' \end{code} @@ -510,26 +492,36 @@ The InstInfo type summarises the information in an instance declaration instance c => k (t tvs) where b +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. + \begin{code} data InstInfo = InstInfo { - iLocal :: Bool, -- True <=> it's defined in this module iDFunId :: DFunId, -- The dfun id iBinds :: RenamedMonoBinds, -- Bindings, b iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances } -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), - nest 4 (ppr (iBinds info))] + | NewTypeDerived { -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument dictionary + -- Hence no bindings. + iDFunId :: DFunId -- The dfun id + } + +pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of +simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of (_, _, _, [ty]) -> ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst) +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \end{code}