+wrapPR :: Type -> VM CoreExpr
+wrapPR ty
+ = do
+ Just 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])
+ (paMethod replicatePDVar "replicatePD" (exprType x))
+
+emptyPD :: Type -> VM CoreExpr
+emptyPD = paMethod emptyPDVar "emptyPD"
+
+packByTagPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+ -> VM CoreExpr
+packByTagPD ty xs len tags t
+ = liftM (`mkApps` [xs, len, tags, t])
+ (paMethod packByTagPDVar "packByTagPD" ty)
+
+combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr]
+ -> VM CoreExpr
+combinePD ty len sel xs
+ = liftM (`mkApps` (len : sel : xs))
+ (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty)
+ where
+ n = length xs
+
+-- | Like `replicatePD` but use the lifting context in the vectoriser state.
+liftPD :: CoreExpr -> VM CoreExpr
+liftPD x
+ = do
+ lc <- builtin liftingContext
+ replicatePD (Var lc) x
+
+zipScalars :: [Type] -> Type -> VM CoreExpr
+zipScalars arg_tys res_ty
+ = do
+ scalar <- builtin scalarClass
+ (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args
+ zipf <- builtin (scalarZip $ length arg_tys)
+ return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns
+ where
+ ty_args = arg_tys ++ [res_ty]
+
+scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr
+scalarClosure arg_tys res_ty scalar_fun array_fun
+ = do
+ ctr <- builtin (closureCtrFun $ length arg_tys)
+ Just pas <- liftM sequence $ mapM paDictOfType (init arg_tys)
+ return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty])
+ `mkApps` (pas ++ [scalar_fun, array_fun])
+
+newLocalVVar :: FastString -> Type -> VM VVar
+newLocalVVar fs vty
+ = do
+ lty <- mkPDataType vty
+ vv <- newLocalVar fs vty
+ lv <- newLocalVar fs lty
+ return (vv,lv)
+
+polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a
+polyAbstract tvs p
+ = localV
+ $ do
+ mdicts <- mapM mk_dict_var tvs
+ zipWithM_ (\tv -> maybe (defLocalTyVar tv)
+ (defLocalTyVarWithPA tv . Var)) tvs mdicts
+ p (mk_args mdicts)
+ where
+ mk_dict_var tv = do
+ r <- paDictArgType tv
+ case r of
+ Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
+ Nothing -> return Nothing
+
+ mk_args mdicts = [dict | Just dict <- mdicts]
+
+polyArity :: [TyVar] -> VM Int
+polyArity tvs = do
+ tys <- mapM paDictArgType tvs
+ return $ length [() | Just _ <- tys]
+
+polyApply :: CoreExpr -> [Type] -> VM CoreExpr
+polyApply expr tys
+ = do Just dicts <- liftM sequence $ mapM paDictOfType tys
+ return $ expr `mkTyApps` tys `mkApps` dicts
+
+polyVApply :: VExpr -> [Type] -> VM VExpr
+polyVApply expr tys
+ = do Just dicts <- liftM sequence $ mapM paDictOfType tys
+ return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
+
+
+{-
+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)
+-}
+
+