- 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)
+ vect_dc <- maybeV (lookupDataCon dc)
+ let tag = mkDataConTag vect_dc
+ fvs = freeVarsOf body `delVarSetList` bndrs
+ (vect_bndrs, lift_bndrs, vbody)
+ <- vect_alt_bndrs bndrs
+ $ \len -> packLiftingContext len sel tag fvs vty lty
+ $ vectExpr body
+
+ return (vect_dc, vect_bndrs, lift_bndrs, vbody)
+ proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt"
+
+ vect_alt_bndrs [] p
+ = do
+ void_tc <- builtin voidTyCon
+ let void_ty = mkTyConApp void_tc []
+ arr_ty <- mkPArrayType void_ty
+ bndr <- newLocalVar (fsLit "voids") arr_ty
+ len <- lengthPA void_ty (Var bndr)
+ e <- p len
+ return ([], [bndr], e)
+
+ vect_alt_bndrs bndrs p
+ = localV
+ $ do
+ vbndrs <- mapM vectBndr bndrs
+ let (vect_bndrs, lift_bndrs) = unzip vbndrs
+ vv : _ = vect_bndrs
+ lv : _ = lift_bndrs
+ len <- lengthPA (idType vv) (Var lv)
+ e <- p len
+ return (vect_bndrs, lift_bndrs, e)
+
+ mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)
+
+packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet
+ -> Type -> Type -> VM VExpr -> VM VExpr
+packLiftingContext len shape tag fvs vty lty p