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

Move all vectorisation built-ins to VectBuiltIn

parent 135a48ab
module VectBuiltIn (
Builtins(..), initBuiltins
Builtins(..),
initBuiltins, initBuiltinTyCons, initBuiltinPAs
) where
#include "HsVersions.h"
import DsMonad
import IfaceEnv ( lookupOrig )
import Module ( Module )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConDataCons )
import TyCon ( TyCon, tyConName, tyConDataCons )
import Var ( Var )
import Id ( mkSysLocal )
import Name ( Name )
import OccName ( mkVarOccFS )
import TypeRep ( funTyCon )
import TysPrim ( intPrimTy )
import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
import PrelNames
import BasicTypes ( Boxity(..) )
import Control.Monad ( liftM )
import FastString
import Control.Monad ( liftM, zipWithM )
data Builtins = Builtins {
parrayTyCon :: TyCon
......@@ -103,4 +113,43 @@ initBuiltins
, liftingContext = liftingContext
}
initBuiltinTyCons :: DsM [(Name, TyCon)]
initBuiltinTyCons
= do
vects <- sequence vs
return (zip origs vects)
where
(origs, vs) = unzip builtinTyCons
builtinTyCons :: [(Name, DsM TyCon)]
builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
initBuiltinPAs :: DsM [(Name, Var)]
initBuiltinPAs
= do
pas <- zipWithM lookupExternalVar mods fss
return $ zip tcs pas
where
(tcs, mods, fss) = unzip3 builtinPAs
builtinPAs :: [(Name, Module, FastString)]
builtinPAs = [
mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo")
, mk (tyConName unitTyCon) nDP_PARRAY FSLIT("dPA_Unit")
, temporary intTyConName FSLIT("dPA_Int")
]
++ tups
where
mk name mod fs = (name, mod, fs)
temporary name fs = (name, nDP_INSTANCES, fs)
tups = map mk_tup [2..3]
mk_tup n = temporary (tyConName $ tupleTyCon Boxed n)
(mkFastString $ "dPA_" ++ show n)
lookupExternalVar :: Module -> FastString -> DsM Var
lookupExternalVar mod fs
= dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
......@@ -22,7 +22,7 @@ module VectMonad (
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
......@@ -119,17 +119,13 @@ data LocalEnv = LocalEnv {
-- Local binding name
, local_bind_name :: FastString
}
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins
-> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs bi
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs
= GlobalEnv {
global_vars = mapVarEnv snd $ vectInfoVar info
, global_exported_vars = emptyVarEnv
, global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
(tyConName funTyCon) (closureTyCon bi)
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_inst_env = instEnvs
......@@ -143,6 +139,14 @@ setFamInstEnv l_fam_inst genv
where
(g_fam_inst, _) = global_fam_inst_env genv
extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
......@@ -258,11 +262,6 @@ inBind id p
= do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
p
lookupExternalVar :: Module -> FastString -> VM Var
lookupExternalVar mod fs
= liftDs
$ dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
cloneName :: (OccName -> OccName) -> Name -> VM Name
cloneName mk_occ name = liftM make (liftDs newUnique)
where
......@@ -354,16 +353,6 @@ defTyConPAs ps = updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
[(tyConName tc, pa) | (tc, pa) <- ps] }
defTyConBuiltinPAs :: [(Name, Module, FastString)] -> VM ()
defTyConBuiltinPAs ps
= do
pas <- zipWithM lookupExternalVar mods fss
updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
(zip tcs pas) }
where
(tcs, mods, fss) = unzip3 ps
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
......@@ -454,11 +443,14 @@ initV hsc_env guts info p
go instEnvs famInstEnvs =
do
builtins <- initBuiltins
r <- runVM p builtins (initGlobalEnv info
instEnvs
famInstEnvs
builtins)
emptyLocalEnv
builtin_tycons <- initBuiltinTyCons
builtin_pas <- initBuiltinPAs
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv
case r of
Yes genv _ x -> return $ Just (new_info genv, x)
No -> return Nothing
......
......@@ -45,19 +45,6 @@ import Outputable
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
builtin_PAs :: [(Name, Module, FastString)]
builtin_PAs = [
(closureTyConName, nDP_CLOSURE, FSLIT("dPA_Clo"))
, mk intTyConName FSLIT("dPA_Int")
]
++ tups
where
mk name fs = (name, nDP_INSTANCES, fs)
tups = mk_tup 0 : map mk_tup [2..3]
mk_tup n = (getName $ tupleTyCon Boxed n, nDP_INSTANCES,
mkFastString $ "dPA_" ++ show n)
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
vectorise hsc_env _ _ guts
......@@ -74,7 +61,6 @@ vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
defTyConBuiltinPAs builtin_PAs
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_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