Generate conversion from PRepr to original type

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 7001907..c77343b 100644 (file)
--- 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
     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
 
 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
 
       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)
 
 
     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
 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),
           
 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
 
 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 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,8 +3,8 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,

-  mkPReprType, mkPReprAlts,
-  mkPADictType, mkPArrayType,
+  mkPRepr, mkToPRepr, mkFromPRepr,
+  mkPADictType, mkPArrayType, mkPReprType,

   parrayReprTyCon, parrayReprDataCon, mkVScrut,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,

@@ -37,7 +37,7 @@ import BasicTypes         ( Boxity(..) )
 import Outputable
 import FastString
 
 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 []
 
 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]
 
   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
   = do
       embed <- builtin embedTyCon
       cross <- builtin crossTyCon

@@ -142,8 +142,8 @@ mkPReprType tys
              . map (mk_tup . map mk_embed)
              $ 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
   = do
       embed_tc <- builtin embedTyCon
       embed_dc <- builtin embedDataCon

@@ -181,12 +181,64 @@ mkPReprAlts ess
                      pa <- paDictOfType ty
                      return (expr, ty, pa)
 
                      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
 
 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]
 
 mkPADictType :: Type -> VM Type
 mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]