prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
paMethod, mkPR, lengthPA, replicatePA, emptyPA, packPA, combinePA, liftPA,
+ zipScalars, scalarClosure,
polyAbstract, polyApply, polyVApply,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
import TyCon
import DataCon
import Var
-import Id ( mkWildId )
import MkId ( unwrapFamInstScrut )
import TysWiredIn
import BasicTypes ( Boxity(..) )
collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
collectAnnValBinders expr = go [] expr
where
- go bs (_, AnnLam b e) | isIdVar b = go (b:bs) e
- go bs e = (reverse bs, e)
+ go bs (_, AnnLam b e) | isId b = go (b:bs) e
+ go bs e = (reverse bs, e)
isAnnTypeArg :: AnnExpr b ann -> Bool
isAnnTypeArg (_, AnnType _) = True
lc <- builtin liftingContext
replicatePA (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)
+ pas <- 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
buildClosures _ _ [] _ mk_body
= mk_body
buildClosures tvs vars [arg_ty] res_ty mk_body
- = buildClosure tvs vars arg_ty res_ty mk_body
+ = liftM vInlineMe (buildClosure tvs vars arg_ty res_ty mk_body)
buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
= do
res_ty' <- mkClosureTypes arg_tys res_ty
arg <- newLocalVVar (fsLit "x") arg_ty
- buildClosure tvs vars arg_ty res_ty'
+ liftM vInlineMe
+ . buildClosure tvs vars arg_ty res_ty'
. hoistPolyVExpr tvs
$ do
lc <- builtin liftingContext
body <- mk_body
body' <- bind (vVar env_bndr)
(vVarApps lc body (vars ++ [arg_bndr]))
- return (vLamsWithoutLC [env_bndr, arg_bndr] body')
+ return . vInlineMe $ vLamsWithoutLC [env_bndr, arg_bndr] body'
mkClosure arg_ty res_ty env_ty fn env
mkVectEnv [] [] = (unitTy, Var unitDataConId, \_ body -> body)
mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
mkVectEnv tys vs = (ty, mkCoreTup (map Var vs),
- \env body -> Case env (mkWildId ty) (exprType body)
+ \env body -> mkWildCase env ty (exprType body)
[(DataAlt (tupleCon Boxed (length vs)), vs, body)])
where
ty = mkCoreTupTy tys
bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
in
- return $ Case scrut (mkWildId (exprType scrut))
+ return $ mkWildCase scrut (exprType scrut)
(exprType body)
[(DataAlt env_con, lc : bndrs, body)]
return (env, bind)