X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=744fb42661ed9cb1298bc31abf8b2d21455d4825;hb=c7eeb7113387ae4d3adc5a02eba441de335a9031;hp=fd3d9c178cc26249eb4b0a8a18a4f6a84e74c475;hpb=db7db1b4dc4d6b7aa2f8c6f57794ac7f3d6ebe2e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index fd3d9c1..744fb42 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,76 +1,77 @@ \begin{code} module TcEnv( TcId, TcIdSet, - TyThing(..), TyThingDetails(..), + TyThing(..), TyThingDetails(..), TcTyThing(..), -- Getting stuff from the environment TcEnv, initTcEnv, - tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, + tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts, + getTcGEnv, - -- Instance environment + -- Instance environment, and InstInfo type tcGetInstEnv, tcSetInstEnv, + InstInfo(..), pprInstInfo, + simpleInstInfoTy, simpleInstInfoTyCon, -- Global environment - tcExtendGlobalEnv, tcExtendGlobalValEnv, - tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, + tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, + tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, + tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment - tcExtendKindEnv, + tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, + tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId, -- Global type variables tcGetGlobalTyVars, tcExtendGlobalTyVars, -- Random useful things - tcAddImportedIdInfo, tcInstId, + RecTcEnv, tcLookupRecId, tcLookupRecId_maybe, -- New Ids - newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName + newLocalName, newDFunName, + + -- Misc + isLocalThing, tcSetEnv ) where #include "HsVersions.h" +import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, - tcInstTyVars, zonkTcTyVars, - ) -import Id ( mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( vanillaIdInfo ) -import MkId ( mkSpecPragmaId ) -import Var ( TyVar, Id, setVarName, - idType, lazySetIdInfo, idInfo, tyVarKind, UVar, - ) +import TcMType ( zonkTcTyVarsAndFV ) +import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, + tyVarsOfTypes, tcSplitDFunTy, + getDFunTyKey, tcTyConAppTyCon + ) +import Id ( idName, isDataConWrapId_maybe ) +import IdInfo ( vanillaIdInfo ) +import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import VarEnv ( TyVarSubstEnv ) -import Type ( Kind, Type, superKind, - tyVarsOfType, tyVarsOfTypes, - splitForAllTys, splitRhoTy, splitFunTys, - splitAlgTyConApp_maybe, getTyVar, getDFunTyKey - ) -import DataCon ( DataCon ) -import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon ) -import Class ( Class, ClassOpItem, ClassContext, classTyCon ) -import Subst ( substTy ) -import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), - nameOccName, nameModule, getSrcLoc, mkGlobalName, - maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, - NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, - extendNameEnv, extendNameEnvList - ) -import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) -import Module ( Module ) -import Unify ( unifyTyListsX, matchTys ) -import HscTypes ( ModDetails(..), lookupTypeEnv ) -import Unique ( pprUnique10, Unique, Uniquable(..) ) -import UniqFM -import Unique ( Uniquable(..) ) -import Util ( zipEqual, zipWith3Equal, mapAccumL ) -import SrcLoc ( SrcLoc ) -import FastString ( FastString ) -import Maybes +import DataCon ( DataCon ) +import TyCon ( TyCon ) +import Class ( Class, ClassOpItem ) +import Name ( Name, NamedThing(..), + getSrcLoc, mkLocalName, isLocalName, 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 Module ( Module ) +import InstEnv ( InstEnv, emptyInstEnv ) +import HscTypes ( lookupType, TyThing(..) ) +import Util ( zipEqual ) +import SrcLoc ( SrcLoc ) import Outputable + +import IOExts ( newIORef ) \end{code} %************************************************************************ @@ -85,15 +86,16 @@ type TcIdSet = IdSet data TcEnv = TcEnv { - tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation + tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation tcInsts :: InstEnv, -- All instances (both imported and in this module) - tcGEnv :: NameEnv TyThing -- The global type environment we've accumulated while - -- compiling this module: + tcGEnv :: TypeEnv, -- The global type environment we've accumulated while + {- 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 @@ -126,11 +128,37 @@ used thus: \begin{code} +initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv hst pte + = do { gtv_var <- newIORef emptyVarSet ; + return (TcEnv { tcGST = lookup, + tcGEnv = emptyNameEnv, + tcInsts = emptyInstEnv, + tcLEnv = emptyNameEnv, + tcTyVars = gtv_var + })} + where + lookup name | isLocalName name = Nothing + | otherwise = lookupType hst pte name + + +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 + +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 + = 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. @@ -138,30 +166,18 @@ 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 gst inst_env - = do { gtv_var <- newIORef emptyVarSet - return (TcEnv { tcGST = gst, - tcGEnv = emptyNameEnv, - tcInsts = inst_env, - tcLEnv = emptyNameEnv, - tcTyVars = gtv_var - })} +\end{code} -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)] +This data type is used to help tie the knot + when type checking type and class declarations --- This data type is used to help tie the knot --- when type checking type and class declarations +\begin{code} data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] [Class] - | ClassDetails ClassContext [Id] [ClassOpItem] DataCon + | DataTyDetails ThetaType [DataCon] [Id] + | ClassDetails ThetaType [Id] [ClassOpItem] DataCon + | ForeignTyDetails -- Nothing yet \end{code} - %************************************************************************ %* * \subsection{Basic lookups} @@ -172,67 +188,37 @@ data TyThingDetails = SynTyDetails Type lookup_global :: TcEnv -> Name -> Maybe TyThing -- Try the global envt and then the global symbol table lookup_global env name - = case lookupNameEnv (tcGEnv env) name of { - Just thing -> Just thing ; - Nothing -> lookupTypeEnv (tcGST env) name + = case lookupNameEnv (tcGEnv env) name of + Just thing -> Just thing + Nothing -> tcGST env name lookup_local :: TcEnv -> Name -> Maybe TcTyThing -- Try the local envt and then try the global lookup_local env name - = case lookupNameEnv (tcLEnv env) name of - Just thing -> Just thing ; + = case lookupNameEnv (tcLEnv env) name of + Just thing -> Just thing Nothing -> case lookup_global env name of - Just thing -> AGlobal thing + 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} - -%************************************************************************ -%* * -\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') - -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 +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 + +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 -> Id +tcLookupRecId env name = case lookup_global env name of + Just (AnId id) -> id + Nothing -> pprPanic "tcLookupRecId" (ppr name) \end{code} - %************************************************************************ %* * \subsection{Making new Ids} @@ -242,39 +228,32 @@ tcAddImportedIdInfo unf_env id Constructing new Ids \begin{code} -newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId -newLocalId name ty loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkUserLocal name uniq ty loc) - -newSpecPragmaId :: Name -> TcType -> NF_TcM TcId -newSpecPragmaId name ty +newLocalName :: Name -> NF_TcM Name +newLocalName name -- Make a clone = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) + returnNF_Tc (mkLocalName 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 globalise 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) - (LocalDef loc Exported)) +newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName clas (ty:_) loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc) where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) -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)) - (LocalDef loc Exported)) +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} +\begin{code} +isLocalThing :: NamedThing a => Module -> a -> Bool +isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) +\end{code} %************************************************************************ %* * @@ -283,17 +262,30 @@ newDefaultMethodName op_name loc %************************************************************************ \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} @@ -308,24 +300,25 @@ A variety of global lookups, when we know what we are looking for. \begin{code} tcLookupGlobal :: Name -> NF_TcM TyThing +tcLookupGlobal name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing -> case maybe_thing of Just thing -> returnNF_Tc thing - other -> notFound "tcLookupGlobal:" name + other -> notFound "tcLookupGlobal" name tcLookupGlobalId :: Name -> NF_TcM Id tcLookupGlobalId name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of - Just (AnId clas) -> returnNF_Tc id - other -> notFound "tcLookupGlobalId:" name + Just (AnId id) -> returnNF_Tc id + other -> notFound "tcLookupGlobalId" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name = tcLookupGlobalId con_name `thenNF_Tc` \ con_id -> - case isDataConWrapId_maybe con_id of { + case isDataConWrapId_maybe con_id of Just data_con -> returnTc data_con - Nothing -> failWithTc (badCon con_id); + Nothing -> failWithTc (badCon con_id) tcLookupClass :: Name -> NF_TcM Class @@ -333,14 +326,31 @@ tcLookupClass name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas -> case maybe_clas of Just (AClass clas) -> returnNF_Tc clas - other -> notFound "tcLookupClass:" name + other -> notFound "tcLookupClass" name tcLookupTyCon :: Name -> NF_TcM TyCon tcLookupTyCon name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc -> case maybe_tc of Just (ATyCon tc) -> returnNF_Tc tc - other -> notFound "tcLookupTyCon:" name + 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} @@ -361,7 +371,7 @@ tcLookup name = tcLookup_maybe name `thenNF_Tc` \ maybe_thing -> case maybe_thing of Just thing -> returnNF_Tc thing - other -> notFound "tcLookup:" name + other -> notFound "tcLookup" name -- Extract the IdInfo from an IfaceSig imported from an interface file \end{code} @@ -435,7 +445,7 @@ tcExtendLocalValEnv names_w_ids thing_inside 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 + tcSetEnv (env {tcTyVars = gtvs'}) thing_inside tc_extend_gtvs gtvs extra_global_tvs = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> @@ -450,13 +460,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} @@ -480,6 +487,49 @@ tcSetInstEnv ie thing_inside %************************************************************************ %* * +\subsection{The InstInfo type} +%* * +%************************************************************************ + +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 { + iDFunId :: DFunId, -- The dfun id + iBinds :: RenamedMonoBinds, -- Bindings, b + iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances + } + + | 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 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 = tcTyConAppTyCon (simpleInstInfoTy inst) +\end{code} + + +%************************************************************************ +%* * \subsection{Errors} %* * %************************************************************************ @@ -487,6 +537,6 @@ tcSetInstEnv ie thing_inside \begin{code} badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") -notFound where name = failWithTc (text where <> colon <+> quotes (ppr name) <+> +notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) \end{code}