X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=405d6ab2b70300b1e0087a2ac3f38955860eb753;hb=054019538c6ac004d2dc5abd639cf953c8c485ef;hp=b238199730465053a599c49e43757d04ff9a301a;hpb=bfddbe303f56f1e96b0e4820986699768738beb4;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index b238199..405d6ab 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -263,10 +263,6 @@ mkSum reprs
   where
     arity = length reprs
 
-reprProducts :: Repr -> [Repr]
-reprProducts (SumRepr { sum_components = rs }) = rs
-reprProducts repr                              = [repr]
-
 reprType :: Repr -> Type
 reprType (ProdRepr { prod_tycon = tycon, prod_components = tys })
   = mkTyConApp tycon tys
@@ -276,20 +272,11 @@ reprType (SumRepr { sum_tycon = tycon, sum_components = reprs })
 arrReprType :: Repr -> VM Type
 arrReprType = mkPArrayType . reprType
 
-reprTys :: Repr -> [[Type]]
-reprTys (SumRepr { sum_components = prods }) = map prodTys prods
-reprTys prod                                 = [prodTys prod]
-
-prodTys (ProdRepr { prod_components = tys }) = tys
-
-reprVars :: Repr -> VM [[Var]]
-reprVars = mapM (mapM (newLocalVar FSLIT("r"))) . reprTys
-
 arrShapeTys :: Repr -> VM [Type]
 arrShapeTys (SumRepr  {})
   = do
-      uarr <- builtin uarrTyCon
-      return [intPrimTy, mkTyConApp uarr [intTy]]
+      int_arr <- builtin parrayIntPrimTyCon
+      return [intPrimTy, mkTyConApp int_arr [], mkTyConApp int_arr []]
 arrShapeTys repr = return [intPrimTy]
 
 arrShapeVars :: Repr -> VM [Var]
@@ -297,6 +284,11 @@ arrShapeVars repr = mapM (newLocalVar FSLIT("sh")) =<< arrShapeTys repr
 
 replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr]
 replicateShape (ProdRepr {}) len _ = return [len]
+replicateShape (SumRepr {})  len tag
+  = do
+      rep <- builtin replicatePAIntPrimVar
+      up  <- builtin upToPAIntPrimVar
+      return [len, Var rep `mkApps` [len, tag], Var up `App` len]
 
 arrReprElemTys :: Repr -> [[Type]]
 arrReprElemTys (SumRepr { sum_components = prods })
@@ -626,40 +618,10 @@ mkPADFun :: TyCon -> VM Var
 mkPADFun vect_tc
   = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
 
-data Shape = Shape {
-               shapeReprTys    :: [Type]
-             , shapeStrictness :: [StrictnessMark]
-             , shapeLength     :: [CoreExpr] -> VM CoreExpr
-             , shapeReplicate  :: CoreExpr -> CoreExpr -> VM [CoreExpr]
-             }
-
-tyConShape :: TyCon -> VM Shape
-tyConShape vect_tc
-  | isProductTyCon vect_tc
-  = return $ Shape {
-                shapeReprTys    = [intPrimTy]
-              , shapeStrictness = [NotMarkedStrict]
-              , shapeLength     = \[len] -> return len
-              , shapeReplicate  = \len _ -> return [len]
-              }
-
-  | otherwise
-  = do
-      repr_ty <- mkPArrayType intTy   -- FIXME: we want to unbox this
-      return $ Shape {
-                 shapeReprTys    = [repr_ty]
-               , shapeStrictness = [MarkedStrict]
-               , shapeLength     = \[sel] -> lengthPA sel
-               , shapeReplicate  = \len n -> do
-                                               e <- replicatePA len n
-                                               return [e]
-               }
-
 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
                    -> VM [(Var, CoreExpr)]
 buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun
   = do
-      shape <- tyConShape vect_tc
       repr  <- mkRepr vect_tc
       vectDataConWorkers repr orig_tc vect_tc arr_tc
       dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
@@ -700,7 +662,6 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
                    (lift_data_con tys (concat pre)
                                       (concat post)
                                       (mkDataConTag con))
-                   
 
     vect_data_con con = return $ mkConApp con ty_args
     lift_data_con tys pre_tys post_tys tag
@@ -708,10 +669,10 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
           len  <- builtin liftingContext
           args <- mapM (newLocalVar FSLIT("xs"))
                   =<< mapM mkPArrayType tys
-      
+
           shape <- replicateShape repr (Var len) tag
           repr  <- mk_arr_repr (Var len) (map Var args)
-      
+
           pre   <- mapM emptyPA pre_tys
           post  <- mapM emptyPA post_tys
 
@@ -741,48 +702,6 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
       where
         orig_worker = dataConWorkId data_con
 
-vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon
-                  -> DataCon -> DataCon -> [[Type]] -> [[Type]]
-                  -> VM ()
-vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post)
-  = do
-      clo <- closedV
-           . inBind orig_worker
-           . polyAbstract tvs $ \abstract ->
-             liftM (abstract . vectorised)
-           $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift)
-
-      worker <- cloneId mkVectOcc orig_worker (exprType clo)
-      hoistBinding worker clo
-      defGlobalVar orig_worker worker
-      return ()
-  where
-    tvs     = tyConTyVars vect_tc
-    arg_tys = mkTyVarTys tvs
-    res_ty  = mkTyConApp vect_tc arg_tys
-
-    orig_worker = dataConWorkId orig_dc
-
-    mk_vect = return . mkConApp vect_dc $ map Type arg_tys
-    mk_lift = do
-                len     <- newLocalVar FSLIT("n") intPrimTy
-                arr_tys <- mapM mkPArrayType dc_tys
-                args    <- mapM (newLocalVar FSLIT("xs")) arr_tys
-                shapes  <- shapeReplicate shape
-                                          (Var len)
-                                          (mkDataConTag vect_dc)
-
-                empty_pre  <- mapM emptyPA (concat pre)
-                empty_post <- mapM emptyPA (concat post)
-
-                return . mkLams (len : args)
-                       . wrapFamInstBody arr_tc arg_tys
-                       . mkConApp arr_dc
-                       $ map Type arg_tys ++ shapes
-                                          ++ empty_pre
-                                          ++ map Var args
-                                          ++ empty_post
-
 buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
 buildPADict repr vect_tc prepr_tc arr_tc dfun
   = polyAbstract tvs $ \abstract ->