+{-# 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,
noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
liftDs,
- cloneName, cloneId,
+ cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon,
+ Builtins(..), sumTyCon, prodTyCon, uarrTy, intPrimArrayTy,
+ combinePAVar,
builtin, builtins,
GlobalEnv(..),
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
+ lookupBoxedTyCon,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
import TysPrim ( intPrimTy )
import Module
import IfaceEnv
-import IOEnv ( ioToIOEnv )
+import IOEnv ( liftIO )
import DsMonad
import PrelNames
-- Mapping from TyCons to their PR dfuns
, global_pr_funs :: NameEnv Var
+ -- Mapping from unboxed TyCons to their boxed versions
+ , global_boxed_tycons :: NameEnv TyCon
+
-- External package inst-env & home-package inst-env for class
-- instances
--
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
- , global_pr_funs = emptyVarEnv
+ , global_pr_funs = emptyNameEnv
+ , global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
}
+extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
+extendImportedVarsEnv ps genv
+ = genv { global_vars = extendVarEnvList (global_vars genv) ps }
+
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamInstEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
+extendDataConsEnv ps genv
+ = genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
+
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
+setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+setBoxedTyConsEnv ps genv
+ = genv { global_boxed_tycons = mkNameEnv ps }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
| otherwise = Id.mkLocalId name ty
return id'
+cloneVar :: Var -> VM Var
+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
+
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
lookupDataCon :: DataCon -> VM (Maybe DataCon)
-lookupDataCon dc = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
+lookupDataCon dc
+ | isTupleTyCon (dataConTyCon dc) = return (Just dc)
+ | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
defDataCon :: DataCon -> DataCon -> VM ()
defDataCon dc dc' = updGEnv $ \env ->
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
+lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
+ (tyConName tc)
+
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
env { local_tyvars = tv : local_tyvars env
go =
do
builtins <- initBuiltins
- let builtin_tycons = initBuiltinTyCons 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
- eps <- ioToIOEnv $ hscEPS hsc_env
+ 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)
- let genv = extendTyConsEnv builtin_tycons
+ let genv = extendImportedVarsEnv builtin_vars
+ . extendTyConsEnv builtin_tycons
+ . extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv