+vectAlgCase tycon _ty_args scrut bndr ty alts
+ = do
+ vect_tc <- maybeV (lookupTyCon tycon)
+ (vty, lty) <- vectAndLiftType ty
+ repr <- mkRepr vect_tc
+ shape_bndrs <- arrShapeVars repr
+ (len, sel, indices) <- arrSelector repr (map Var shape_bndrs)
+
+ (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel vty lty) alts'
+ let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
+
+ vexpr <- vectExpr scrut
+ (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
+ let [arr_dc] = tyConDataCons arr_tc
+
+ let (vect_scrut, lift_scrut) = vscrut
+ (vect_bodies, lift_bodies) = unzip vbodies
+
+ vdummy <- newDummyVar (exprType vect_scrut)
+ ldummy <- newDummyVar (exprType lift_scrut)
+ let vect_case = Case vect_scrut vdummy vty
+ (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies)
+
+ lbody <- combinePA vty len sel indices lift_bodies
+ let lift_case = Case lift_scrut ldummy lty
+ [(DataAlt arr_dc, shape_bndrs ++ concat lift_bndrss,
+ lbody)]
+
+ return . vLet (vNonRec vbndr vexpr)
+ $ (vect_case, lift_case)
+ where
+ vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
+ | otherwise = vectBndrIn bndr
+
+ alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts
+
+ cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2
+ cmp DEFAULT DEFAULT = EQ
+ cmp DEFAULT _ = LT
+ cmp _ DEFAULT = GT
+ cmp _ _ = panic "vectAlgCase/cmp"
+
+ proc_alt sel vty lty (DataAlt dc, bndrs, body)
+ = do
+ 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