X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=37d65db91e29be98a950ed0499a13b8494ed66ac;hp=ffb43bb0c925aacfc95818a331aff57bcc34f032;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=3f6a74eafcabc1f8d496937a33ec92e7b416f989 diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index ffb43bb..37d65db 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -1,6 +1,5 @@ - module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv, - mkRepr, arrShapeTys, arrShapeVars, arrSelector, + -- arrSumArity, pdataCompTys, pdataCompVars, buildPADict, fromVect ) where @@ -12,6 +11,8 @@ import VectCore import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import CoreSyn import CoreUtils +import CoreUnfold +import MkCore ( mkWildCase ) import BuildTyCl import DataCon import TyCon @@ -20,14 +21,13 @@ import TypeRep import Coercion import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName +import Id import MkId -import BasicTypes ( StrictnessMark(..), boolToRecFlag ) -import Var ( Var, TyVar ) -import Id ( mkWildId ) +import BasicTypes ( HsBang(..), boolToRecFlag, + alwaysInlinePragma, dfunInlinePragma ) +import Var ( Var, TyVar, varType ) import Name ( Name, getOccName ) import NameEnv -import TysWiredIn -import TysPrim ( intPrimTy ) import Unique import UniqFM @@ -38,6 +38,7 @@ import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) import Outputable import FastString +import MonadUtils ( zipWith3M, foldrM, concatMapM ) import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM ) import Data.List ( inits, tails, zipWith4, zipWith5 ) @@ -59,7 +60,7 @@ vectAndLiftType ty mdicts <- mapM paDictArgType tyvars let dicts = [dict | Just dict <- mdicts] vmono_ty <- vectType mono_ty - lmono_ty <- mkPArrayType vmono_ty + lmono_ty <- mkPDataType vmono_ty return (abstractType tyvars dicts vmono_ty, abstractType tyvars dicts lmono_ty) where @@ -119,26 +120,30 @@ vectTypeEnv env new_tcs <- vectTyConDecls conv_tcs let orig_tcs = keep_tcs ++ conv_tcs - vect_tcs = keep_tcs ++ new_tcs - - repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs - parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs - dfuns <- mapM mkPADFun vect_tcs - defTyConPAs (zip vect_tcs dfuns) - binds <- sequence (zipWith5 buildTyConBindings orig_tcs - vect_tcs - repr_tcs - parr_tcs - dfuns) - - let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs + vect_tcs = keep_tcs ++ new_tcs + + (_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) -> + do + defTyConPAs (zipLazy vect_tcs dfuns') + reprs <- mapM tyConRepr vect_tcs + repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs + pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs + dfuns <- sequence $ zipWith5 buildTyConBindings orig_tcs + vect_tcs + repr_tcs + pdata_tcs + reprs + binds <- takeHoisted + return (dfuns, binds, repr_tcs ++ pdata_tcs) + + let all_new_tcs = new_tcs ++ inst_tcs let new_env = extendTypeEnvList env (map ATyCon all_new_tcs ++ [ADataCon dc | tc <- all_new_tcs , dc <- tyConDataCons tc]) - return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds) + return (new_env, map mkLocalFamInst inst_tcs, binds) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -197,13 +202,14 @@ vectDataCon dc liftDs $ buildDataCon name' False -- not infix - (map (const NotMarkedStrict) arg_tys) + (map (const HsNoBang) arg_tys) [] -- no labelled fields univ_tvs [] -- no existential tvs for now [] -- no eq spec for now [] -- no context - arg_tys + arg_tys + (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) tycon' where name = dataConName dc @@ -215,11 +221,13 @@ mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) mk_fam_inst fam_tc arg_tc = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) -buildPReprTyCon :: TyCon -> TyCon -> VM TyCon -buildPReprTyCon orig_tc vect_tc + +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPReprTyCon orig_tc vect_tc repr = do name <- cloneName mkPReprTyConOcc (tyConName orig_tc) - rhs_ty <- buildPReprType vect_tc + -- rhs_ty <- buildPReprType vect_tc + rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon liftDs $ buildSynTyCon name tyvars @@ -229,572 +237,433 @@ buildPReprTyCon orig_tc vect_tc where tyvars = tyConTyVars vect_tc - -data Repr = ProdRepr { - prod_components :: [Type] - , prod_tycon :: TyCon - , prod_data_con :: DataCon - , prod_arr_tycon :: TyCon - , prod_arr_data_con :: DataCon - } - - | SumRepr { - sum_components :: [Repr] - , sum_tycon :: TyCon - , sum_arr_tycon :: TyCon - , sum_arr_data_con :: DataCon - } - - | IdRepr Type - - | VoidRepr { - void_tycon :: TyCon - , void_bottom :: CoreExpr - } - - | EnumRepr { - enum_tycon :: TyCon - , enum_data_con :: DataCon - , enum_arr_tycon :: TyCon - , enum_arr_data_con :: DataCon - } - -voidRepr :: VM Repr -voidRepr - = do - tycon <- builtin voidTyCon - var <- builtin voidVar - return $ VoidRepr { - void_tycon = tycon - , void_bottom = Var var - } - -{- -enumRepr :: VM Repr -enumRepr - = do - tycon <- builtin enumerationTyCon - let [data_con] = tyConDataCons tycon - (arr_tycon, _) <- parrayReprTyCon (mkTyConApp tycon []) - let [arr_data_con] = tyConDataCons arr_tycon - - return $ EnumRepr { - enum_tycon = tycon - , enum_data_con = data_con - , enum_arr_tycon = arr_tycon - , enum_arr_data_con = arr_data_con - } --} - -unboxedProductRepr :: [Type] -> VM Repr -unboxedProductRepr [] = voidRepr -unboxedProductRepr [ty] = return $ IdRepr ty -unboxedProductRepr tys = boxedProductRepr tys - -boxedProductRepr :: [Type] -> VM Repr -boxedProductRepr tys - = do - tycon <- builtin (prodTyCon arity) - let [data_con] = tyConDataCons tycon - - tys' <- mapM boxType tys - (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys' - let [arr_data_con] = tyConDataCons arr_tycon - - return $ ProdRepr { - prod_components = tys - , prod_tycon = tycon - , prod_data_con = data_con - , prod_arr_tycon = arr_tycon - , prod_arr_data_con = arr_data_con - } - where - arity = length tys - -sumRepr :: [Repr] -> VM Repr -sumRepr [] = voidRepr -sumRepr [repr] = boxRepr repr -sumRepr reprs - = do - tycon <- builtin (sumTyCon arity) - (arr_tycon, _) <- parrayReprTyCon - . mkTyConApp tycon - $ map reprType reprs - - let [arr_data_con] = tyConDataCons arr_tycon - - return $ SumRepr { - sum_components = reprs - , sum_tycon = tycon - , sum_arr_tycon = arr_tycon - , sum_arr_data_con = arr_data_con - } - where - arity = length reprs - -splitSumRepr :: Repr -> [Repr] -splitSumRepr (SumRepr { sum_components = reprs }) = reprs -splitSumRepr repr = [repr] - -boxRepr :: Repr -> VM Repr -boxRepr (VoidRepr {}) = boxedProductRepr [] -boxRepr (IdRepr ty) = boxedProductRepr [ty] -boxRepr repr = return repr - -reprType :: Repr -> Type -reprType (ProdRepr { prod_tycon = tycon, prod_components = tys }) - = mkTyConApp tycon tys -reprType (SumRepr { sum_tycon = tycon, sum_components = reprs }) - = mkTyConApp tycon (map reprType reprs) -reprType (IdRepr ty) = ty -reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon [] -reprType (EnumRepr { enum_tycon = tycon }) = mkTyConApp tycon [] - -arrReprType :: Repr -> VM Type -arrReprType = mkPArrayType . reprType - -arrShapeTys :: Repr -> VM [Type] -arrShapeTys (SumRepr {}) = sumShapeTys -arrShapeTys (ProdRepr {}) = return [intPrimTy] -arrShapeTys (IdRepr _) = return [] -arrShapeTys (VoidRepr {}) = return [intPrimTy] -arrShapeTys (EnumRepr {}) = sumShapeTys - -sumShapeTys :: VM [Type] -sumShapeTys = do - int_arr <- builtin intPrimArrayTy - return [intPrimTy, int_arr, int_arr] - - -arrShapeVars :: Repr -> VM [Var] -arrShapeVars repr = mapM (newLocalVar (fsLit "sh")) =<< arrShapeTys repr - -replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr] -replicateShape (ProdRepr {}) len _ = return [len] -replicateShape (SumRepr {}) len tag = replicateSumShape len tag -replicateShape (IdRepr _) _ _ = return [] -replicateShape (VoidRepr {}) len _ = return [len] -replicateShape (EnumRepr {}) len tag = replicateSumShape len tag - -replicateSumShape :: CoreExpr -> CoreExpr -> VM [CoreExpr] -replicateSumShape len tag - = do - rep <- builtin replicatePAIntPrimVar - up <- builtin upToPAIntPrimVar - return [len, Var rep `mkApps` [len, tag], Var up `App` len] - -arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr) -arrSelector (SumRepr {}) [len, sel, is] = return (len, sel, is) -arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is) -arrSelector _ _ = panic "arrSelector" - -emptyArrRepr :: Repr -> VM [CoreExpr] -emptyArrRepr (SumRepr { sum_components = prods }) - = liftM concat $ mapM emptyArrRepr prods -emptyArrRepr (ProdRepr { prod_components = [] }) - = return [Var unitDataConId] -emptyArrRepr (ProdRepr { prod_components = tys }) - = mapM emptyPA tys -emptyArrRepr (IdRepr ty) - = liftM singleton $ emptyPA ty -emptyArrRepr (VoidRepr { void_tycon = tycon }) - = liftM singleton $ emptyPA (mkTyConApp tycon []) -emptyArrRepr (EnumRepr {}) - = return [] - -arrReprTys :: Repr -> VM [Type] -arrReprTys (SumRepr { sum_components = reprs }) - = liftM concat $ mapM arrReprTys reprs -arrReprTys (ProdRepr { prod_components = [] }) - = return [unitTy] -arrReprTys (ProdRepr { prod_components = tys }) - = mapM mkPArrayType tys -arrReprTys (IdRepr ty) - = liftM singleton $ mkPArrayType ty -arrReprTys (VoidRepr { void_tycon = tycon }) - = liftM singleton $ mkPArrayType (mkTyConApp tycon []) -arrReprTys (EnumRepr {}) - = return [] - -arrReprTys' :: Repr -> VM [[Type]] -arrReprTys' (SumRepr { sum_components = reprs }) - = mapM arrReprTys reprs -arrReprTys' repr = liftM singleton $ arrReprTys repr - -arrReprVars :: Repr -> VM [[Var]] -arrReprVars repr - = mapM (mapM (newLocalVar (fsLit "rs"))) =<< arrReprTys' repr - -mkRepr :: TyCon -> VM Repr -mkRepr vect_tc - | [tys] <- rep_tys = boxedProductRepr tys - -- removed: | all null rep_tys = enumRepr - | otherwise = sumRepr =<< mapM unboxedProductRepr rep_tys +data CompRepr = Keep Type + CoreExpr -- PR dictionary for the type + | Wrap Type + +data ProdRepr = EmptyProd + | UnaryProd CompRepr + | Prod { repr_tup_tc :: TyCon -- representation tuple tycon + , repr_ptup_tc :: TyCon -- PData representation tycon + , repr_comp_tys :: [Type] -- representation types of + , repr_comps :: [CompRepr] -- components + } +data ConRepr = ConRepr DataCon ProdRepr + +data SumRepr = EmptySum + | UnarySum ConRepr + | Sum { repr_sum_tc :: TyCon -- representation sum tycon + , repr_psum_tc :: TyCon -- PData representation tycon + , repr_sel_ty :: Type -- type of selector + , repr_con_tys :: [Type] -- representation types of + , repr_cons :: [ConRepr] -- components + } + +tyConRepr :: TyCon -> VM SumRepr +tyConRepr tc = sum_repr (tyConDataCons tc) where - rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - -buildPReprType :: TyCon -> VM Type -buildPReprType = liftM reprType . mkRepr - -buildToPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToPRepr repr vect_tc prepr_tc _ + sum_repr [] = return EmptySum + sum_repr [con] = liftM UnarySum (con_repr con) + sum_repr cons = do + rs <- mapM con_repr cons + sum_tc <- builtin (sumTyCon arity) + tys <- mapM conReprType rs + (psum_tc, _) <- pdataReprTyCon (mkTyConApp sum_tc tys) + sel_ty <- builtin (selTy arity) + return $ Sum { repr_sum_tc = sum_tc + , repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = rs + } + where + arity = length cons + + con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con)) + + prod_repr [] = return EmptyProd + prod_repr [ty] = liftM UnaryProd (comp_repr ty) + prod_repr tys = do + rs <- mapM comp_repr tys + tup_tc <- builtin (prodTyCon arity) + tys' <- mapM compReprType rs + (ptup_tc, _) <- pdataReprTyCon (mkTyConApp tup_tc tys') + return $ Prod { repr_tup_tc = tup_tc + , repr_ptup_tc = ptup_tc + , repr_comp_tys = tys' + , repr_comps = rs + } + where + arity = length tys + + comp_repr ty = liftM (Keep ty) (prDictOfType ty) + `orElseV` return (Wrap ty) + +sumReprType :: SumRepr -> VM Type +sumReprType EmptySum = voidType +sumReprType (UnarySum r) = conReprType r +sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) + = return $ mkTyConApp sum_tc tys + +conReprType :: ConRepr -> VM Type +conReprType (ConRepr _ r) = prodReprType r + +prodReprType :: ProdRepr -> VM Type +prodReprType EmptyProd = voidType +prodReprType (UnaryProd r) = compReprType r +prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) + = return $ mkTyConApp tup_tc tys + +compReprType :: CompRepr -> VM Type +compReprType (Keep ty _) = return ty +compReprType (Wrap ty) = do + wrap_tc <- builtin wrapTyCon + return $ mkTyConApp wrap_tc [ty] + +compOrigType :: CompRepr -> Type +compOrigType (Keep ty _) = ty +compOrigType (Wrap ty) = ty + +buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildToPRepr vect_tc repr_tc _ repr = do + let arg_ty = mkTyConApp vect_tc ty_args + res_ty <- mkPReprType arg_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- to_repr repr (Var arg) - - return . Lam arg - . wrapFamInstBody prepr_tc var_tys - $ result + result <- to_sum (Var arg) arg_ty res_ty repr + return $ Lam arg result where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - arg_ty = mkTyConApp vect_tc var_tys - res_ty = reprType repr + ty_args = mkTyVarTys (tyConTyVars vect_tc) - cons = tyConDataCons vect_tc - [con] = cons + wrap_repr_inst = wrapFamInstBody repr_tc ty_args - to_repr (SumRepr { sum_components = prods - , sum_tycon = tycon }) - expr + to_sum _ _ _ EmptySum = do - (vars, bodies) <- mapAndUnzipM to_unboxed prods - return . Case expr (mkWildId (exprType expr)) res_ty - $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies - where - mk_alt con vars sum_con body - = (DataAlt con, vars, mkConApp sum_con (ty_args ++ [body])) - - ty_args = map (Type . reprType) prods + void <- builtin voidVar + return $ wrap_repr_inst $ Var void - to_repr (EnumRepr { enum_data_con = data_con }) expr - = return . Case expr (mkWildId (exprType expr)) res_ty - $ map mk_alt cons - where - mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con]) + to_sum arg arg_ty res_ty (UnarySum r) + = do + (pat, vars, body) <- con_alt r + return $ mkWildCase arg arg_ty res_ty + [(pat, vars, wrap_repr_inst body)] - to_repr prod expr + to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) + = do + alts <- mapM con_alt cons + let alts' = [(pat, vars, wrap_repr_inst + $ mkConApp sum_con (map Type tys ++ [body])) + | ((pat, vars, body), sum_con) + <- zip alts (tyConDataCons sum_tc)] + return $ mkWildCase arg arg_ty res_ty alts' + + con_alt (ConRepr con r) = do - (vars, body) <- to_unboxed prod - return $ Case expr (mkWildId (exprType expr)) res_ty - [(DataAlt con, vars, body)] + (vars, body) <- to_prod r + return (DataAlt con, vars, body) - to_unboxed (ProdRepr { prod_components = tys - , prod_data_con = data_con }) + to_prod EmptyProd = do - vars <- mapM (newLocalVar (fsLit "r")) tys - return (vars, mkConApp data_con (map Type tys ++ map Var vars)) + void <- builtin voidVar + return ([], Var void) - to_unboxed (IdRepr ty) + to_prod (UnaryProd comp) = do - var <- newLocalVar (fsLit "y") ty - return ([var], Var var) + var <- newLocalVar (fsLit "x") (compOrigType comp) + body <- to_comp (Var var) comp + return ([var], body) - to_unboxed (VoidRepr { void_bottom = bottom }) - = return ([], bottom) + to_prod(Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + vars <- newLocalVars (fsLit "x") (map compOrigType comps) + exprs <- zipWithM to_comp (map Var vars) comps + return (vars, mkConApp tup_con (map Type tys ++ exprs)) + where + [tup_con] = tyConDataCons tup_tc - to_unboxed _ = panic "buildToPRepr/to_unboxed" + to_comp expr (Keep _ _) = return expr + to_comp expr (Wrap ty) = do + wrap_tc <- builtin wrapTyCon + return $ wrapNewTypeBody wrap_tc [ty] expr -buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromPRepr repr vect_tc prepr_tc _ +buildFromPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildFromPRepr vect_tc repr_tc _ repr = do arg_ty <- mkPReprType res_ty - arg <- newLocalVar (fsLit "x") arg_ty + arg <- newLocalVar (fsLit "x") arg_ty - liftM (Lam arg) - . from_repr repr - $ unwrapFamInstScrut prepr_tc var_tys (Var arg) + result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg)) + repr + return $ Lam arg result where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - res_ty = mkTyConApp vect_tc var_tys - - cons = map (`mkConApp` map Type var_tys) (tyConDataCons vect_tc) - [con] = cons + ty_args = mkTyVarTys (tyConTyVars vect_tc) + res_ty = mkTyConApp vect_tc ty_args - from_repr repr@(SumRepr { sum_components = prods - , sum_tycon = tycon }) - expr + from_sum _ EmptySum = do - vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods) - bodies <- sequence . zipWith3 from_unboxed prods cons - $ map Var vars - return . Case expr (mkWildId (reprType repr)) res_ty - $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies - where - sum_alt data_con var body = (DataAlt data_con, [var], body) + dummy <- builtin fromVoidVar + return $ Var dummy `App` Type res_ty - from_repr repr@(EnumRepr { enum_data_con = data_con }) expr + from_sum expr (UnarySum r) = from_con expr r + from_sum expr (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) = do - var <- newLocalVar (fsLit "n") intPrimTy + vars <- newLocalVars (fsLit "x") tys + es <- zipWithM from_con (map Var vars) cons + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt con, [var], e) + | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] - let res = Case (Var var) (mkWildId intPrimTy) res_ty - $ (DEFAULT, [], error_expr) - : zipWith mk_alt (tyConDataCons vect_tc) cons + from_con expr (ConRepr con r) + = from_prod expr (mkConApp con $ map Type ty_args) r - return $ Case expr (mkWildId (reprType repr)) res_ty - [(DataAlt data_con, [var], res)] + from_prod _ con EmptyProd = return con + from_prod expr con (UnaryProd r) + = do + e <- from_comp expr r + return $ con `App` e + + from_prod expr con (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps + }) + = do + vars <- newLocalVars (fsLit "y") tys + es <- zipWithM from_comp (map Var vars) comps + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt tup_con, vars, con `mkApps` es)] where - mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con) - - error_expr = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty - . showSDoc - $ sep [text "Invalid NDP representation of", ppr vect_tc] - - from_repr repr expr = from_unboxed repr con expr + [tup_con] = tyConDataCons tup_tc - from_unboxed prod@(ProdRepr { prod_components = tys - , prod_data_con = data_con }) - con - expr + from_comp expr (Keep _ _) = return expr + from_comp expr (Wrap ty) = do - vars <- mapM (newLocalVar (fsLit "y")) tys - return $ Case expr (mkWildId (reprType prod)) res_ty - [(DataAlt data_con, vars, con `mkVarApps` vars)] + wrap <- builtin wrapTyCon + return $ unwrapNewTypeBody wrap [ty] expr - from_unboxed (IdRepr _) con expr - = return $ con `App` expr - from_unboxed (VoidRepr {}) con _ - = return con - - from_unboxed _ _ _ = panic "buildFromPRepr/from_unboxed" - -buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToArrPRepr repr vect_tc prepr_tc arr_tc +buildToArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildToArrPRepr vect_tc prepr_tc pdata_tc r = do - arg_ty <- mkPArrayType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - res_ty <- mkPArrayType (reprType repr) - - shape_vars <- arrShapeVars repr - repr_vars <- arrReprVars repr - - parray_co <- mkBuiltinCo parrayTyCon + arg_ty <- mkPDataType el_ty + res_ty <- mkPDataType =<< mkPReprType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion parray_co + co = mkAppCoercion pdata_co . mkSymCoercion - $ mkTyConApp repr_co var_tys + $ mkTyConApp repr_co ty_args - scrut = unwrapFamInstScrut arr_tc var_tys (Var arg) + scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - result <- to_repr shape_vars repr_vars repr + (vars, result) <- to_sum r return . Lam arg - . mkCoerce co - $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty - [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)] + $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty + [(DataAlt pdata_dc, vars, mkCoerce co result)] where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc var_tys + ty_args = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc ty_args - [arr_dc] = tyConDataCons arr_tc + [pdata_dc] = tyConDataCons pdata_tc - to_repr shape_vars@(_ : _) - repr_vars - (SumRepr { sum_components = prods - , sum_arr_tycon = tycon - , sum_arr_data_con = data_con }) - = do - exprs <- zipWithM to_prod repr_vars prods - return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ map Var shape_vars ++ exprs - where - tys = map reprType prods - - to_repr [len_var] - [repr_vars] - (ProdRepr { prod_components = tys - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) - = return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ map Var (len_var : repr_vars) - - to_repr shape_vars - _ - (EnumRepr { enum_arr_tycon = tycon - , enum_arr_data_con = data_con }) - = return . wrapFamInstBody tycon [] - . mkConApp data_con - $ map Var shape_vars - - to_repr _ _ _ = panic "buildToArrPRepr/to_repr" - - to_prod repr_vars@(r : _) - (ProdRepr { prod_components = tys@(ty : _) - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) + to_sum EmptySum = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + to_sum (UnarySum r) = to_con r + to_sum (Sum { repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = cons + }) = do - len <- lengthPA ty (Var r) - return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ len : map Var repr_vars + (vars, exprs) <- mapAndUnzipM to_con cons + sel <- newLocalVar (fsLit "sel") sel_ty + return (sel : concat vars, mk_result (Var sel) exprs) + where + [psum_con] = tyConDataCons psum_tc + mk_result sel exprs = wrapFamInstBody psum_tc tys + $ mkConApp psum_con + $ map Type tys ++ (sel : exprs) - to_prod [var] (IdRepr _) = return (Var var) - to_prod [var] (VoidRepr {}) = return (Var var) - to_prod _ _ = panic "buildToArrPRepr/to_prod" + to_con (ConRepr _ r) = to_prod r + to_prod EmptyProd = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + to_prod (UnaryProd r) + = do + pty <- mkPDataType (compOrigType r) + var <- newLocalVar (fsLit "x") pty + expr <- to_comp (Var var) r + return ([var], expr) + + to_prod (Prod { repr_ptup_tc = ptup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + ptys <- mapM (mkPDataType . compOrigType) comps + vars <- newLocalVars (fsLit "x") ptys + es <- zipWithM to_comp (map Var vars) comps + return (vars, mk_result es) + where + [ptup_con] = tyConDataCons ptup_tc + mk_result exprs = wrapFamInstBody ptup_tc tys + $ mkConApp ptup_con + $ map Type tys ++ exprs -buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromArrPRepr repr vect_tc prepr_tc arr_tc - = do - arg_ty <- mkPArrayType =<< mkPReprType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty + to_comp expr (Keep _ _) = return expr - res_ty <- mkPArrayType el_ty + -- FIXME: this is bound to be wrong! + to_comp expr (Wrap ty) + = do + wrap_tc <- builtin wrapTyCon + (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty]) + return $ wrapNewTypeBody pwrap_tc [ty] expr - shape_vars <- arrShapeVars repr - repr_vars <- arrReprVars repr - parray_co <- mkBuiltinCo parrayTyCon +buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildFromArrPRepr vect_tc prepr_tc pdata_tc r + = do + arg_ty <- mkPDataType =<< mkPReprType el_ty + res_ty <- mkPDataType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion parray_co + co = mkAppCoercion pdata_co $ mkTyConApp repr_co var_tys scrut = mkCoerce co (Var arg) - result = wrapFamInstBody arr_tc var_tys - . mkConApp arr_dc - $ map Type var_tys ++ map Var (shape_vars ++ concat repr_vars) + mk_result args = wrapFamInstBody pdata_tc var_tys + $ mkConApp pdata_con + $ map Type var_tys ++ args - liftM (Lam arg) - (from_repr repr scrut shape_vars repr_vars res_ty result) + (expr, _) <- fixV $ \ ~(_, args) -> + from_sum res_ty (mk_result args) scrut r + + return $ Lam arg expr + + -- (args, mk) <- from_sum res_ty scrut r + + -- let result = wrapFamInstBody pdata_tc var_tys + -- . mkConApp pdata_dc + -- $ map Type var_tys ++ args + + -- return $ Lam arg (mk result) where var_tys = mkTyVarTys $ tyConTyVars vect_tc el_ty = mkTyConApp vect_tc var_tys - [arr_dc] = tyConDataCons arr_tc + [pdata_con] = tyConDataCons pdata_tc - from_repr (SumRepr { sum_components = prods - , sum_arr_tycon = tycon - , sum_arr_data_con = data_con }) - expr - shape_vars - repr_vars - res_ty - body + from_sum _ res _ EmptySum = return (res, []) + from_sum res_ty res expr (UnarySum r) = from_con res_ty res expr r + from_sum res_ty res expr (Sum { repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = cons }) = do - vars <- mapM (newLocalVar (fsLit "xs")) =<< mapM arrReprType prods - result <- go prods repr_vars vars body - - let scrut = unwrapFamInstScrut tycon ty_args expr - return . Case scrut (mkWildId scrut_ty) res_ty - $ [(DataAlt data_con, shape_vars ++ vars, result)] + sel <- newLocalVar (fsLit "sel") sel_ty + ptys <- mapM mkPDataType tys + vars <- newLocalVars (fsLit "xs") ptys + (res', args) <- fold from_con res_ty res (map Var vars) cons + let scrut = unwrapFamInstScrut psum_tc tys expr + body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt psum_con, sel : vars, res')] + return (body, Var sel : args) where - ty_args = map reprType prods - scrut_ty = mkTyConApp tycon ty_args - - go [] [] [] body = return body - go (prod : prods) (repr_vars : rss) (var : vars) body - = do - shape_vars <- mapM (newLocalVar (fsLit "s")) =<< arrShapeTys prod - - from_prod prod (Var var) shape_vars repr_vars res_ty - =<< go prods rss vars body - go _ _ _ _ = panic "buildFromArrPRepr/go" - - from_repr repr expr shape_vars [repr_vars] res_ty body - = from_prod repr expr shape_vars repr_vars res_ty body - - from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr" - - from_prod (ProdRepr { prod_components = tys - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) - expr - shape_vars - repr_vars - res_ty - body + [psum_con] = tyConDataCons psum_tc + + + from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r + + from_prod _ res _ EmptyProd = return (res, []) + from_prod res_ty res expr (UnaryProd r) + = from_comp res_ty res expr r + from_prod res_ty res expr (Prod { repr_ptup_tc = ptup_tc + , repr_comp_tys = tys + , repr_comps = comps }) = do - let scrut = unwrapFamInstScrut tycon tys expr - scrut_ty = mkTyConApp tycon tys - - return $ Case scrut (mkWildId scrut_ty) res_ty - [(DataAlt data_con, shape_vars ++ repr_vars, body)] - - from_prod (EnumRepr { enum_arr_tycon = tycon - , enum_arr_data_con = data_con }) - expr - shape_vars - _ - res_ty - body - = let scrut = unwrapFamInstScrut tycon [] expr - scrut_ty = mkTyConApp tycon [] - in - return $ Case scrut (mkWildId scrut_ty) res_ty - [(DataAlt data_con, shape_vars, body)] - - from_prod (IdRepr _) - expr - _shape_vars - [repr_var] - _res_ty - body - = return $ Let (NonRec repr_var expr) body - - from_prod (VoidRepr {}) - expr - _shape_vars - [repr_var] - _res_ty - body - = return $ Let (NonRec repr_var expr) body - - from_prod _ _ _ _ _ _ = panic "buildFromArrPRepr/from_prod" - -buildPRDictRepr :: Repr -> VM CoreExpr -buildPRDictRepr (VoidRepr { void_tycon = tycon }) - = prDFunOfTyCon tycon -buildPRDictRepr (IdRepr ty) = mkPR ty -buildPRDictRepr (ProdRepr { - prod_components = tys - , prod_tycon = tycon - }) - = do - prs <- mapM mkPR tys - dfun <- prDFunOfTyCon tycon - return $ dfun `mkTyApps` tys `mkApps` prs + ptys <- mapM mkPDataType tys + vars <- newLocalVars (fsLit "ys") ptys + (res', args) <- fold from_comp res_ty res (map Var vars) comps + let scrut = unwrapFamInstScrut ptup_tc tys expr + body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt ptup_con, vars, res')] + return (body, args) + where + [ptup_con] = tyConDataCons ptup_tc -buildPRDictRepr (SumRepr { - sum_components = prods - , sum_tycon = tycon }) - = do - prs <- mapM buildPRDictRepr prods - dfun <- prDFunOfTyCon tycon - return $ dfun `mkTyApps` map reprType prods `mkApps` prs + from_comp _ res expr (Keep _ _) = return (res, [expr]) + from_comp _ res expr (Wrap ty) + = do + wrap_tc <- builtin wrapTyCon + (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty]) + return (res, [unwrapNewTypeBody pwrap_tc [ty] + $ unwrapFamInstScrut pwrap_tc [ty] expr]) -buildPRDictRepr (EnumRepr { enum_tycon = tycon }) - = prDFunOfTyCon tycon + fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) + where + f' (expr, r) (res, args) = do + (res', args') <- f res_ty res expr r + return (res', args' ++ args) -buildPRDict :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildPRDict repr vect_tc prepr_tc _ +buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildPRDict vect_tc prepr_tc _ r = do - dict <- buildPRDictRepr repr - + dict <- sum_dict r pr_co <- mkBuiltinCo prTyCon let co = mkAppCoercion pr_co . mkSymCoercion - $ mkTyConApp arg_co var_tys - - return $ mkCoerce co dict + $ mkTyConApp arg_co ty_args + return (mkCoerce co dict) where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - + ty_args = mkTyVarTys (tyConTyVars vect_tc) Just arg_co = tyConFamilyCoercion_maybe prepr_tc -buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon -buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> + sum_dict EmptySum = prDFunOfTyCon =<< builtin voidTyCon + sum_dict (UnarySum r) = con_dict r + sum_dict (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons + }) + = do + dicts <- mapM con_dict cons + dfun <- prDFunOfTyCon sum_tc + return $ dfun `mkTyApps` tys `mkApps` dicts + + con_dict (ConRepr _ r) = prod_dict r + + prod_dict EmptyProd = prDFunOfTyCon =<< builtin voidTyCon + prod_dict (UnaryProd r) = comp_dict r + prod_dict (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + dicts <- mapM comp_dict comps + dfun <- prDFunOfTyCon tup_tc + return $ dfun `mkTyApps` tys `mkApps` dicts + + comp_dict (Keep _ pr) = return pr + comp_dict (Wrap ty) = wrapPR ty + + +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> do - name' <- cloneName mkPArrayTyConOcc orig_name - rhs <- buildPArrayTyConRhs orig_name vect_tc repr_tc - parray <- builtin parrayTyCon + name' <- cloneName mkPDataTyConOcc orig_name + rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr + pdata <- builtin pdataTyCon liftDs $ buildAlgTyCon name' tyvars @@ -803,149 +672,180 @@ buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> rec_flag -- FIXME: is this ok? False -- FIXME: no generics False -- not GADT syntax - (Just $ mk_fam_inst parray vect_tc) + (Just $ mk_fam_inst pdata vect_tc) where orig_name = tyConName orig_tc tyvars = tyConTyVars vect_tc rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) -buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs -buildPArrayTyConRhs orig_name vect_tc repr_tc +buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs +buildPDataTyConRhs orig_name vect_tc repr_tc repr = do - data_con <- buildPArrayDataCon orig_name vect_tc repr_tc + data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr return $ DataTyCon { data_cons = [data_con], is_enum = False } -buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon -buildPArrayDataCon orig_name vect_tc repr_tc +buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon +buildPDataDataCon orig_name vect_tc repr_tc repr = do - dc_name <- cloneName mkPArrayDataConOcc orig_name - repr <- mkRepr vect_tc - - shape_tys <- arrShapeTys repr - repr_tys <- arrReprTys repr - - let tys = shape_tys ++ repr_tys + dc_name <- cloneName mkPDataDataConOcc orig_name + comp_tys <- sum_tys repr liftDs $ buildDataCon dc_name False -- not infix - (map (const NotMarkedStrict) tys) + (map (const HsNoBang) comp_tys) [] -- no field labels - (tyConTyVars vect_tc) + tvs [] -- no existentials [] -- no eq spec [] -- no context - tys + comp_tys + (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) repr_tc + where + tvs = tyConTyVars vect_tc + + sum_tys EmptySum = return [] + sum_tys (UnarySum r) = con_tys r + sum_tys (Sum { repr_sel_ty = sel_ty + , repr_cons = cons }) + = liftM (sel_ty :) (concatMapM con_tys cons) + + con_tys (ConRepr _ r) = prod_tys r + + prod_tys EmptyProd = return [] + prod_tys (UnaryProd r) = liftM singleton (comp_ty r) + prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps -mkPADFun :: TyCon -> VM Var -mkPADFun vect_tc - = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc + comp_ty r = mkPDataType (compOrigType r) -buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var - -> VM [(Var, CoreExpr)] -buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun + +buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr + -> VM Var +buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr = do - repr <- mkRepr vect_tc - vectDataConWorkers repr orig_tc vect_tc arr_tc - dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun - binds <- takeHoisted - return $ (dfun, dict) : binds - -vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon - -> VM () -vectDataConWorkers repr orig_tc vect_tc arr_tc + vectDataConWorkers orig_tc vect_tc pdata_tc + buildPADict vect_tc prepr_tc pdata_tc repr + +vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () +vectDataConWorkers orig_tc vect_tc arr_tc = do bs <- sequence . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys $ zipWith4 mk_data_con (tyConDataCons vect_tc) rep_tys - (inits reprs) - (tail $ tails reprs) + (inits rep_tys) + (tail $ tails rep_tys) mapM_ (uncurry hoistBinding) bs where tyvars = tyConTyVars vect_tc var_tys = mkTyVarTys tyvars ty_args = map Type var_tys - res_ty = mkTyConApp vect_tc var_tys + cons = tyConDataCons vect_tc + arity = length cons + [arr_dc] = tyConDataCons arr_tc + rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - reprs = splitSumRepr repr - [arr_dc] = tyConDataCons arr_tc mk_data_con con tys pre post = liftM2 (,) (vect_data_con con) (lift_data_con tys pre post (mkDataConTag con)) + sel_replicate len tag + | arity > 1 = do + rep <- builtin (selReplicate arity) + return [rep `mkApps` [len, tag]] + + | otherwise = return [] + vect_data_con con = return $ mkConApp con ty_args - lift_data_con tys pre_reprs post_reprs tag + lift_data_con tys pre_tys post_tys tag = do len <- builtin liftingContext args <- mapM (newLocalVar (fsLit "xs")) - =<< mapM mkPArrayType tys + =<< mapM mkPDataType tys - shape <- replicateShape repr (Var len) tag - repr <- mk_arr_repr (Var len) (map Var args) + sel <- sel_replicate (Var len) tag - pre <- liftM concat $ mapM emptyArrRepr pre_reprs - post <- liftM concat $ mapM emptyArrRepr post_reprs + pre <- mapM emptyPD (concat pre_tys) + post <- mapM emptyPD (concat post_tys) return . mkLams (len : args) . wrapFamInstBody arr_tc var_tys . mkConApp arr_dc - $ ty_args ++ shape ++ pre ++ repr ++ post - - mk_arr_repr len [] - = do - units <- replicatePA len (Var unitDataConId) - return [units] - - mk_arr_repr _ arrs = return arrs + $ ty_args ++ sel ++ pre ++ map Var args ++ post def_worker data_con arg_tys mk_body = do + arity <- polyArity tyvars body <- closedV . inBind orig_worker - . polyAbstract tyvars $ \abstract -> - liftM (abstract . vectorised) + . polyAbstract tyvars $ \args -> + liftM (mkLams (tyvars ++ args) . vectorised) $ buildClosures tyvars [] arg_tys res_ty mk_body - vect_worker <- cloneId mkVectOcc orig_worker (exprType body) + raw_worker <- cloneId mkVectOcc orig_worker (exprType body) + let vect_worker = raw_worker `setIdUnfolding` + mkInlineRule body (Just arity) defGlobalVar orig_worker vect_worker return (vect_worker, body) where orig_worker = dataConWorkId data_con -buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr -buildPADict repr vect_tc prepr_tc arr_tc _ - = polyAbstract tvs $ \abstract -> +buildPADict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM Var +buildPADict vect_tc prepr_tc arr_tc repr + = polyAbstract tvs $ \args -> do - meth_binds <- mapM (mk_method repr) paMethods - let meth_exprs = map (Var . fst) meth_binds + method_ids <- mapM (method args) paMethods + + pa_tc <- builtin paTyCon + pa_con <- builtin paDataCon + let dict = mkLams (tvs ++ args) + $ mkConApp pa_con + $ Type inst_ty : map (method_call args) method_ids - pa_dc <- builtin paDataCon - let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs) - body = Let (Rec meth_binds) dict - return . mkInlineMe $ abstract body + dfun_ty = mkForAllTys tvs + $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty]) + + raw_dfun <- newExportedVar dfun_name dfun_ty + let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids + `setInlinePragma` dfunInlinePragma + + hoistBinding dfun dict + return dfun where - tvs = tyConTyVars arr_tc + tvs = tyConTyVars vect_tc arg_tys = mkTyVarTys tvs + inst_ty = mkTyConApp vect_tc arg_tys + + dfun_name = mkPADFunOcc (getOccName vect_tc) - mk_method repr (name, build) + method args (name, build) = localV $ do - body <- build repr vect_tc prepr_tc arr_tc - var <- newLocalVar name (exprType body) - return (var, mkInlineMe body) + expr <- build vect_tc prepr_tc arr_tc repr + let body = mkLams (tvs ++ args) expr + raw_var <- newExportedVar (method_name name) (exprType body) + let var = raw_var + `setIdUnfolding` mkInlineRule body (Just (length args)) + `setInlinePragma` alwaysInlinePragma + hoistBinding var body + return var + + method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) + + method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) + -paMethods :: [(FastString, Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr)] -paMethods = [(fsLit "toPRepr", buildToPRepr), - (fsLit "fromPRepr", buildFromPRepr), - (fsLit "toArrPRepr", buildToArrPRepr), - (fsLit "fromArrPRepr", buildFromArrPRepr), - (fsLit "dictPRepr", buildPRDict)] +paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] +paMethods = [("dictPRepr", buildPRDict), + ("toPRepr", buildToPRepr), + ("fromPRepr", buildFromPRepr), + ("toArrPRepr", buildToArrPRepr), + ("fromArrPRepr", buildFromArrPRepr)] -- | Split the given tycons into two sets depending on whether they have to be -- converted (first list) or not (second list). The first argument contains @@ -1023,7 +923,7 @@ fromVect (FunTy arg_ty res_ty) expr varg <- toVect arg_ty (Var arg) varg_ty <- vectType arg_ty vres_ty <- vectType res_ty - apply <- builtin applyClosureVar + apply <- builtin applyVar body <- fromVect res_ty $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg] return $ Lam arg body