Commit d7763733 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Lookup of class and family instances in vectorisation monad

parent 0501060c
......@@ -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,
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment