projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Refactoring
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
944f8c8
..
1beb550
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-3,7
+3,8
@@
module VectMonad (
VM,
noV, tryV, maybeV, orElseV, fixV, localV, closedV, initV,
VM,
noV, tryV, maybeV, orElseV, fixV, localV, closedV, initV,
- cloneName, newExportedVar, newLocalVar, newTyVar,
+ cloneName, cloneId,
+ newExportedVar, newLocalVar, newDummyVar, newTyVar,
Builtins(..), paDictTyCon, paDictDataCon,
builtin,
Builtins(..), paDictTyCon, paDictDataCon,
builtin,
@@
-15,6
+16,8
@@
module VectMonad (
LocalEnv(..),
readLEnv, setLEnv, updLEnv,
LocalEnv(..),
readLEnv, setLEnv, updLEnv,
+ getBindName, inBind,
+
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
@@
-37,6
+40,7
@@
import Id
import OccName
import Name
import NameEnv
import OccName
import Name
import NameEnv
+import TysPrim ( intPrimTy )
import DsMonad
import PrelNames
import DsMonad
import PrelNames
@@
-67,6
+71,7
@@
data Builtins = Builtins {
, lengthPAVar :: Var
, replicatePAVar :: Var
, emptyPAVar :: Var
, lengthPAVar :: Var
, replicatePAVar :: Var
, emptyPAVar :: Var
+ , liftingContext :: Var
}
paDictTyCon :: Builtins -> TyCon
}
paDictTyCon :: Builtins -> TyCon
@@
-90,6
+95,9
@@
initBuiltins
replicatePAVar <- dsLookupGlobalId replicatePAName
emptyPAVar <- dsLookupGlobalId emptyPAName
replicatePAVar <- dsLookupGlobalId replicatePAName
emptyPAVar <- dsLookupGlobalId emptyPAName
+ liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
+ newUnique
+
return $ Builtins {
parrayTyCon = parrayTyCon
, paClass = paClass
return $ Builtins {
parrayTyCon = parrayTyCon
, paClass = paClass
@@
-101,12
+109,13
@@
initBuiltins
, lengthPAVar = lengthPAVar
, replicatePAVar = replicatePAVar
, emptyPAVar = emptyPAVar
, lengthPAVar = lengthPAVar
, replicatePAVar = replicatePAVar
, emptyPAVar = emptyPAVar
+ , liftingContext = liftingContext
}
data GlobalEnv = GlobalEnv {
-- Mapping from global variables to their vectorised versions.
--
}
data GlobalEnv = GlobalEnv {
-- Mapping from global variables to their vectorised versions.
--
- global_vars :: VarEnv CoreExpr
+ global_vars :: VarEnv Var
-- Exported variables which have a vectorised version
--
-- Exported variables which have a vectorised version
--
@@
-140,7
+149,7
@@
data LocalEnv = LocalEnv {
-- Mapping from local variables to their vectorised and
-- lifted versions
--
-- Mapping from local variables to their vectorised and
-- lifted versions
--
- local_vars :: VarEnv (CoreExpr, CoreExpr)
+ local_vars :: VarEnv (Var, Var)
-- In-scope type variables
--
-- In-scope type variables
--
@@
-148,13
+157,16
@@
data LocalEnv = LocalEnv {
-- Mapping from tyvars to their PA dictionaries
, local_tyvar_pa :: VarEnv CoreExpr
-- Mapping from tyvars to their PA dictionaries
, local_tyvar_pa :: VarEnv CoreExpr
+
+ -- Local binding name
+ , local_bind_name :: FastString
}
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs bi
= GlobalEnv {
}
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs bi
= GlobalEnv {
- global_vars = mapVarEnv (Var . snd) $ vectInfoVar info
+ global_vars = mapVarEnv snd $ vectInfoVar info
, global_exported_vars = emptyVarEnv
, global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
(tyConName funTyCon) (closureTyCon bi)
, global_exported_vars = emptyVarEnv
, global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
(tyConName funTyCon) (closureTyCon bi)
@@
-176,6
+188,7
@@
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
+ , local_bind_name = FSLIT("fn")
}
-- FIXME
}
-- FIXME
@@
-207,6
+220,9
@@
instance Monad VM where
noV :: VM a
noV = VM $ \_ _ _ -> return No
noV :: VM a
noV = VM $ \_ _ _ -> return No
+traceNoV :: String -> SDoc -> VM a
+traceNoV s d = pprTrace s d noV
+
tryV :: VM a -> VM (Maybe a)
tryV (VM p) = VM $ \bi genv lenv ->
do
tryV :: VM a -> VM (Maybe a)
tryV (VM p) = VM $ \bi genv lenv ->
do
@@
-218,6
+234,9
@@
tryV (VM p) = VM $ \bi genv lenv ->
maybeV :: VM (Maybe a) -> VM a
maybeV p = maybe noV return =<< p
maybeV :: VM (Maybe a) -> VM a
maybeV p = maybe noV return =<< p
+traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
+traceMaybeV s d p = maybe (traceNoV s d) return =<< p
+
orElseV :: VM a -> VM a -> VM a
orElseV p q = maybe q return =<< tryV p
orElseV :: VM a -> VM a -> VM a
orElseV p q = maybe q return =<< tryV p
@@
-236,7
+255,7
@@
localV p = do
closedV :: VM a -> VM a
closedV p = do
env <- readLEnv id
closedV :: VM a -> VM a
closedV p = do
env <- readLEnv id
- setLEnv emptyLocalEnv
+ setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
x <- p
setLEnv env
return x
x <- p
setLEnv env
return x
@@
-271,6
+290,14
@@
getInstEnv = readGEnv global_inst_env
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
+getBindName :: VM FastString
+getBindName = readLEnv local_bind_name
+
+inBind :: Id -> VM a -> VM a
+inBind id p
+ = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
+ p
+
cloneName :: (OccName -> OccName) -> Name -> VM Name
cloneName mk_occ name = liftM make (liftDs newUnique)
where
cloneName :: (OccName -> OccName) -> Name -> VM Name
cloneName mk_occ name = liftM make (liftDs newUnique)
where
@@
-281,6
+308,14
@@
cloneName mk_occ name = liftM make (liftDs newUnique)
(nameSrcSpan name)
| otherwise = mkSystemName u occ_name
(nameSrcSpan name)
| otherwise = mkSystemName u occ_name
+cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
+cloneId mk_occ id ty
+ = do
+ name <- cloneName mk_occ (getName id)
+ let id' | isExportedId id = Id.mkExportedLocalId name ty
+ | otherwise = Id.mkLocalId name ty
+ return id'
+
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
@@
-297,6
+332,9
@@
newLocalVar fs ty
u <- liftDs newUnique
return $ mkSysLocal fs u ty
u <- liftDs newUnique
return $ mkSysLocal fs u ty
+newDummyVar :: Type -> VM Var
+newDummyVar = newLocalVar FSLIT("ds")
+
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
= do
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
= do
@@
-305,21
+343,22
@@
newTyVar fs k
defGlobalVar :: Var -> Var -> VM ()
defGlobalVar v v' = updGEnv $ \env ->
defGlobalVar :: Var -> Var -> VM ()
defGlobalVar v v' = updGEnv $ \env ->
- env { global_vars = extendVarEnv (global_vars env) v (Var v')
+ env { global_vars = extendVarEnv (global_vars env) v v'
, global_exported_vars = upd (global_exported_vars env)
}
where
upd env | isExportedId v = extendVarEnv env v (v, v')
| otherwise = env
, global_exported_vars = upd (global_exported_vars env)
}
where
upd env | isExportedId v = extendVarEnv env v (v, v')
| otherwise = env
-lookupVar :: Var -> VM (Scope CoreExpr (CoreExpr, CoreExpr))
+lookupVar :: Var -> VM (Scope Var (Var, Var))
lookupVar v
= do
r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
case r of
Just e -> return (Local e)
Nothing -> liftM Global
lookupVar v
= do
r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
case r of
Just e -> return (Local e)
Nothing -> liftM Global
- $ maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
+ $ traceMaybeV "lookupVar" (ppr v)
+ (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
@@
-376,7
+415,7
@@
lookupInst cls tys
where
inst_tys' = [ty | Right ty <- inst_tys]
noFlexiVar = all isRight inst_tys
where
inst_tys' = [ty | Right ty <- inst_tys]
noFlexiVar = all isRight inst_tys
- _other -> noV
+ _other -> traceNoV "lookupInst" (ppr cls <+> ppr tys)
}
where
isRight (Left _) = False
}
where
isRight (Left _) = False