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

Use lookupOrig to find built-in NDP-related names

parent 82661b7f
......@@ -276,6 +276,7 @@ gLA_EXTS = mkBaseModule FSLIT("GHC.Exts")
nDP_PARRAY = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.PArray")
nDP_UTILS = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Utils")
nDP_CLOSURE = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Closure")
nDP_INSTANCES = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Instances")
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule FSLIT(":Main") -- Root module for initialisation
......
......@@ -21,7 +21,7 @@ module VectMonad (
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs, defTyConRdrPAs,
lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
......@@ -41,7 +41,8 @@ import OccName
import Name
import NameEnv
import TysPrim ( intPrimTy )
import RdrName
import Module
import IfaceEnv
import DsMonad
import PrelNames
......@@ -54,7 +55,7 @@ import Outputable
import FastString
import SrcLoc ( noSrcSpan )
import Control.Monad ( liftM )
import Control.Monad ( liftM, zipWithM )
data Scope a b = Global a | Local b
......@@ -154,10 +155,6 @@ data GlobalEnv = GlobalEnv {
-- Hoisted bindings
, global_bindings :: [(Var, CoreExpr)]
-- Global Rdr environment (from ModGuts)
--
, global_rdr_env :: GlobalRdrEnv
}
data LocalEnv = LocalEnv {
......@@ -178,9 +175,9 @@ data LocalEnv = LocalEnv {
}
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalRdrEnv
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins
-> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs bi rdr_env
initGlobalEnv info instEnvs famInstEnvs bi
= GlobalEnv {
global_vars = mapVarEnv snd $ vectInfoVar info
, global_exported_vars = emptyVarEnv
......@@ -192,7 +189,6 @@ initGlobalEnv info instEnvs famInstEnvs bi rdr_env
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
, global_rdr_env = rdr_env
}
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
......@@ -316,20 +312,10 @@ inBind id p
= do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
p
lookupRdrName :: RdrName -> VM Name
lookupRdrName rdr_name
= do
rdr_env <- readGEnv global_rdr_env
case lookupGRE_RdrName rdr_name rdr_env of
[gre] -> return (gre_name gre)
[] -> pprPanic "VectMonad.lookupRdrName: not found" (ppr rdr_name)
_ -> pprPanic "VectMonad.lookupRdrName: ambiguous" (ppr rdr_name)
lookupRdrVar :: RdrName -> VM Var
lookupRdrVar rdr_name
= do
name <- lookupRdrName rdr_name
liftDs (dsLookupGlobalId name)
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)
......@@ -422,15 +408,15 @@ defTyConPAs ps = updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
[(tyConName tc, pa) | (tc, pa) <- ps] }
defTyConRdrPAs :: [(Name, RdrName)] -> VM ()
defTyConRdrPAs ps
defTyConBuiltinPAs :: [(Name, Module, FastString)] -> VM ()
defTyConBuiltinPAs ps
= do
pas <- mapM lookupRdrVar rdr_names
pas <- zipWithM lookupExternalVar mods fss
updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
(zip tcs pas) }
where
(tcs, rdr_names) = unzip ps
(tcs, mods, fss) = unzip3 ps
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
......@@ -525,8 +511,7 @@ initV hsc_env guts info p
r <- runVM p builtins (initGlobalEnv info
instEnvs
famInstEnvs
builtins
(mg_rdr_env guts))
builtins)
emptyLocalEnv
case r of
Yes genv _ x -> return $ Just (new_info genv, x)
......
......@@ -30,8 +30,7 @@ import NameEnv
import Id
import MkId ( unwrapFamInstScrut )
import OccName
import RdrName ( RdrName, mkRdrQual )
import Module ( mkModuleNameFS )
import Module ( Module )
import DsMonad hiding (mapAndUnzipM)
import DsUtils ( mkCoreTup, mkCoreTupTy )
......@@ -46,23 +45,18 @@ import Outputable
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
mkNDPVar :: String -> RdrName
mkNDPVar s = mkRdrQual nDP_BUILTIN (mkVarOcc s)
mkNDPVarFS :: FastString -> RdrName
mkNDPVarFS fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs)
builtin_PAs :: [(Name, RdrName)]
builtin_PAs :: [(Name, Module, FastString)]
builtin_PAs = [
mk closureTyConName FSLIT("dPA_Clo")
, mk intTyConName FSLIT("dPA_Int")
]
++ tups
where
mk name fs = (name, mkNDPVarFS fs)
mk name fs = (name, nDP_INSTANCES, fs)
tups = mk_tup 0 : map mk_tup [2..3]
mk_tup n = (getName $ tupleTyCon Boxed n, mkNDPVar $ "dPA_" ++ show n)
mk_tup n = (getName $ tupleTyCon Boxed n, nDP_INSTANCES,
mkFastString $ "dPA_" ++ show n)
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
......@@ -80,7 +74,7 @@ vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
defTyConRdrPAs builtin_PAs
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