- (vbndr, valts) <- vect_scrut_bndr
- $ mapM (proc_alt arity sel vty lty) alts'
- let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
-
- vexpr <- vectExpr scrut
- (vect_scrut, lift_scrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr)
- let [pdata_dc] = tyConDataCons pdata_tc
-
- let (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)
-
- lc <- builtin liftingContext
- lbody <- combinePD vty (Var lc) sel lift_bodies
- let lift_case = Case lift_scrut ldummy lty
- [(DataAlt pdata_dc, sel_bndr : 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 arity sel vty lty (DataAlt dc, bndrs, body)
- = do
- vect_dc <- maybeV (lookupDataCon dc)
- let ntag = dataConTagZ vect_dc
- tag = mkDataConTag vect_dc
- fvs = freeVarsOf body `delVarSetList` bndrs
-
- sel_tags <- liftM (`App` sel) (builtin (selTags arity))
- lc <- builtin liftingContext
- elems <- builtin (selElements arity ntag)
-
- (vbndrs, vbody)
- <- vectBndrsIn bndrs
- . localV
- $ do
- binds <- mapM (pack_var (Var lc) sel_tags tag)
- . filter isLocalId
- $ varSetElems fvs
- (ve, le) <- vectExpr body
- return (ve, Case (elems `App` sel) lc lty
- [(DEFAULT, [], (mkLets (concat binds) le))])
- -- empty <- emptyPD vty
- -- return (ve, Case (elems `App` sel) lc lty
- -- [(DEFAULT, [], Let (NonRec flags_var flags_expr)
- -- $ mkLets (concat binds) le),
- -- (LitAlt (mkMachInt 0), [], empty)])
- let (vect_bndrs, lift_bndrs) = unzip vbndrs
- return (vect_dc, vect_bndrs, lift_bndrs, vbody)
-
- proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt"
-
- mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)
-
- pack_var len tags t v
- = do
- r <- lookupVar v
- case r of
- Local (vv, lv) ->
- do
- lv' <- cloneVar lv
- expr <- packByTagPD (idType vv) (Var lv) len tags t
- updLEnv (\env -> env { local_vars = extendVarEnv
- (local_vars env) v (vv, lv') })
- return [(NonRec lv' expr)]
-
- _ -> return []