X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=08a8067561d40040c0141b6849eb38a1071ada59;hb=020f85464387244a063acad967e88132ba715982;hp=15b2a5bec0db39f685d0719b05f43f49d19d2206;hpb=6789720ce2765f7f9b395e86447ea7c0b14df64e;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 15b2a5b..08a8067 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -7,6 +7,7 @@ import VectMonad
 import VectUtils
 
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
+import CoreSyn
 import DataCon
 import TyCon
 import Type
@@ -17,9 +18,11 @@ import InstEnv           ( Instance )
 import OccName
 import MkId
 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
+import Id                ( mkWildId )
 import Name              ( Name )
 import NameEnv
-import TysWiredIn        ( intTy )
+import TysWiredIn        ( intTy, intDataCon )
+import TysPrim           ( intPrimTy )
 
 import Unique
 import UniqFM
@@ -28,7 +31,8 @@ import Digraph           ( SCC(..), stronglyConnComp )
 
 import Outputable
 
-import Control.Monad  ( liftM2, zipWithM, zipWithM_ )
+import Control.Monad  ( liftM, liftM2, zipWithM, zipWithM_ )
+import Data.List      ( inits, tails )
 
 -- ----------------------------------------------------------------------------
 -- Types
@@ -77,8 +81,8 @@ vectTypeEnv env
       zipWithM_ defTyCon   keep_tcs keep_tcs
       zipWithM_ defDataCon keep_dcs keep_dcs
       vect_tcs <- vectTyConDecls conv_tcs
-      parr_tcs1 <- mapM (\tc -> buildPArrayTyCon (tyConName tc) tc) keep_tcs
-      parr_tcs2 <- zipWithM (buildPArrayTyCon . tyConName) conv_tcs vect_tcs
+      parr_tcs1 <- zipWithM buildPArrayTyCon keep_tcs keep_tcs
+      parr_tcs2 <- zipWithM buildPArrayTyCon conv_tcs vect_tcs
       let new_tcs = vect_tcs ++ parr_tcs1 ++ parr_tcs2
 
       let new_env = extendTypeEnvList env
@@ -173,8 +177,8 @@ vectDataCon dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
 
-buildPArrayTyCon :: Name -> TyCon -> VM TyCon
-buildPArrayTyCon orig_name vect_tc = fixV $ \repr_tc ->
+buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
+buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
   do
     name'  <- cloneName mkPArrayTyConOcc orig_name
     parent <- buildPArrayParentInfo orig_name vect_tc repr_tc
@@ -191,6 +195,7 @@ buildPArrayTyCon orig_name vect_tc = fixV $ \repr_tc ->
                         False           -- FIXME: no generics
                         False           -- not GADT syntax
   where
+    orig_name = tyConName orig_tc
     name   = tyConName vect_tc
     kind   = tyConKind vect_tc
     tyvars = tyConTyVars vect_tc
@@ -248,6 +253,89 @@ buildPArrayDataCon orig_name vect_tc repr_tc
     types = [ty | dc <- tyConDataCons vect_tc
                 , ty <- dataConRepArgTys dc]
 
+buildLengthPA :: TyCon -> VM CoreExpr
+buildLengthPA repr_tc
+  = do
+      arg   <- newLocalVar FSLIT("xs") arg_ty
+      shape <- newLocalVar FSLIT("sel") shape_ty
+      body  <- lengthPA (Var shape)
+      return . Lam arg
+             $ Case (Var arg) (mkWildId arg_ty) intPrimTy
+                    [(DataAlt repr_dc, shape : map mkWildId repr_tys, body)]
+  where
+    arg_ty = mkTyConApp repr_tc . mkTyVarTys $ tyConTyVars repr_tc
+    [repr_dc] = tyConDataCons repr_tc
+    shape_ty : repr_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 :: TyCon -> TyCon -> VM CoreExpr
+buildReplicatePA 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 <- replicatePA len (ctr_num val)
+      reprs <- liftM concat $ mapM (mk_comp_arrs len val) vect_dcs
+      
+      return . mkLams [len_var, val_var]
+             $ mkConApp arr_dc (map (Type . TyVarTy) (tyConTyVars arr_tc) ++ (shape : reprs))
+  where
+    val_ty = mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars arr_tc
+    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
+                     [(DataAlt dc, pre ++ (var : post), rep), (DEFAULT, [], empty)]
+
 -- | 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
 -- information about the conversion status of external tycons: