X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=dc26b4b69020c4ca2904c863eecca8e205f2d3c2;hb=35380dd876960a2e88e8743545615040f08b4f27;hp=46204b06bbce83c93b22d3a275adee7de21e8b80;hpb=621bc50eeb52dad05750d77581c4829e37424741;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 46204b0..dc26b4b 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -1,10 +1,10 @@ module VectMonad ( VM, - noV, tryV, maybeV, orElseV, localV, initV, + noV, tryV, maybeV, orElseV, localV, closedV, initV, newLocalVar, newTyVar, - Builtins(..), + Builtins(..), paDictTyCon, builtin, GlobalEnv(..), @@ -13,13 +13,17 @@ module VectMonad ( LocalEnv(..), readLEnv, setLEnv, updLEnv, - lookupTyCon, extendTyVarPA + lookupTyCon, + lookupTyVarPA, extendTyVarPA, deleteTyVarPA, + + lookupInst, lookupFamInst ) where #include "HsVersions.h" import HscTypes import CoreSyn +import Class import TyCon import Type import Var @@ -31,6 +35,11 @@ import NameEnv import DsMonad import PrelNames +import InstEnv +import FamInstEnv + +import Panic +import Outputable import FastString -- ---------------------------------------------------------------------------- @@ -38,41 +47,41 @@ import FastString data Builtins = Builtins { parrayTyCon :: TyCon - , paTyCon :: TyCon + , paClass :: Class , closureTyCon :: TyCon , mkClosureVar :: Var , applyClosureVar :: Var , mkClosurePVar :: Var , applyClosurePVar :: Var - , closurePAVar :: Var , lengthPAVar :: Var , replicatePAVar :: Var } +paDictTyCon :: Builtins -> TyCon +paDictTyCon = classTyCon . paClass + initBuiltins :: DsM Builtins initBuiltins = do parrayTyCon <- dsLookupTyCon parrayTyConName - paTyCon <- dsLookupTyCon paTyConName + paClass <- dsLookupClass paClassName closureTyCon <- dsLookupTyCon closureTyConName mkClosureVar <- dsLookupGlobalId mkClosureName applyClosureVar <- dsLookupGlobalId applyClosureName mkClosurePVar <- dsLookupGlobalId mkClosurePName applyClosurePVar <- dsLookupGlobalId applyClosurePName - closurePAVar <- dsLookupGlobalId closurePAName lengthPAVar <- dsLookupGlobalId lengthPAName replicatePAVar <- dsLookupGlobalId replicatePAName return $ Builtins { parrayTyCon = parrayTyCon - , paTyCon = paTyCon + , paClass = paClass , closureTyCon = closureTyCon , mkClosureVar = mkClosureVar , applyClosureVar = applyClosureVar , mkClosurePVar = mkClosurePVar , applyClosurePVar = applyClosurePVar - , closurePAVar = closurePAVar , lengthPAVar = lengthPAVar , replicatePAVar = replicatePAVar } @@ -95,6 +104,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 { @@ -105,21 +124,27 @@ data LocalEnv = LocalEnv { -- Mapping from tyvars to their PA dictionaries , local_tyvar_pa :: VarEnv CoreExpr + + -- Hoisted bindings + , local_bindings :: [(Var, CoreExpr)] } -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 { local_vars = emptyVarEnv , local_tyvar_pa = emptyVarEnv + , local_bindings = [] } -- FIXME @@ -171,6 +196,14 @@ localV p = do setLEnv env return x +closedV :: VM a -> VM a +closedV p = do + env <- readLEnv id + setLEnv emptyLocalEnv + x <- p + setLEnv env + return x + liftDs :: DsM a -> VM a liftDs p = VM $ \bi genv lenv -> do { x <- p; return (Yes genv lenv x) } @@ -195,6 +228,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 @@ -210,24 +249,90 @@ newTyVar fs k lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) +lookupTyVarPA :: Var -> VM (Maybe CoreExpr) +lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv + extendTyVarPA :: Var -> CoreExpr -> VM () extendTyVarPA tv pa = updLEnv $ \env -> env { local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa } +deleteTyVarPA :: Var -> VM () +deleteTyVarPA tv = updLEnv $ \env -> env { local_tyvar_pa = delVarEnv (local_tyvar_pa env) tv } + +-- 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 -> noV + } + 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