projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
catch SIGHUP and SIGTERM and raise an exception (#3656)
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
56f5b8f
..
98701f0
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-2,14
+2,16
@@
module VectMonad (
Scope(..),
VM,
Scope(..),
VM,
- noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV,
+ noV, traceNoV, ensureV, traceEnsureV, tryV, maybeV, traceMaybeV, orElseV,
+ onlyIfV, fixV, localV, closedV,
initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
liftDs,
cloneName, cloneId, cloneVar,
initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
liftDs,
cloneName, cloneId, cloneVar,
- newExportedVar, newLocalVar, newDummyVar, newTyVar,
+ newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon,
- combinePAVar,
+ Builtins(..), sumTyCon, prodTyCon, prodDataCon,
+ selTy, selReplicate, selPick, selTags, selElements,
+ combinePDVar, scalarZip, closureCtrFun,
builtin, builtins,
GlobalEnv(..),
builtin, builtins,
GlobalEnv(..),
@@
-21,7
+23,7
@@
module VectMonad (
getBindName, inBind,
getBindName, inBind,
- lookupVar, defGlobalVar,
+ lookupVar, defGlobalVar, globalScalars,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
@@
-30,7
+32,7
@@
module VectMonad (
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
- {-lookupInst,-} lookupFamInst
+ lookupInst, lookupFamInst
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-40,15
+42,16
@@
import VectBuiltIn
import HscTypes hiding ( MonadThings(..) )
import Module ( PackageId )
import CoreSyn
import HscTypes hiding ( MonadThings(..) )
import Module ( PackageId )
import CoreSyn
+import Class
import TyCon
import DataCon
import Type
import Var
import TyCon
import DataCon
import Type
import Var
+import VarSet
import VarEnv
import Id
import Name
import NameEnv
import VarEnv
import Id
import Name
import NameEnv
-import IOEnv ( liftIO )
import DsMonad
import DsMonad
@@
-71,6
+74,10
@@
data GlobalEnv = GlobalEnv {
--
global_vars :: VarEnv Var
--
global_vars :: VarEnv Var
+ -- Purely scalar variables. Code which mentions only these
+ -- variables doesn't have to be lifted.
+ , global_scalars :: VarSet
+
-- Exported variables which have a vectorised version
--
, global_exported_vars :: VarEnv (Var, Var)
-- Exported variables which have a vectorised version
--
, global_exported_vars :: VarEnv (Var, Var)
@@
-130,6
+137,7
@@
initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
initGlobalEnv info instEnvs famInstEnvs
= GlobalEnv {
global_vars = mapVarEnv snd $ vectInfoVar info
initGlobalEnv info instEnvs famInstEnvs
= GlobalEnv {
global_vars = mapVarEnv snd $ vectInfoVar info
+ , global_scalars = emptyVarSet
, global_exported_vars = emptyVarEnv
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_exported_vars = emptyVarEnv
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
@@
-145,6
+153,10
@@
extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
extendImportedVarsEnv ps genv
= genv { global_vars = extendVarEnvList (global_vars genv) ps }
extendImportedVarsEnv ps genv
= genv { global_vars = extendVarEnvList (global_vars genv) ps }
+extendScalars :: [Var] -> GlobalEnv -> GlobalEnv
+extendScalars vs genv
+ = genv { global_scalars = extendVarSetList (global_scalars genv) vs }
+
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamInstEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamInstEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
@@
-231,6
+243,17
@@
noV = VM $ \_ _ _ -> return No
traceNoV :: String -> SDoc -> VM a
traceNoV s d = pprTrace s d noV
traceNoV :: String -> SDoc -> VM a
traceNoV s d = pprTrace s d noV
+ensureV :: Bool -> VM ()
+ensureV False = noV
+ensureV True = return ()
+
+onlyIfV :: Bool -> VM a -> VM a
+onlyIfV b p = ensureV b >> p
+
+traceEnsureV :: String -> SDoc -> Bool -> VM ()
+traceEnsureV s d False = traceNoV s d
+traceEnsureV _ _ True = return ()
+
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
@@
-301,10
+324,8
@@
setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
-{-
getInstEnv :: VM (InstEnv, InstEnv)
getInstEnv = readGEnv global_inst_env
getInstEnv :: VM (InstEnv, InstEnv)
getInstEnv = readGEnv global_inst_env
--}
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
@@
-354,6
+375,9
@@
newLocalVar fs ty
u <- liftDs newUnique
return $ mkSysLocal fs u ty
u <- liftDs newUnique
return $ mkSysLocal fs u ty
+newLocalVars :: FastString -> [Type] -> VM [Var]
+newLocalVars fs = mapM (newLocalVar fs)
+
newDummyVar :: Type -> VM Var
newDummyVar = newLocalVar (fsLit "vv")
newDummyVar :: Type -> VM Var
newDummyVar = newLocalVar (fsLit "vv")
@@
-382,6
+406,9
@@
lookupVar v
. maybeCantVectoriseM "Variable not vectorised:" (ppr v)
. readGEnv $ \env -> lookupVarEnv (global_vars env) v
. maybeCantVectoriseM "Variable not vectorised:" (ppr v)
. readGEnv $ \env -> lookupVarEnv (global_vars env) v
+globalScalars :: VM VarSet
+globalScalars = readGEnv global_scalars
+
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
| isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
| isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
@@
-453,7
+480,6
@@
localTyVars = readLEnv (reverse . local_tyvars)
-- instances head (i.e., no flexi vars); for details for what this means,
-- see the docs at InstEnv.lookupInstEnv.
--
-- instances head (i.e., no flexi vars); for details for what this means,
-- see the docs at InstEnv.lookupInstEnv.
--
-{-
lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
lookupInst cls tys
= do { instEnv <- getInstEnv
lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
lookupInst cls tys
= do { instEnv <- getInstEnv
@@
-465,12
+491,12
@@
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 -> traceNoV "lookupInst" (ppr cls <+> ppr tys)
+ _other ->
+ pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
}
where
isRight (Left _) = False
isRight (Right _) = True
}
where
isRight (Left _) = False
isRight (Right _) = True
--}
-- Look up the representation tycon of a family instance.
--
-- Look up the representation tycon of a family instance.
--
@@
-517,15
+543,18
@@
initV pkg hsc_env guts info p
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins
- builtin_pas <- initBuiltinPAs builtins
- builtin_prs <- initBuiltinPRs builtins
builtin_boxed <- initBuiltinBoxedTyCons builtins
builtin_boxed <- initBuiltinBoxedTyCons builtins
+ builtin_scalars <- initBuiltinScalars builtins
eps <- liftIO $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
instEnvs = (eps_inst_env eps, mg_inst_env guts)
eps <- liftIO $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
instEnvs = (eps_inst_env eps, mg_inst_env guts)
+ builtin_prs <- initBuiltinPRs builtins instEnvs
+ builtin_pas <- initBuiltinPAs builtins instEnvs
+
let genv = extendImportedVarsEnv builtin_vars
let genv = extendImportedVarsEnv builtin_vars
+ . extendScalars builtin_scalars
. extendTyConsEnv builtin_tycons
. extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas
. extendTyConsEnv builtin_tycons
. extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas