Commit e12e8c14 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Support for using built-in PA dictionaries for some types

parent 97b95db0
...@@ -21,7 +21,7 @@ module VectMonad ( ...@@ -21,7 +21,7 @@ module VectMonad (
lookupVar, defGlobalVar, lookupVar, defGlobalVar,
lookupTyCon, defTyCon, lookupTyCon, defTyCon,
lookupDataCon, defDataCon, lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, lookupTyConPA, defTyConPA, defTyConRdrPAs,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars, lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupInst, lookupFamInst lookupInst, lookupFamInst
...@@ -413,6 +413,16 @@ defTyConPA :: TyCon -> Var -> VM () ...@@ -413,6 +413,16 @@ defTyConPA :: TyCon -> Var -> VM ()
defTyConPA tc pa = updGEnv $ \env -> defTyConPA tc pa = updGEnv $ \env ->
env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa } env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
defTyConRdrPAs :: [(Name, RdrName)] -> VM ()
defTyConRdrPAs ps
= do
pas <- mapM lookupRdrVar rdr_names
updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
(zip tcs pas) }
where
(tcs, rdr_names) = unzip ps
lookupTyVarPA :: Var -> VM (Maybe CoreExpr) lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
......
...@@ -25,11 +25,13 @@ import InstEnv ( extendInstEnvList ) ...@@ -25,11 +25,13 @@ import InstEnv ( extendInstEnvList )
import Var import Var
import VarEnv import VarEnv
import VarSet import VarSet
import Name ( mkSysTvName, getName ) import Name ( Name, mkSysTvName, getName )
import NameEnv import NameEnv
import Id import Id
import MkId ( unwrapFamInstScrut ) import MkId ( unwrapFamInstScrut )
import OccName import OccName
import RdrName ( RdrName, mkRdrQual )
import Module ( mkModuleNameFS )
import DsMonad hiding (mapAndUnzipM) import DsMonad hiding (mapAndUnzipM)
import DsUtils ( mkCoreTup, mkCoreTupTy ) import DsUtils ( mkCoreTup, mkCoreTupTy )
...@@ -44,6 +46,12 @@ import Outputable ...@@ -44,6 +46,12 @@ import Outputable
import FastString import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM ) import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
mkNDPVar :: FastString -> RdrName
mkNDPVar fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs)
builtin_PAs :: [(Name, RdrName)]
builtin_PAs = [(intTyConName, mkNDPVar FSLIT("dPA_Int"))]
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts) -> IO (SimplCount, ModGuts)
vectorise hsc_env _ _ guts vectorise hsc_env _ _ guts
...@@ -60,6 +68,7 @@ vectorise hsc_env _ _ guts ...@@ -60,6 +68,7 @@ vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts vectModule :: ModGuts -> VM ModGuts
vectModule guts vectModule guts
= do = do
defTyConRdrPAs builtin_PAs
(types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts) (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts)
let insts = map painstInstance pa_insts let insts = map painstInstance pa_insts
......
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