newLocalVVar,
- mkBuiltinCo, voidType,
+ mkBuiltinCo, voidType, mkWrapType,
mkPADictType, mkPArrayType, mkPDataType, mkPReprType, mkPArray,
pdataReprTyCon, pdataReprDataCon, mkVScrut,
- prDFunOfTyCon,
+ prDictOfType, prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
- paMethod, mkPR, replicatePD, emptyPD, packPD,
+ paMethod, wrapPR, replicatePD, emptyPD, packPD,
combinePD,
liftPD,
zipScalars, scalarClosure,
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
voidType :: VM Type
-voidType = mkBuiltinTyConApp voidTyCon []
+voidType = mkBuiltinTyConApp VectMonad.voidTyCon []
+
+mkWrapType :: Type -> VM Type
+mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
mkClosureTypes :: [Type] -> Type -> VM Type
mkClosureTypes = mkBuiltinTyConApps closureTyCon
dicts <- mapM paDictOfType tys
return $ mkApps (mkTyApps dfun tys) dicts
-type PAMethod = (Builtins -> Var, String)
-
paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr
paMethod _ name ty
| Just tycon <- splitPrimTyCon ty
dict <- paDictOfType ty
return $ mkApps (Var fn) [Type ty, dict]
-mkPR :: Type -> VM CoreExpr
-mkPR ty
+prDictOfType :: Type -> VM CoreExpr
+prDictOfType ty = prDictOfTyApp ty_fn ty_args
+ where
+ (ty_fn, ty_args) = splitAppTys ty
+
+prDictOfTyApp :: Type -> [Type] -> VM CoreExpr
+prDictOfTyApp ty_fn ty_args
+ | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
+prDictOfTyApp (TyConApp tc _) ty_args
= do
- fn <- builtin mkPRVar
- dict <- paDictOfType ty
- return $ mkApps (Var fn) [Type ty, dict]
+ dfun <- prDFunOfTyCon tc
+ prDFunApply dfun ty_args
+prDictOfTyApp _ _ = noV
+
+prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+ = do
+ dicts <- mapM prDictOfType tys
+ return $ mkApps (mkTyApps dfun tys) dicts
+
+wrapPR :: Type -> VM CoreExpr
+wrapPR ty
+ = do
+ pa_dict <- paDictOfType ty
+ pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon
+ return $ mkApps pr_dfun [Type ty, pa_dict]
replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr
replicatePD len x = liftM (`mkApps` [len,x])
`mkTyApps` lenv_tyargs
`mkApps` map Var lvs
- vbind env body = mkWildCase venv ty (exprType body)
- [(DataAlt venv_con, vvs, body)]
+ vbind env body = mkWildCase env ty (exprType body)
+ [(DataAlt venv_con, vvs, body)]
lbind env body =
- let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs lenv
+ let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env
in
mkWildCase scrut (exprType scrut) (exprType body)
[(DataAlt lenv_con, lvs, body)]