module VectBuiltIn (
Builtins(..), sumTyCon, prodTyCon, combinePAVar,
initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs,
+ initBuiltinBoxedTyCons,
primMethod, primPArray
) where
import TypeRep ( funTyCon )
import Type ( Type )
import TysPrim
-import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
+import TysWiredIn ( unitTyCon, tupleTyCon, intTyCon, intTyConName )
import Module
import BasicTypes ( Boxity(..) )
mk_prod n = (tyConName $ prodTyCon n bi, nDP_REPR,
mkFastString ("dPR_" ++ show n))
+initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
+initBuiltinBoxedTyCons = return . builtinBoxedTyCons
+
+builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
+builtinBoxedTyCons bi =
+ [(tyConName intPrimTyCon, intTyCon)]
+
externalVar :: Module -> FastString -> DsM Var
externalVar mod fs
= dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
+ lookupBoxedTyCon,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
-- 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_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_pr_funs = emptyNameEnv
+ , global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
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 = []
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
let builtin_tycons = initBuiltinTyCons builtins
builtin_pas <- initBuiltinPAs builtins
builtin_prs <- initBuiltinPRs builtins
+ builtin_boxed <- initBuiltinBoxedTyCons builtins
eps <- ioToIOEnv $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
- (mapM vectType [ty1,ty2])
+ (mapM vectAndBoxType [ty1,ty2])
vectType ty@(ForAllTy _ _)
= do
mdicts <- mapM paDictArgType tyvars
vectType ty = pprPanic "vectType:" (ppr ty)
+vectAndBoxType :: Type -> VM Type
+vectAndBoxType ty = vectType ty >>= boxType
+
+-- ----------------------------------------------------------------------------
+-- Boxing
+
+boxType :: Type -> VM Type
+boxType ty
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isUnLiftedTyCon tycon
+ = do
+ r <- lookupBoxedTyCon tycon
+ case r of
+ Just tycon' -> return $ mkTyConApp tycon' []
+ Nothing -> return ty
+boxType ty = return ty
+
-- ----------------------------------------------------------------------------
-- Type definitions
tycon <- builtin (prodTyCon arity)
let [data_con] = tyConDataCons tycon
- (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys
+ tys' <- mapM boxType tys
+ (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys'
let [arr_data_con] = tyConDataCons arr_tycon
return $ ProdRepr {
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
+boxExpr :: Type -> VExpr -> VM VExpr
+boxExpr ty (vexpr, lexpr)
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isUnLiftedTyCon tycon
+ = do
+ r <- lookupBoxedTyCon tycon
+ case r of
+ Just tycon' -> let [dc] = tyConDataCons tycon'
+ in
+ return (mkConApp dc [vexpr], lexpr)
+ Nothing -> return (vexpr, lexpr)
+
+
mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do