X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=2340e8f227d21898a0a553878b0f00681c7b32b6;hb=2e4068a25fb7b0905c264b51843e41fd328f0ed3;hp=a7c463b462426ee1676fca430dd19b92040279d9;hpb=ea8027bad72931bce05f36cae99497e7f255eef7;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index a7c463b..2340e8f 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -209,7 +209,7 @@ buildPReprTyCon orig_tc vect_tc
     tyvars = tyConTyVars vect_tc
 
 buildPReprType :: TyCon -> VM Type
-buildPReprType = mkPRepr . map dataConRepArgTys . tyConDataCons
+buildPReprType = liftM repr_type . mkTyConRepr
 
 buildToPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildToPRepr _ vect_tc prepr_tc _
@@ -230,6 +230,43 @@ buildToPRepr _ vect_tc prepr_tc _
 
     mk_alt data_con bndrs body = (DataAlt data_con, bndrs, body)
 
+buildToArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr _ vect_tc prepr_tc arr_tc
+  = do
+      arg_ty  <- mkPArrayType el_ty
+      rep_tys <- mapM (mapM mkPArrayType) rep_el_tys
+
+      arg     <- newLocalVar FSLIT("xs") arg_ty
+      bndrss  <- mapM (mapM (newLocalVar FSLIT("ys"))) rep_tys
+      len     <- newLocalVar FSLIT("len") intPrimTy
+      sel     <- newLocalVar FSLIT("sel") =<< mkPArrayType intTy
+
+      let add_sel xs | has_selector = sel : xs
+                     | otherwise    = xs
+
+          all_bndrs = len : add_sel (concat bndrss)
+
+      res      <- parrayCoerce prepr_tc var_tys
+                =<< mkToArrPRepr (Var len) (Var sel) (map (map Var) bndrss)
+      res_ty   <- mkPArrayType =<< mkPReprType el_ty
+
+      return . Lam arg
+             $ Case (unwrapFamInstScrut arr_tc var_tys (Var arg))
+                    (mkWildId (mkTyConApp arr_tc var_tys))
+                    res_ty
+                    [(DataAlt arr_dc, all_bndrs, res)]
+  where
+    var_tys    = mkTyVarTys $ tyConTyVars vect_tc
+    el_ty      = mkTyConApp vect_tc var_tys
+    data_cons  = tyConDataCons vect_tc
+    rep_el_tys = map dataConRepArgTys data_cons
+
+    [arr_dc]   = tyConDataCons arr_tc
+
+    has_selector | [_] <- data_cons = False
+                 | otherwise        = True
+
+
 buildFromPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildFromPRepr _ vect_tc prepr_tc _
   = do
@@ -248,6 +285,10 @@ buildFromPRepr _ vect_tc prepr_tc _
                   bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc
                   return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs))
 
+buildFromArrPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromArrPRepr _ vect_tc prepr_tc arr_tc
+  = mkFromArrPRepr undefined undefined undefined undefined undefined undefined
+
 buildPRDict :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildPRDict _ vect_tc prepr_tc _
   = prCoerce prepr_tc var_tys
@@ -420,103 +461,11 @@ buildPADict shape vect_tc prepr_tc arr_tc dfun
           var  <- newLocalVar name (exprType body)
           return (var, mkInlineMe body)
           
