+ 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