From 9396c0736a7e7d73c2a13f1a18104e0c43b924b0 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Wed, 22 Aug 2007 06:18:25 +0000 Subject: [PATCH] Generate conversion from PRepr to original type --- compiler/vectorise/VectType.hs | 25 ++++++++++++-- compiler/vectorise/VectUtils.hs | 68 ++++++++++++++++++++++++++++++++++----- 2 files changed, 82 insertions(+), 11 deletions(-) diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 7001907..c77343b 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -209,14 +209,14 @@ buildPReprTyCon orig_tc vect_tc tyvars = tyConTyVars vect_tc buildPReprType :: TyCon -> VM Type -buildPReprType = mkPReprType . map dataConRepArgTys . tyConDataCons +buildPReprType = mkPRepr . map dataConRepArgTys . tyConDataCons buildToPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr buildToPRepr _ vect_tc prepr_tc _ = do arg <- newLocalVar FSLIT("x") arg_ty bndrss <- mapM (mapM (newLocalVar FSLIT("x"))) rep_tys - (alt_bodies, res_ty) <- mkPReprAlts $ map (map Var) bndrss + (alt_bodies, res_ty) <- mkToPRepr $ map (map Var) bndrss return . Lam arg . wrapFamInstBody prepr_tc var_tys @@ -230,6 +230,24 @@ buildToPRepr _ vect_tc prepr_tc _ mk_alt data_con bndrs body = (DataAlt data_con, bndrs, body) +buildFromPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr +buildFromPRepr _ vect_tc prepr_tc _ + = do + arg_ty <- mkPReprType res_ty + arg <- newLocalVar FSLIT("x") arg_ty + alts <- mapM mk_alt data_cons + body <- mkFromPRepr (unwrapFamInstScrut prepr_tc var_tys (Var arg)) + res_ty alts + return $ Lam arg body + where + var_tys = mkTyVarTys $ tyConTyVars vect_tc + res_ty = mkTyConApp vect_tc var_tys + data_cons = tyConDataCons vect_tc + + mk_alt dc = do + bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc + return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs)) + buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> do @@ -397,7 +415,8 @@ buildPADict shape vect_tc prepr_tc arr_tc dfun paMethods = [(FSLIT("lengthPA"), buildLengthPA), (FSLIT("replicatePA"), buildReplicatePA), - (FSLIT("toPRepr"), buildToPRepr)] + (FSLIT("toPRepr"), buildToPRepr), + (FSLIT("fromPRepr"), buildFromPRepr)] buildLengthPA :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr buildLengthPA shape vect_tc _ arr_tc diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index bbcd91c..0789688 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -3,8 +3,8 @@ module VectUtils ( collectAnnValBinders, mkDataConTag, splitClosureTy, - mkPReprType, mkPReprAlts, - mkPADictType, mkPArrayType, + mkPRepr, mkToPRepr, mkFromPRepr, + mkPADictType, mkPArrayType, mkPReprType, parrayReprTyCon, parrayReprDataCon, mkVScrut, paDictArgType, paDictOfType, paDFunType, paMethod, lengthPA, replicatePA, emptyPA, liftPA, @@ -37,7 +37,7 @@ import BasicTypes ( Boxity(..) ) import Outputable import FastString -import Control.Monad ( liftM, zipWithM_ ) +import Control.Monad ( liftM, liftM2, zipWithM_ ) collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) collectAnnTypeArgs expr = go expr [] @@ -120,9 +120,9 @@ mkBuiltinTyConApps1 get_tc dft tys where mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] -mkPReprType :: [[Type]] -> VM Type -mkPReprType [] = return unitTy -mkPReprType tys +mkPRepr :: [[Type]] -> VM Type +mkPRepr [] = return unitTy +mkPRepr tys = do embed <- builtin embedTyCon cross <- builtin crossTyCon @@ -142,8 +142,8 @@ mkPReprType tys . map (mk_tup . map mk_embed) $ tys -mkPReprAlts :: [[CoreExpr]] -> VM ([CoreExpr], Type) -mkPReprAlts ess +mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type) +mkToPRepr ess = do embed_tc <- builtin embedTyCon embed_dc <- builtin embedDataCon @@ -181,12 +181,64 @@ mkPReprAlts ess pa <- paDictOfType ty return (expr, ty, pa) +mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr +mkFromPRepr scrut res_ty alts + = do + embed_dc <- builtin embedDataCon + cross_dc <- builtin crossDataCon + left_dc <- builtin leftDataCon + right_dc <- builtin rightDataCon + pa_tc <- builtin paTyCon + + let un_embed expr ty var res + = do + pa <- newLocalVar FSLIT("pa") (mkTyConApp pa_tc [idType var]) + return $ Case expr (mkWildId ty) res_ty + [(DataAlt embed_dc, [pa, var], res)] + + un_cross expr ty var1 var2 res + = Case expr (mkWildId ty) res_ty + [(DataAlt cross_dc, [var1, var2], res)] + + un_tup expr ty [] res = return res + un_tup expr ty [var] res = un_embed expr ty var res + un_tup expr ty (var : vars) res + = do + lv <- newLocalVar FSLIT("x") lty + rv <- newLocalVar FSLIT("y") rty + liftM (un_cross expr ty lv rv) + (un_embed (Var lv) lty var + =<< un_tup (Var rv) rty vars res) + where + (lty, rty) = splitCrossTy ty + + un_plus expr ty var1 var2 res1 res2 + = Case expr (mkWildId ty) res_ty + [(DataAlt left_dc, [var1], res1), + (DataAlt right_dc, [var2], res2)] + + un_sum expr ty [(vars, res)] = un_tup expr ty vars res + un_sum expr ty ((vars, res) : alts) + = do + lv <- newLocalVar FSLIT("l") lty + rv <- newLocalVar FSLIT("r") rty + liftM2 (un_plus expr ty lv rv) + (un_tup (Var lv) lty vars res) + (un_sum (Var rv) rty alts) + where + (lty, rty) = splitPlusTy ty + + un_sum scrut (exprType scrut) alts + mkClosureType :: Type -> Type -> VM Type mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty] mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon +mkPReprType :: Type -> VM Type +mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty] + mkPADictType :: Type -> VM Type mkPADictType ty = mkBuiltinTyConApp paTyCon [ty] -- 1.7.10.4