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