X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=e28b66ffa02e779cf19db9a7b4b9d62423616fe6;hp=4f8ab7ff870544fa3cc8b05d94f5f6d71a6c163b;hb=58eb6de8922742d301a6703b4a21504dd8d623a5;hpb=c4f31cc44f596c5fb04083da9bc0ee39e3e44646

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 4f8ab7f..e28b66f 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -26,7 +26,7 @@ import Var               ( Var )
 import Id                ( mkWildId )
 import Name              ( Name, getOccName )
 import NameEnv
-import TysWiredIn        ( intTy, intDataCon )
+import TysWiredIn        ( unitTy, intTy, intDataCon )
 import TysPrim           ( intPrimTy )
 
 import Unique
@@ -97,19 +97,20 @@ vectTypeEnv env
       let orig_tcs = keep_tcs ++ conv_tcs
           vect_tcs  = keep_tcs ++ new_tcs
 
+      repr_tcs <- zipWithM buildPReprTyCon   orig_tcs vect_tcs
       parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
       dfuns    <- mapM mkPADFun vect_tcs
       defTyConPAs (zip vect_tcs dfuns)
       binds    <- sequence (zipWith4 buildTyConBindings orig_tcs vect_tcs parr_tcs dfuns)
       
-      let all_new_tcs = new_tcs ++ parr_tcs
+      let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs
 
       let new_env = extendTypeEnvList env
                        (map ATyCon all_new_tcs
                         ++ [ADataCon dc | tc <- all_new_tcs
                                         , dc <- tyConDataCons tc])
 
-      return (new_env, map mkLocalFamInst parr_tcs, concat binds)
+      return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds)
   where
     tycons = typeEnvTyCons env
     groups = tyConGroups tycons
@@ -186,6 +187,45 @@ vectDataCon dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
 
+mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
+mk_fam_inst fam_tc arg_tc
+  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
+
+mkSumOfProdRepr :: [[Type]] -> VM Type
+mkSumOfProdRepr [] = panic "mkSumOfProdRepr"
+mkSumOfProdRepr 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]
+
+buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
+buildPReprTyCon orig_tc vect_tc
+  = do
+      name     <- cloneName mkPReprTyConOcc (tyConName orig_tc)
+      rhs_ty   <- buildPReprRhsTy vect_tc
+      prepr_tc <- builtin preprTyCon
+      liftDs $ buildSynTyCon name
+                             tyvars
+                             (SynonymTyCon rhs_ty)
+                             (Just $ mk_fam_inst prepr_tc vect_tc)
+  where
+    tyvars = tyConTyVars vect_tc
+
+buildPReprRhsTy :: TyCon -> VM Type
+buildPReprRhsTy = mkSumOfProdRepr . map dataConRepArgTys . tyConDataCons
+
 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
   do
@@ -200,7 +240,7 @@ buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
                            rec_flag    -- FIXME: is this ok?
                            False       -- FIXME: no generics
                            False       -- not GADT syntax
-                           (Just (parray, [mkTyConApp vect_tc (map mkTyVarTy tyvars)]))
+                           (Just $ mk_fam_inst parray vect_tc)
   where
     orig_name = tyConName orig_tc
     tyvars = tyConTyVars vect_tc