X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=1360c47b9c688ef6373b1f71dc39a1035cc0d78d;hb=9d4c03805bafb6b1e1d47306b6a6c591c998e517;hp=c2b831dcaa6e1ea35fbb4aa59caa38f583728cf0;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index c2b831d..1360c47 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -6,38 +6,46 @@ module TcEnv( initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, - tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv, - tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey, + tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar, + + tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, + tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, + tcGetTyConsAndClasses, tcExtendGlobalValEnv, tcExtendLocalValEnv, - tcLookupLocalValue, tcLookupLocalValueOK, + tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcTyVarScope, newMonoIds, newLocalIds, - tcGetGlobalTyVars + newMonoIds, newLocalIds, newLocalId, + tcGetGlobalTyVars, tcExtendGlobalTyVars ) where -import Ubiq -import TcMLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(TcMLoop) -- for paranoia checking -import Id ( Id(..), GenId, idType, mkUserLocal ) -import TcHsSyn ( TcIdBndr(..) ) -import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind ) -import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars ) -import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet ) -import Type ( tyVarsOfTypes ) -import TyCon ( TyCon, getTyConKind ) -import Class ( Class(..), GenClass, getClassSig ) +import Id ( SYN_IE(Id), GenId, idType, mkUserLocal ) +import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) ) +import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) +import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), + newTyVarTys, tcInstTyVars, zonkTcTyVars + ) +import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) +import Type ( tyVarsOfTypes, splitForAllTy ) +import TyCon ( TyCon, tyConKind, synTyConArity ) +import Class ( SYN_IE(Class), GenClass, classSig ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) -import Name ( Name(..), getNameShortName ) +import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} ) import PprStyle import Pretty -import Unique ( Unique ) -import UniqFM -import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic ) +import RnHsSyn ( RnName(..) ) +import Unique ( pprUnique10, pprUnique{-ToDo:rm-} ) +import UniqFM +import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy, + panic, pprPanic, pprTrace{-ToDo:rm-} + ) \end{code} Data type declarations @@ -46,135 +54,143 @@ Data type declarations \begin{code} data TcEnv s = TcEnv (TyVarEnv s) + (TyConEnv s) + (ClassEnv s) (ValueEnv Id) -- Globals (ValueEnv (TcIdBndr s)) -- Locals (MutableVar s (TcTyVarSet s)) -- Free type variables of locals -- ...why mutable? see notes with tcGetGlobalTyVars - (KindEnv s) -- Gives TcKinds of TyCons and Classes - TyConEnv - ClassEnv type TyVarEnv s = UniqFM (TcKind s, TyVar) -type TyConEnv = UniqFM TyCon -type KindEnv s = UniqFM (TcKind s) -type ClassEnv = UniqFM Class +type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only +type ClassEnv s = UniqFM (TcKind s, Class) type ValueEnv id = UniqFM id initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s -initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM +initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut -getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls -getEnv_TyCons (TcEnv _ _ _ _ _ ts _) = ts -getEnv_Classes (TcEnv _ _ _ _ _ _ cs) = cs +getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls +getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts] +getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs] \end{code} Making new TcTyVars, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyVarScope :: [Name] -- Names of some type variables - -> ([TyVar] -> TcM s a) -- Thing to type check in their scope - -> TcM s a -- Result - -tcTyVarScope tyvar_names thing_inside - = newKindVars (length tyvar_names) `thenNF_Tc` \ tyvar_kinds -> +tcTyVarScopeGivenKinds + :: [Name] -- Names of some type variables + -> [TcKind s] + -> ([TyVar] -> TcM s a) -- Thing to type check in their scope + -> TcM s a -- Result - fixTc (\ ~(tyvars, _) -> - -- Ok to look at kinds, but not tyvars! - tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) ( +tcTyVarScopeGivenKinds names kinds thing_inside + = fixTc (\ ~(rec_tyvars, _) -> + -- Ok to look at names, kinds, but not tyvars! - -- Do the thing inside - thing_inside tyvars `thenTc` \ result -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + let + tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars)) + in + tcSetEnv (TcEnv tve' tce ce gve lve gtvs) + (thing_inside rec_tyvars) `thenTc` \ result -> -- Get the tyvar's Kinds from their TcKinds - mapNF_Tc tcKindToKind tyvar_kinds `thenNF_Tc` \ tyvar_kinds' -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' -> -- Construct the real TyVars let - tyvars = zipWithEqual mk_tyvar tyvar_names tyvar_kinds' - mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind + tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds' in returnTc (tyvars, result) - )) `thenTc` \ (_,result) -> + ) `thenTc` \ (_,result) -> returnTc result + +tcTyVarScope names thing_inside + = newKindVars (length names) `thenNF_Tc` \ kinds -> + tcTyVarScopeGivenKinds names kinds thing_inside \end{code} The Kind, TyVar, Class and TyCon envs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Extending the environments +Extending the environments. Notice the uses of @zipLazy@, which makes sure +that the knot-tied TyVars, TyCons and Classes aren't looked at too early. \begin{code} -tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r -tcExtendKindEnv names kinds scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - ke' = addListToUFM ke (names `zip` kinds) - in - tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope +tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r -tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r -tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> +tcExtendTyConEnv names_w_arities tycons scope + = newKindVars (length names_w_arities) `thenNF_Tc` \ kinds -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars) + tce' = addListToUFM tce [ (name, (kind, arity, tycon)) + | ((name,arity), (kind,tycon)) + <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons) + ] in - tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope + tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` + returnTc result -tcExtendTyConEnv tycons scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons] - in - tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope -tcExtendClassEnv classes scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> +tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r +tcExtendClassEnv names classes scope + = newKindVars (length names) `thenNF_Tc` \ kinds -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes] + ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes)) in - tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope + tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` + returnTc result \end{code} -Looking up in the environments +Looking up in the environments. \begin{code} tcLookupTyVar name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name) + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name) tcLookupTyCon (WiredInTyCon tc) -- wired in tycons - = returnNF_Tc (kindToTcKind (getTyConKind tc), tc) + = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc) tcLookupTyCon name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon") name - kind = lookupWithDefaultUFM ke (kindToTcKind (getTyConKind tycon)) name - -- The KE will bind tycon in the current mutually-recursive set. - -- If the KE doesn't, then the tycon is already defined, and we - -- can safely grab the kind from the TyCon itself + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name) + +tcLookupTyConByKey uniq + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + let + (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce + (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) + uniq in - returnNF_Tc (kind,tycon) - + returnNF_Tc tycon tcLookupClass name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - clas = lookupWithDefaultUFM ce (panic "tcLookupClass") name - (tyvar, _, _) = getClassSig clas - kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name - in - returnNF_Tc (kind,clas) + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $ +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $ + returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name) tcLookupClassByKey uniq - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq + (kind, clas) = lookupWithDefaultUFM_Directly ce + (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq)) + uniq in - returnNF_Tc (clas) + returnNF_Tc clas + +tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class]) +tcGetTyConsAndClasses + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce], + [c | (_, c) <- eltsUFM ce]) \end{code} @@ -183,23 +199,23 @@ Extending and consulting the value environment ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcExtendGlobalValEnv ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids] + gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids] in - tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope + tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope tcExtendLocalValEnv names ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> let - lve' = addListToUFM lve (names `zip` ids) + lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids) extra_global_tyvars = tyVarsOfTypes (map idType ids) new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tyvars in tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' -> - tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope + tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope \end{code} @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. @@ -209,48 +225,61 @@ the environment. \begin{code} tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s) tcGetGlobalTyVars - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' -> tcWriteMutVar gtvs global_tvs' `thenNF_Tc_` returnNF_Tc global_tvs' + +tcExtendGlobalTyVars extra_global_tvs scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> + let + new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tvs + in + tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' -> + tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope \end{code} \begin{code} -tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s)) +tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s)) tcLookupLocalValue name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM lve name) -tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s) +tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s)) +tcLookupLocalValueByKey uniq + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupUFM_Directly lve uniq) + +tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s) tcLookupLocalValueOK err name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM lve (panic err) name) -tcLookupGlobalValue :: Name -> NF_TcM s Id +tcLookupGlobalValue :: RnName -> NF_TcM s Id -tcLookupGlobalValue (WiredInVal id) -- wired in ids +tcLookupGlobalValue (WiredInId id) -- wired in ids = returnNF_Tc id tcLookupGlobalValue name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM gve def name) where #ifdef DEBUG - def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name)) + def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name) #else def = panic "tcLookupGlobalValue" #endif - tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq) where #ifdef DEBUG - def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq)) + def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq) #else def = panic "tcLookupGlobalValueByKey" #endif @@ -262,26 +291,37 @@ Constructing new Ids ~~~~~~~~~~~~~~~~~~~~ \begin{code} -newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a +newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a + newMonoIds names kind m = newTyVarTys no_of_names kind `thenNF_Tc` \ tys -> tcGetUniques no_of_names `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys - mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty - (getSrcLoc name) + new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys + + mk_id name uniq ty + = let + name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n } + in + mkUserLocal name_str uniq ty (getSrcLoc name) in tcExtendLocalValEnv names new_ids (m new_ids) where no_of_names = length names -newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s] +newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s) +newLocalId name ty + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (TcId (mkUserLocal name uniq ty loc)) + +newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s] newLocalIds names tys = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUniques (length names) `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys - mk_id name uniq ty = mkUserLocal name uniq ty loc + new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys + mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc) in returnNF_Tc new_ids \end{code}