Generate conversion to PRepr during vectorisation

[ghc-hetmet.git] / compiler / vectorise / VectUtils.hs

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index eee2734..78e386d 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,6 +3,7 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
+  mkPReprType, mkPReprAlts,
   mkPADictType, mkPArrayType,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
   paDictArgType, paDictOfType, paDFunType,
@@ -98,8 +99,9 @@ mkBuiltinTyConApps get_tc tys ty
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
-mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> [Type] -> VM Type
-mkBuiltinTyConApps1 get_tc tys
+mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
+mkBuiltinTyConApps1 get_tc dft [] = return dft
+mkBuiltinTyConApps1 get_tc dft tys
   = do
       tc <- builtin get_tc
       case tys of
@@ -108,6 +110,67 @@ mkBuiltinTyConApps1 get_tc tys
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
+mkPReprType :: [[Type]] -> VM Type
+mkPReprType [] = return unitTy
+mkPReprType tys
+  = do
+      embed <- builtin embedTyCon
+      cross <- builtin crossTyCon
+      plus  <- builtin plusTyCon
+
+      let mk_embed ty      = mkTyConApp embed [ty]
+          mk_cross ty1 ty2 = mkTyConApp cross [ty1, ty2]
+          mk_plus  ty1 ty2 = mkTyConApp plus  [ty1, ty2]
+
+          mk_tup   []      = unitTy
+          mk_tup   tys     = foldr1 mk_cross tys
+
+          mk_sum   []      = unitTy
+          mk_sum   tys     = foldr1 mk_plus  tys
+
+      return . mk_sum
+             . map (mk_tup . map mk_embed)
+             $ tys
+
+mkPReprAlts :: [[CoreExpr]] -> VM ([CoreExpr], Type)
+mkPReprAlts ess
+  = do
+      embed_tc <- builtin embedTyCon
+      embed_dc <- builtin embedDataCon
+      cross_tc <- builtin crossTyCon
+      cross_dc <- builtin crossDataCon
+      plus_tc  <- builtin plusTyCon
+      left_dc  <- builtin leftDataCon
+      right_dc <- builtin rightDataCon
+
+      let mk_embed (expr, ty, pa)
+            = (mkConApp   embed_dc [Type ty, pa, expr],
+               mkTyConApp embed_tc [ty])
+
+          mk_cross (expr1, ty1) (expr2, ty2)
+            = (mkConApp   cross_dc [Type ty1, Type ty2, expr1, expr2],
+               mkTyConApp cross_tc [ty1, ty2])
+
+          mk_tup [] = (Var unitDataConId, unitTy)
+          mk_tup es = foldr1 mk_cross es
+
+          mk_sum []           = ([Var unitDataConId], unitTy)
+          mk_sum [(expr, ty)] = ([expr], ty)
+          mk_sum ((expr, lty) : es)
+            = let (alts, rty) = mk_sum es
+              in
+              (mkConApp left_dc [Type lty, Type rty, expr]
+                 : [mkConApp right_dc [Type lty, Type rty, alt] | alt <- alts],
+               mkTyConApp plus_tc [lty, rty])
+      
+      liftM (mk_sum . map (mk_tup . map mk_embed))
+            (mapM (mapM init) ess)
+  where
+    init expr = let ty = exprType expr
+                in do
+                     pa <- paDictOfType ty
+                     return (expr, ty, pa)
+
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]