-paMethods = [(FSLIT("lengthPA"),    buildLengthPA),
-             (FSLIT("replicatePA"), buildReplicatePA),
-             (FSLIT("toPRepr"),     buildToPRepr),
-             (FSLIT("fromPRepr"),   buildFromPRepr),
-             (FSLIT("dictPRepr"),   buildPRDict)]
-
-buildLengthPA :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildLengthPA shape vect_tc _ arr_tc
-  = do
-      parr_ty <- mkPArrayType (mkTyConApp vect_tc arg_tys)
-      arg    <- newLocalVar FSLIT("xs") parr_ty
-      shapes <- mapM (newLocalVar FSLIT("sh")) shape_tys
-      wilds  <- mapM newDummyVar repr_tys
-      let scrut    = unwrapFamInstScrut arr_tc arg_tys (Var arg)
-          scrut_ty = exprType scrut
-
-      body <- shapeLength shape (map Var shapes)
-
-      return . Lam arg
-             $ Case scrut (mkWildId scrut_ty) intPrimTy
-                    [(DataAlt repr_dc, shapes ++ wilds, body)]
-  where
-    arg_tys = mkTyVarTys $ tyConTyVars arr_tc
-    [repr_dc] = tyConDataCons arr_tc
-    
-    shape_tys = shapeReprTys shape
-    repr_tys  = drop (length shape_tys) (dataConRepArgTys repr_dc)
-
--- data T = C0 t1 ... tm
---          ...
---          Ck u1 ... un
---
--- data [:T:] = A ![:Int:] [:t1:] ... [:un:]
---
--- replicatePA :: Int# -> T -> [:T:]
--- replicatePA n# t
---   = let c = case t of
---               C0 _ ... _ -> 0
---               ...
---               Ck _ ... _ -> k
---
---         xs1 = case t of
---                 C0 x1 _ ... _ -> replicatePA @t1 n# x1
---                 _             -> emptyPA @t1
---
---         ...
---
---         ysn = case t of
---                 Ck _ ... _ yn -> replicatePA @un n# yn
---                 _             -> emptyPA @un
---     in
---     A (replicatePA @Int n# c) xs1 ... ysn
---
---
-
-buildReplicatePA :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildReplicatePA shape vect_tc _ arr_tc
-  = do
-      len_var <- newLocalVar FSLIT("n") intPrimTy
-      val_var <- newLocalVar FSLIT("x") val_ty
-
-      let len = Var len_var
-          val = Var val_var
-
-      shape_reprs <- shapeReplicate shape len (ctr_num val)
-      reprs <- liftM concat $ mapM (mk_comp_arrs len val) vect_dcs
-
-      return . mkLams [len_var, val_var]
-             . wrapFamInstBody arr_tc arg_tys
-             $ mkConApp arr_dc (map Type arg_tys ++ shape_reprs ++ reprs)
-  where
-    arg_tys = mkTyVarTys (tyConTyVars arr_tc)
-    val_ty  = mkTyConApp vect_tc arg_tys
-    wild    = mkWildId val_ty
-    vect_dcs = tyConDataCons vect_tc
-    [arr_dc] = tyConDataCons arr_tc
-
-    ctr_num val = Case val wild intTy (zipWith ctr_num_alt vect_dcs [0..])
-    ctr_num_alt dc i = (DataAlt dc, map mkWildId (dataConRepArgTys dc),
-                                    mkConApp intDataCon [mkIntLitInt i])
-
-
-    mk_comp_arrs len val dc = let tys = dataConRepArgTys dc
-                                  wilds = map mkWildId tys
-                              in
-                              sequence (zipWith3 (mk_comp_arr len val dc)
-                                       tys (inits wilds) (tails wilds))
-
-    mk_comp_arr len val dc ty pre (_:post)
-      = do
-          var   <- newLocalVar FSLIT("x") ty
-          rep   <- replicatePA len (Var var)
-          empty <- emptyPA ty
-          arr_ty <- mkPArrayType ty
-
-          return $ Case val wild arr_ty
-                     [(DEFAULT, [], empty), (DataAlt dc, pre ++ (var : post), rep)]
+paMethods = [(FSLIT("toPRepr"),      buildToPRepr),
+             (FSLIT("fromPRepr"),    buildFromPRepr),
+             (FSLIT("toArrPRepr"),   buildToArrPRepr),
+             (FSLIT("fromArrPRepr"), buildFromArrPRepr),
+             (FSLIT("dictPRepr"),    buildPRDict)]
 
 -- | Split the given tycons into two sets depending on whether they have to be
 -- converted (first list) or not (second list). The first argument contains