From: Manuel M T Chakravarty Date: Tue, 10 Jul 2007 08:49:49 +0000 (+0000) Subject: Lookup of class and family instances in vectorisation monad X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d77637338d311172efb17a4a7e99ac6c441543b1 Lookup of class and family instances in vectorisation monad --- diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index cb861ae..e2b22ee 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -71,6 +71,7 @@ deSugar hsc_env tcg_keep = keep_var, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, + tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, tcg_deprecs = deprecs, tcg_binds = binds, @@ -168,6 +169,7 @@ deSugar hsc_env mg_types = type_env, mg_insts = insts, mg_fam_insts = fam_insts, + mg_inst_env = inst_env, mg_fam_inst_env = fam_inst_env, mg_rules = ds_rules, mg_binds = ds_binds, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index b353caa..f36b205 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -521,9 +521,12 @@ data ModGuts mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in -- this module + mg_inst_env :: InstEnv, -- Class instance enviroment fro + -- *home-package* modules (including + -- this one); c.f. tcg_inst_env mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment -- for *home-package* modules (including - -- this one). c.f. tcg_fam_inst_env + -- this one); c.f. tcg_fam_inst_env mg_types :: !TypeEnv, mg_insts :: ![Instance], -- Instances diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 46204b0..ab77037 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -13,13 +13,16 @@ module VectMonad ( LocalEnv(..), readLEnv, setLEnv, updLEnv, - lookupTyCon, extendTyVarPA + lookupTyCon, extendTyVarPA, + + lookupInst, lookupFamInst ) where #include "HsVersions.h" import HscTypes import CoreSyn +import Class import TyCon import Type import Var @@ -31,6 +34,11 @@ import NameEnv import DsMonad import PrelNames +import InstEnv +import FamInstEnv + +import Panic +import Outputable import FastString -- ---------------------------------------------------------------------------- @@ -95,6 +103,16 @@ data GlobalEnv = GlobalEnv { -- Mapping from TyCons to their PA dictionaries -- , global_tycon_pa :: NameEnv CoreExpr + + -- External package inst-env & home-package inst-env for class + -- instances + -- + , global_inst_env :: (InstEnv, InstEnv) + + -- External package inst-env & home-package inst-env for family + -- instances + -- + , global_fam_inst_env :: FamInstEnvs } data LocalEnv = LocalEnv { @@ -108,13 +126,15 @@ data LocalEnv = LocalEnv { } -initGlobalEnv :: VectInfo -> GlobalEnv -initGlobalEnv info +initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv +initGlobalEnv info instEnvs famInstEnvs = GlobalEnv { global_vars = mapVarEnv (Var . snd) $ vectInfoCCVar info , global_exported_vars = emptyVarEnv , global_tycons = mapNameEnv snd $ vectInfoCCTyCon info , global_tycon_pa = emptyNameEnv + , global_inst_env = instEnvs + , global_fam_inst_env = famInstEnvs } emptyLocalEnv = LocalEnv { @@ -195,6 +215,12 @@ setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ()) updLEnv :: (LocalEnv -> LocalEnv) -> VM () updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) +getInstEnv :: VM (InstEnv, InstEnv) +getInstEnv = readGEnv global_inst_env + +getFamInstEnv :: VM FamInstEnvs +getFamInstEnv = readGEnv global_fam_inst_env + newLocalVar :: FastString -> Type -> VM Var newLocalVar fs ty = do @@ -213,21 +239,83 @@ lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName extendTyVarPA :: Var -> CoreExpr -> VM () extendTyVarPA tv pa = updLEnv $ \env -> env { local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa } +-- Look up the dfun of a class instance. +-- +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of +-- the class instance declaration. The found class instances must not have +-- any type variables in the instance context that do not appear in the +-- instances head (i.e., no flexi vars); for details for what this means, +-- see the docs at InstEnv.lookupInstEnv. +-- +lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) +lookupInst cls tys + = do { instEnv <- getInstEnv + ; case lookupInstEnv instEnv cls tys of + ([(inst, inst_tys)], _) + | noFlexiVar -> return (instanceDFunId inst, inst_tys') + | otherwise -> pprPanic "VectMonad.lookupInst: flexi var: " + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Right ty <- inst_tys] + noFlexiVar = all isRight inst_tys + _other -> + pprPanic "VectMonad.lookupInst: not found: " + (ppr $ mkTyConApp (classTyCon cls) tys) + } + where + isRight (Left _) = False + isRight (Right _) = True + +-- Look up the representation tycon of a family instance. +-- +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of +-- the family instance declaration. +-- +-- Return the instance tycon and its type instance. For example, if we have +-- +-- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int') +-- +-- then we have a coercion (ie, type instance of family instance coercion) +-- +-- :Co:R42T Int :: T [Int] ~ :R42T Int +-- +-- which implies that :R42T was declared as 'data instance T [a]'. +-- +lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type]) +lookupFamInst tycon tys + = ASSERT( isOpenTyCon tycon ) + do { instEnv <- getFamInstEnv + ; case lookupFamInstEnv instEnv tycon tys of + [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys) + _other -> + pprPanic "VectMonad.lookupFamInst: not found: " + (ppr $ mkTyConApp tycon tys) + } + initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a)) initV hsc_env guts info p = do + eps <- hscEPS hsc_env + let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) + let instEnvs = (eps_inst_env eps, mg_inst_env guts) + Just r <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) - go + (go instEnvs famInstEnvs) return r where - go = do - builtins <- initBuiltins - r <- runVM p builtins (initGlobalEnv info) emptyLocalEnv - case r of - Yes genv _ x -> return $ Just (new_info genv, x) - No -> return Nothing + + go instEnvs famInstEnvs = + do + builtins <- initBuiltins + r <- runVM p builtins (initGlobalEnv info instEnvs famInstEnvs) + emptyLocalEnv + case r of + Yes genv _ x -> return $ Just (new_info genv, x) + No -> return Nothing new_info genv = updVectInfo genv (mg_types guts) info