X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=0789688c43ed8c7b976c9c77f13080a63da84550;hp=78e386dc1c55253c9770802e413e2b47450cc5ff;hb=9396c0736a7e7d73c2a13f1a18104e0c43b924b0;hpb=eb3d8bd851e58b182d62e711942de7dd76d3ec62

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 78e386d..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,
@@ -29,6 +29,7 @@ import DataCon            ( DataCon, dataConWrapId, dataConTag )
 import Var
 import Id                 ( mkWildId )
 import MkId               ( unwrapFamInstScrut )
+import Name               ( Name )
 import PrelNames
 import TysWiredIn
 import BasicTypes         ( Boxity(..) )
@@ -36,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 []
@@ -63,27 +64,36 @@ isAnnTypeArg _              = False
 mkDataConTag :: DataCon -> CoreExpr
 mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
 
-isClosureTyCon :: TyCon -> Bool
-isClosureTyCon tc = tyConName tc == closureTyConName
+splitUnTy :: String -> Name -> Type -> Type
+splitUnTy s name ty
+  | Just (tc, [ty']) <- splitTyConApp_maybe ty
+  , tyConName tc == name
+  = ty'
 
-splitClosureTy :: Type -> (Type, Type)
-splitClosureTy ty
-  | Just (tc, [arg_ty, res_ty]) <- splitTyConApp_maybe ty
-  , isClosureTyCon tc
-  = (arg_ty, res_ty)
+  | otherwise = pprPanic s (ppr ty)
 
-  | otherwise = pprPanic "splitClosureTy" (ppr ty)
+splitBinTy :: String -> Name -> Type -> (Type, Type)
+splitBinTy s name ty
+  | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty
+  , tyConName tc == name
+  = (ty1, ty2)
 
-isPArrayTyCon :: TyCon -> Bool
-isPArrayTyCon tc = tyConName tc == parrayTyConName
+  | otherwise = pprPanic s (ppr ty)
 
-splitPArrayTy :: Type -> Type
-splitPArrayTy ty
-  | Just (tc, [arg_ty]) <- splitTyConApp_maybe ty
-  , isPArrayTyCon tc
-  = arg_ty
+splitCrossTy :: Type -> (Type, Type)
+splitCrossTy = splitBinTy "splitCrossTy" ndpCrossTyConName
+
+splitPlusTy :: Type -> (Type, Type)
+splitPlusTy = splitBinTy "splitSumTy" ndpPlusTyConName
+
+splitEmbedTy :: Type -> Type
+splitEmbedTy = splitUnTy "splitEmbedTy" embedTyConName
 
-  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+splitClosureTy :: Type -> (Type, Type)
+splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
+
+splitPArrayTy :: Type -> Type
+splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 mkBuiltinTyConApp get_tc tys
@@ -110,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
@@ -132,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
@@ -171,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]