- lc_bndr <- newLocalVar FSLIT("lc") intTy
- (varg : vbndrs, larg : lbndrs, (vbody, lbody))
- <- vectBndrsIn (arg : cenv_vars info)
- (vectExpr (Var lc_bndr) body)
-
- venv_bndr <- newLocalVar FSLIT("env") vty
- lenv_bndr <- newLocalVar FSLIT("env") lty
-
- let vcase = bind_venv (Var venv_bndr) vbody vbndrs
- lcase <- bind_lenv (Var lenv_bndr) lbody lc_bndr lbndrs
- return (mkLams [venv_bndr, varg] vcase, mkLams [lenv_bndr, larg] lcase)
- where
- vty = cenv_vty info
- lty = cenv_lty info
-
- arity = length (cenv_vars info)
-
- bind_venv venv vbody [] = vbody
- bind_venv venv vbody [vbndr] = Let (NonRec vbndr venv) vbody
- bind_venv venv vbody vbndrs
- = Case venv (mkWildId vty) (exprType vbody)
- [(DataAlt (tupleCon Boxed arity), vbndrs, vbody)]
-
- bind_lenv lenv lbody lc_bndr [lbndr]
- = do
- lengthPA <- builtin lengthPAVar
- return . Let (NonRec lbndr lenv)
- $ Case (mkApps (Var lengthPA) [Type vty, (Var lbndr)])
- lc_bndr
- intTy
- [(DEFAULT, [], lbody)]
-
- bind_lenv lenv lbody lc_bndr lbndrs
- = return
- $ Case (unwrapFamInstScrut (cenv_repr_tycon info)
- (cenv_repr_tyargs info)
- lenv)
- (mkWildId lty)
- (exprType lbody)
- [(DataAlt (cenv_repr_datacon info), lc_bndr : lbndrs, lbody)]
-
-vectTyAppExpr :: CoreExpr -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
-vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
-vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
-
--- ----------------------------------------------------------------------------
--- Types
-
-vectTyCon :: TyCon -> VM TyCon
-vectTyCon tc
- | isFunTyCon tc = builtin closureTyCon
- | isBoxedTupleTyCon tc = return tc
- | isUnLiftedTyCon tc = return tc
- | otherwise = do
- r <- lookupTyCon tc
- case r of
- Just tc' -> return tc'
-
- -- FIXME: just for now
- Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
-
-vectType :: Type -> VM Type
-vectType ty | Just ty' <- coreView ty = vectType ty
-vectType (TyVarTy tv) = return $ TyVarTy tv
-vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
-vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
-vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
- (mapM vectType [ty1,ty2])
-vectType (ForAllTy tv ty)
- = do
- r <- paDictArgType tv
- ty' <- vectType ty
- return $ ForAllTy tv (wrap r ty')
- where
- wrap Nothing = id
- wrap (Just pa_ty) = FunTy pa_ty
-
-vectType ty = pprPanic "vectType:" (ppr ty)
+ tyvars <- localTyVars
+ (vs, vvs) <- readLEnv $ \env ->
+ unzip [(var, vv) | var <- varSetElems fvs
+ , Just vv <- [lookupVarEnv (local_vars env) var]]
+
+ arg_tys <- mapM (vectType . idType) bs
+ res_ty <- vectType (exprType $ deAnnotate body)
+
+ buildClosures tyvars vvs arg_tys res_ty
+ . hoistPolyVExpr tyvars
+ $ do
+ lc <- builtin liftingContext
+ (vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
+ (vectExpr body)
+ return $ vLams lc vbndrs vbody
+
+vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
+vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
+vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)