- mk_shape uarr = intPrimTy : mk_sel uarr
-
- mk_sel uarr | is_product = []
- | otherwise = [uarr_int, uarr_int]
- where
- uarr_int = mkTyConApp uarr [intTy]
-
- mk_tycon get_tc tys
- | n > 1 = builtin (Just . get_tc n)
- | otherwise = return Nothing
- where n = length tys
-
- mk_single_datacon tc | [dc] <- tyConDataCons tc = dc
-
- mk_tc_app_maybe Nothing [] = unitTy
- mk_tc_app_maybe Nothing [ty] = ty
- mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys
-
- arr_repr_elem_tys [] = [unitTy]
- arr_repr_elem_tys tys = tys
-
-buildPReprType :: TyCon -> VM Type
-buildPReprType = liftM repr_type . mkTyConRepr
-
-buildToPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToPRepr (ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_data_con = prod_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (newLocalVar FSLIT("x")) prod_arg_tys
-
- return . Lam arg
- . wrapFamInstBody prepr_tc var_tys
- $ Case (Var arg) (mkWildId arg_ty) repr_type
- [(DataAlt data_con, vars,
- mkConApp prod_data_con (map Type prod_arg_tys ++ map Var vars))]
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- arg_ty = mkTyConApp vect_tc var_tys
- [data_con] = tyConDataCons vect_tc
-
-buildToPRepr (SumRepr {
- repr_tys = repr_tys
- , repr_prod_data_cons = prod_data_cons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (mapM (newLocalVar FSLIT("x"))) repr_tys
-
- return . Lam arg
- . wrapFamInstBody prepr_tc var_tys
- . Case (Var arg) (mkWildId arg_ty) repr_type
- . zipWith4 mk_alt data_cons vars sum_data_cons
- . zipWith3 mk_prod prod_data_cons repr_tys $ map (map Var) vars
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- arg_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
-
- sum_data_cons = tyConDataCons sum_tycon
-
- mk_alt dc vars sum_dc expr = (DataAlt dc, vars,
- mkConApp sum_dc (map Type prod_tys ++ [expr]))
-
- mk_prod _ _ [] = Var unitDataConId
- mk_prod _ _ [expr] = expr
- mk_prod (Just dc) tys exprs = mkConApp dc (map Type tys ++ exprs)
-
-buildFromPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildFromPRepr (ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_data_con = prod_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg_ty <- mkPReprType res_ty
- arg <- newLocalVar FSLIT("x") arg_ty
- vars <- mapM (newLocalVar FSLIT("x")) prod_arg_tys
-
- return . Lam arg
- $ Case (unwrapFamInstScrut prepr_tc var_tys (Var arg))
- (mkWildId repr_type)
- res_ty
- [(DataAlt prod_data_con, vars,
- mkConApp data_con (map Type var_tys ++ map Var vars))]
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- ty_args = map Type var_tys
- res_ty = mkTyConApp vect_tc var_tys
- [data_con] = tyConDataCons vect_tc
-
-buildFromPRepr (SumRepr {
- repr_tys = repr_tys
- , repr_prod_data_cons = prod_data_cons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = repr_type
- })
- vect_tc prepr_tc _
- = do
- arg_ty <- mkPReprType res_ty
- arg <- newLocalVar FSLIT("x") arg_ty
-
- liftM (Lam arg
- . Case (unwrapFamInstScrut prepr_tc var_tys (Var arg))
- (mkWildId repr_type)
- res_ty
- . zipWith mk_alt sum_data_cons)
- (sequence
- $ zipWith4 un_prod data_cons prod_data_cons prod_tys repr_tys)
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- ty_args = map Type var_tys
- res_ty = mkTyConApp vect_tc var_tys
- data_cons = tyConDataCons vect_tc
-
- sum_data_cons = tyConDataCons sum_tycon
-
- un_prod dc _ _ []
- = do
- var <- newLocalVar FSLIT("u") unitTy
- return (var, mkConApp dc ty_args)
- un_prod dc _ _ [ty]
- = do
- var <- newLocalVar FSLIT("x") ty
- return (var, mkConApp dc (ty_args ++ [Var var]))
-
- un_prod dc (Just prod_dc) prod_ty tys
- = do
- vars <- mapM (newLocalVar FSLIT("x")) tys
- pv <- newLocalVar FSLIT("p") prod_ty
-
- let res = mkConApp dc (ty_args ++ map Var vars)
- expr = Case (Var pv) (mkWildId prod_ty) res_ty
- [(DataAlt prod_dc, vars, res)]
-
- return (pv, expr)
-
- mk_alt sum_dc (var, expr) = (DataAlt sum_dc, [var], expr)
-
-
-buildToArrPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildToArrPRepr repr@(ProdRepr {
- repr_prod_arg_tys = prod_arg_tys
- , repr_prod_arr_tycon = prod_arr_tycon
- , repr_prod_arr_data_con = prod_arr_data_con
- , repr_type = repr_type
- })
- vect_tc prepr_tc arr_tc
- = do
- arg_ty <- mkPArrayType el_ty
- shape_tys <- arrShapeTys repr
- arr_tys <- arrReprTys repr
- res_ty <- mkPArrayType repr_type
- rep_el_ty <- mkPReprType el_ty
-
- arg <- newLocalVar FSLIT("xs") arg_ty
- shape_vars <- mapM (newLocalVar FSLIT("sh")) shape_tys
- rep_vars <- mapM (newLocalVar FSLIT("ys")) arr_tys
-
- let vars = shape_vars ++ rep_vars
-
- parray_co <- mkBuiltinCo parrayTyCon
-
- let res = wrapFamInstBody prod_arr_tycon prod_arg_tys
- . mkConApp prod_arr_data_con
- $ map Type prod_arg_tys ++ map Var vars
-
- Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion parray_co
- . mkSymCoercion
- $ mkTyConApp repr_co var_tys
-
- return . Lam arg
- . mkCoerce co
- $ Case (unwrapFamInstScrut arr_tc var_tys (Var arg))
- (mkWildId (mkTyConApp arr_tc var_tys))
- res_ty
- [(DataAlt arr_dc, vars, res)]
- where
- var_tys = mkTyVarTys $ tyConTyVars vect_tc
- el_ty = mkTyConApp vect_tc var_tys