+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
+
+-- Inline ---------------------------------------------------------------------
+-- | Records whether we should inline a particular binding.
+data Inline
+ = Inline Arity
+ | DontInline
+
+-- | Add to the arity contained within an `Inline`, if any.
+addInlineArity :: Inline -> Int -> Inline
+addInlineArity (Inline m) n = Inline (m+n)
+addInlineArity DontInline _ = DontInline
+
+-- | Says to always inline a binding.
+inlineMe :: Inline
+inlineMe = Inline 0
+
+
+-- Hoising --------------------------------------------------------------------
+hoistBinding :: Var -> CoreExpr -> VM ()
+hoistBinding v e = updGEnv $ \env ->
+ env { global_bindings = (v,e) : global_bindings env }
+
+hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
+hoistExpr fs expr inl
+ = do
+ var <- mk_inline `liftM` newLocalVar fs (exprType expr)
+ hoistBinding var expr
+ return var
+ where
+ mk_inline var = case inl of
+ Inline arity -> var `setIdUnfolding`
+ mkInlineRule expr (Just arity)
+ DontInline -> var
+
+hoistVExpr :: VExpr -> Inline -> VM VVar
+hoistVExpr (ve, le) inl
+ = do
+ fs <- getBindName
+ vv <- hoistExpr ('v' `consFS` fs) ve inl
+ lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
+ return (vv, lv)
+
+hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
+hoistPolyVExpr tvs inline p
+ = do
+ inline' <- liftM (addInlineArity inline) (polyArity tvs)
+ expr <- closedV . polyAbstract tvs $ \args ->
+ liftM (mapVect (mkLams $ tvs ++ args)) p
+ fn <- hoistVExpr expr inline'
+ polyVApply (vVar fn) (mkTyVarTys tvs)
+
+takeHoisted :: VM [(Var, CoreExpr)]
+takeHoisted
+ = do
+ env <- readGEnv id
+ 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)
+-}
+
+