X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=bbcd91cafcfe77b8fea185b1ee54ca02985d8630;hb=dcc66f7459ce8b815c1c82521ac6b6214a91ba7b;hp=2757cbc590df92c5833a7d797f3bd851ca3e1dcd;hpb=e2390e76b2f1f2beecd9a0d308c4890a56ae8bca;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 2757cbc..bbcd91c 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,8 +3,7 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
-  mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
-  mkPlusAlts, mkCrosses, mkEmbed,
+  mkPReprType, mkPReprAlts,
   mkPADictType, mkPArrayType,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
   paDictArgType, paDictOfType, paDFunType,
@@ -30,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(..) )
@@ -64,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
 
-  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+splitEmbedTy :: Type -> Type
+splitEmbedTy = splitUnTy "splitEmbedTy" embedTyConName
+
+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
@@ -111,64 +120,66 @@ mkBuiltinTyConApps1 get_tc dft tys
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
-mkBuiltinDataConApp :: (Builtins -> DataCon) -> [CoreExpr] -> VM CoreExpr
-mkBuiltinDataConApp get_dc args
+mkPReprType :: [[Type]] -> VM Type
+mkPReprType [] = return unitTy
+mkPReprType tys
   = do
-      dc <- builtin get_dc
-      return $ mkConApp dc args
+      embed <- builtin embedTyCon
+      cross <- builtin crossTyCon
+      plus  <- builtin plusTyCon
 
-mkPlusType :: Type -> Type -> VM Type
-mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
+      let mk_embed ty      = mkTyConApp embed [ty]
+          mk_cross ty1 ty2 = mkTyConApp cross [ty1, ty2]
+          mk_plus  ty1 ty2 = mkTyConApp plus  [ty1, ty2]
 
-mkPlusTypes :: Type -> [Type] -> VM Type
-mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+          mk_tup   []      = unitTy
+          mk_tup   tys     = foldr1 mk_cross tys
 
-mkPlusAlts :: [CoreExpr] -> VM [CoreExpr]
-mkPlusAlts [] = return []
-mkPlusAlts exprs
-  = do
-      plus_tc  <- builtin plusTyCon
-      left_dc  <- builtin leftDataCon
-      right_dc <- builtin rightDataCon
+          mk_sum   []      = unitTy
+          mk_sum   tys     = foldr1 mk_plus  tys
 
-      let go [expr] = ([expr], exprType expr)
-          go (expr : exprs)
-            | (alts, right_ty) <- go exprs
-            = (mkConApp left_dc [Type left_ty, Type right_ty, expr]
-               : [mkConApp right_dc [Type left_ty, Type right_ty, alt]
-                    | alt <- alts],
-               mkTyConApp plus_tc [left_ty, right_ty])
-            where
-              left_ty = exprType expr
+      return . mk_sum
+             . map (mk_tup . map mk_embed)
+             $ tys
 
-      return . fst $ go exprs
-
-mkCrossType :: Type -> Type -> VM Type
-mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
-
-mkCrossTypes :: Type -> [Type] -> VM Type
-mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
-
-mkCrosses :: [CoreExpr] -> VM CoreExpr
-mkCrosses [] = return (Var unitDataConId)
-mkCrosses exprs
+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 (left, left_ty) (right, right_ty)
-            = (mkConApp   cross_dc [Type left_ty, Type right_ty, left, right],
-               mkTyConApp cross_tc [left_ty, right_ty])
-
-      return . fst
-             $ foldr1 mk [(expr, exprType expr) | expr <- exprs]
-
-mkEmbedType :: Type -> VM Type
-mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
-
-mkEmbed :: CoreExpr -> VM CoreExpr
-mkEmbed expr = mkBuiltinDataConApp embedDataCon
-                                   [Type $ exprType expr, expr]
+      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]