+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module VectMonad (
Scope(..),
VM,
cloneName, cloneId,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..),
- builtin,
+ Builtins(..), sumTyCon, prodTyCon,
+ builtin, builtins,
GlobalEnv(..),
setFamInstEnv,
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
- lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
+ lookupTyConPA, defTyConPA, defTyConPAs,
+ lookupTyConPR,
+ lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
#include "HsVersions.h"
+import VectBuiltIn
+
import HscTypes
import CoreSyn
import TyCon
import DataCon
import Type
+import Class
import Var
import VarEnv
import Id
import TysPrim ( intPrimTy )
import Module
import IfaceEnv
+import IOEnv ( ioToIOEnv )
import DsMonad
import PrelNames
-- ----------------------------------------------------------------------------
-- Vectorisation monad
-data Builtins = Builtins {
- parrayTyCon :: TyCon
- , paTyCon :: TyCon
- , paDataCon :: DataCon
- , preprTyCon :: TyCon
- , embedTyCon :: TyCon
- , embedDataCon :: DataCon
- , crossTyCon :: TyCon
- , crossDataCon :: DataCon
- , plusTyCon :: TyCon
- , leftDataCon :: DataCon
- , rightDataCon :: DataCon
- , closureTyCon :: TyCon
- , mkClosureVar :: Var
- , applyClosureVar :: Var
- , mkClosurePVar :: Var
- , applyClosurePVar :: Var
- , lengthPAVar :: Var
- , replicatePAVar :: Var
- , emptyPAVar :: Var
- -- , packPAVar :: Var
- -- , combinePAVar :: Var
- , intEqPAVar :: Var
- , liftingContext :: Var
- }
-
-initBuiltins :: DsM Builtins
-initBuiltins
- = do
- parrayTyCon <- dsLookupTyCon parrayTyConName
- paTyCon <- dsLookupTyCon paTyConName
- let [paDataCon] = tyConDataCons paTyCon
- preprTyCon <- dsLookupTyCon preprTyConName
- embedTyCon <- dsLookupTyCon embedTyConName
- let [embedDataCon] = tyConDataCons embedTyCon
- crossTyCon <- dsLookupTyCon ndpCrossTyConName
- let [crossDataCon] = tyConDataCons crossTyCon
- plusTyCon <- dsLookupTyCon ndpPlusTyConName
- let [leftDataCon, rightDataCon] = tyConDataCons plusTyCon
- closureTyCon <- dsLookupTyCon closureTyConName
-
- mkClosureVar <- dsLookupGlobalId mkClosureName
- applyClosureVar <- dsLookupGlobalId applyClosureName
- mkClosurePVar <- dsLookupGlobalId mkClosurePName
- applyClosurePVar <- dsLookupGlobalId applyClosurePName
- lengthPAVar <- dsLookupGlobalId lengthPAName
- replicatePAVar <- dsLookupGlobalId replicatePAName
- emptyPAVar <- dsLookupGlobalId emptyPAName
- -- packPAVar <- dsLookupGlobalId packPAName
- -- combinePAVar <- dsLookupGlobalId combinePAName
- intEqPAVar <- dsLookupGlobalId intEqPAName
-
- liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
- newUnique
-
- return $ Builtins {
- parrayTyCon = parrayTyCon
- , paTyCon = paTyCon
- , paDataCon = paDataCon
- , preprTyCon = preprTyCon
- , embedTyCon = embedTyCon
- , embedDataCon = embedDataCon
- , crossTyCon = crossTyCon
- , crossDataCon = crossDataCon
- , plusTyCon = plusTyCon
- , leftDataCon = leftDataCon
- , rightDataCon = rightDataCon
- , closureTyCon = closureTyCon
- , mkClosureVar = mkClosureVar
- , applyClosureVar = applyClosureVar
- , mkClosurePVar = mkClosurePVar
- , applyClosurePVar = applyClosurePVar
- , lengthPAVar = lengthPAVar
- , replicatePAVar = replicatePAVar
- , emptyPAVar = emptyPAVar
- -- , packPAVar = packPAVar
- -- , combinePAVar = combinePAVar
- , intEqPAVar = intEqPAVar
- , liftingContext = liftingContext
- }
-
data GlobalEnv = GlobalEnv {
-- Mapping from global variables to their vectorised versions.
--
--
, global_pa_funs :: NameEnv Var
+ -- Mapping from TyCons to their PR dfuns
+ , global_pr_funs :: NameEnv Var
+
-- External package inst-env & home-package inst-env for class
-- instances
--
-- 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_pr_funs = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
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 }
+
+setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPRFunsEnv ps genv
+ = genv { global_pr_funs = mkNameEnv ps }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
+builtins :: (a -> Builtins -> b) -> VM (a -> b)
+builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
+
readGEnv :: (GlobalEnv -> a) -> VM a
readGEnv f = VM $ \bi genv lenv -> return (Yes genv lenv (f genv))
= 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
defDataCon dc dc' = updGEnv $ \env ->
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
+lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
+lookupPrimPArray = liftDs . primPArray
+
+lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
+lookupPrimMethod tycon = liftDs . primMethod tycon
+
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
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
+lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+
+lookupTyConPR :: TyCon -> VM (Maybe Var)
+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
initV hsc_env guts info p
= do
- eps <- hscEPS hsc_env
- let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
- let instEnvs = (eps_inst_env eps, mg_inst_env guts)
-
Just r <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts)
(mg_types guts)
- (go instEnvs famInstEnvs)
+ go
return r
where
- go instEnvs famInstEnvs =
+ go =
do
- builtins <- initBuiltins
- r <- runVM p builtins (initGlobalEnv info
- instEnvs
- famInstEnvs
- builtins)
- emptyLocalEnv
+ builtins <- initBuiltins
+ let builtin_tycons = initBuiltinTyCons builtins
+ builtin_pas <- initBuiltinPAs builtins
+ builtin_prs <- initBuiltinPRs builtins
+
+ eps <- ioToIOEnv $ hscEPS hsc_env
+ let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+ instEnvs = (eps_inst_env eps, mg_inst_env guts)
+
+ let genv = extendTyConsEnv builtin_tycons
+ . extendPAFunsEnv builtin_pas
+ . setPRFunsEnv builtin_prs
+ $ 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
projects / ghc-hetmet.git / blobdiff