X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=f3ab742550993d5cdecb5a3a9cdcc2f9f7cefe01;hb=849b7bca043a521fc60e18393cc311c754f2d9fe;hp=bbb8573b3554627bff4dc0143d7e5f0ba72ee34b;hpb=d893f3809b61eca1b7a45f3eb63d39b25f757c40;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index bbb8573..f3ab742 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -6,17 +6,17 @@ module TcEnv( -- Getting stuff from the environment TcEnv, initTcEnv, tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars, - getTcGST, getTcGEnv, + getTcGEnv, -- Instance environment, and InstInfo type tcGetInstEnv, tcSetInstEnv, InstInfo(..), pprInstInfo, - simpleInstInfoTy, simpleInstInfoTyCon, isLocalInst, + simpleInstInfoTy, simpleInstInfoTyCon, -- 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, - -- ??? - tcSetEnv, explicitLookupId + -- Misc + isLocalThing, tcSetEnv ) where #include "HsVersions.h" @@ -45,12 +45,12 @@ import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, tcInstTyVars, zonkTcTyVars, ) import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( vanillaIdInfo ) +import IdInfo ( constantIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, ThetaType, - tyVarsOfTypes, +import Type ( Type, + tyVarsOfTypes, splitDFunTy, splitForAllTys, splitRhoTy, getDFunTyKey, splitTyConApp_maybe ) @@ -60,15 +60,14 @@ import Class ( Class, ClassOpItem, ClassContext ) import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), nameOccName, nameModule, getSrcLoc, mkGlobalName, - isLocallyDefined, nameModule, - NameEnv, lookupNameEnv, nameEnvElts, - extendNameEnvList, emptyNameEnv + isLocalName, nameModule_maybe ) +import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv ) +import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv ) import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) -import HscTypes ( lookupTypeEnv, TyThing(..), GlobalSymbolTable ) +import HscTypes ( lookupType, TyThing(..) ) import Util ( zipEqual ) import SrcLoc ( SrcLoc ) import Outputable @@ -88,12 +87,12 @@ 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 :: TypeEnv, -- The global type environment we've accumulated while - {- NameEnv TyThing-}-- compiling this module: + {- NameEnv TyThing-} -- compiling this module: -- types and classes (both imported and local) -- imported Ids -- (Ids defined in this module are in the local envt) @@ -141,15 +140,19 @@ 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 -> IO TcEnv -initTcEnv gst +initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv hst pte = do { gtv_var <- newIORef emptyVarSet ; - return (TcEnv { tcGST = gst, + 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 = [cl | AClass cl <- nameEnvElts (tcGEnv env)] tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] @@ -157,13 +160,12 @@ tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)] tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)] tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)] -getTcGST (TcEnv { tcGST = gst }) = gst 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] [Class] + | DataTyDetails ClassContext [DataCon] | ClassDetails ClassContext [Id] [ClassOpItem] DataCon \end{code} @@ -180,7 +182,7 @@ lookup_global :: TcEnv -> Name -> Maybe TyThing lookup_global env name = case lookupNameEnv (tcGEnv env) name of Just thing -> Just thing - Nothing -> lookupTypeEnv (tcGST env) name + Nothing -> tcGST env name lookup_local :: TcEnv -> Name -> Maybe TcTyThing -- Try the local envt and then try the global @@ -190,13 +192,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 -> constantIdInfo + 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} %************************************************************************ %* * @@ -222,20 +241,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} @@ -273,6 +278,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 -> @@ -281,6 +288,14 @@ newDefaultMethodName op_name loc 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 +\end{code} %************************************************************************ %* * @@ -318,14 +333,14 @@ 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 clas - other -> notFound "tcLookupGlobalId:" name + other -> notFound "tcLookupGlobalId" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name @@ -340,14 +355,14 @@ 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 \end{code} @@ -368,7 +383,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} @@ -498,16 +513,9 @@ The InstInfo type summarises the information in an instance declaration \begin{code} data InstInfo = InstInfo { - iClass :: Class, -- Class, k - iTyVars :: [TyVar], -- Type variables, tvs - iTys :: [Type], -- The types at which the class is being instantiated - iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the - -- instance declaration. It constrains (some of) - -- the TyVars above - iLocal :: Bool, -- True <=> it's defined in this module + iLocal :: Bool, -- True <=> it's defined in this module iDFunId :: DFunId, -- The dfun id iBinds :: RenamedMonoBinds, -- Bindings, b - iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances } @@ -515,7 +523,8 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) nest 4 (ppr (iBinds info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty +simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of + (_, _, _, [ty]) -> ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, @@ -523,9 +532,6 @@ simpleInstInfoTyCon :: InstInfo -> TyCon simpleInstInfoTyCon inst = case splitTyConApp_maybe (simpleInstInfoTy inst) of Just (tycon, _) -> tycon - -isLocalInst :: Module -> InstInfo -> Bool -isLocalInst mod info = mod == nameModule (idName (iDFunId info)) \end{code}