From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Wed, 22 Aug 2007 02:49:23 +0000 (+0000)
Subject: More refactoring
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=742db8bde59c1175a50e5045332f05ec22d12e80

More refactoring
---

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index e8afb46..e528aae 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -208,23 +208,9 @@ buildPReprRhsTy :: TyCon -> VM Type
 buildPReprRhsTy = buildPReprTy . map dataConRepArgTys . tyConDataCons
 
 buildPReprTy :: [[Type]] -> VM Type
-buildPReprTy [] = panic "mkPRepr"
-buildPReprTy tys
-  = do
-      embed <- builtin embedTyCon
-      plus  <- builtin plusTyCon
-      cross <- builtin crossTyCon
-
-      return . foldr1 (mk_bin plus)
-             . map (mkprod cross)
-             . map (map (mk_un embed))
-             $ tys
-  where
-    mkprod cross []  = unitTy
-    mkprod cross tys = foldr1 (mk_bin cross) tys
-
-    mk_un  tc ty      = mkTyConApp tc [ty]
-    mk_bin tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+buildPReprTy tys = mkPlusTypes unitTy
+               =<< mapM (mkCrossTypes unitTy)
+               =<< mapM (mapM mkEmbedType) tys
 
 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index eee2734..8e95b80 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,6 +3,7 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
+  mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
   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,21 @@ mkBuiltinTyConApps1 get_tc tys
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
+mkPlusType :: Type -> Type -> VM Type
+mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
+
+mkPlusTypes :: Type -> [Type] -> VM Type
+mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+
+mkCrossType :: Type -> Type -> VM Type
+mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
+
+mkCrossTypes :: Type -> [Type] -> VM Type
+mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
+
+mkEmbedType :: Type -> VM Type
+mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
+
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]