Refactoring

[ghc-hetmet.git] / compiler / vectorise / VectType.hs

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index d3a1ee2..69a93f8 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -191,6 +191,35 @@ vectDataCon dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
 
+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]
+               }
+        
 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
   do
@@ -243,7 +272,7 @@ buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
 buildPArrayDataCon orig_name vect_tc repr_tc
   = do
       dc_name  <- cloneName mkPArrayDataConOcc orig_name
-      shape_ty <- mkPArrayType intTy   -- FIXME: we want to unbox this!
+      shape    <- tyConShape vect_tc
       repr_tys <- mapM mkPArrayType types
       wrk_name <- cloneName mkDataConWorkerOcc  dc_name
       wrp_name <- cloneName mkDataConWrapperOcc dc_name
@@ -251,13 +280,13 @@ buildPArrayDataCon orig_name vect_tc repr_tc
       let ids      = mkDataConIds wrp_name wrk_name data_con
           data_con = mkDataCon dc_name
                                False
-                               (MarkedStrict : map (const NotMarkedStrict) repr_tys)
+                               (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
                                []
                                (tyConTyVars vect_tc)
                                []
                                []
                                []
-                               (shape_ty : repr_tys)
+                               (shapeReprTys shape ++ repr_tys)
                                repr_tc
                                []
                                ids
@@ -291,43 +320,51 @@ buildPADict (PAInstance {
                painstInstance  = inst
              , painstVectTyCon = vect_tc
              , painstArrTyCon  = arr_tc })
-  = localV . abstractOverTyVars (tyConTyVars arr_tc) $ \abstract ->
+  = polyAbstract (tyConTyVars arr_tc) $ \abstract ->
     do
-      meth_binds <- mapM mk_method paMethods
+      shape <- tyConShape vect_tc
+      meth_binds <- mapM (mk_method shape) paMethods
       let meth_exprs = map (Var . fst) meth_binds
 
       pa_dc <- builtin paDictDataCon
       let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
           body = Let (Rec meth_binds) dict
-      return [(instanceDFunId inst, abstract body)]
+      return [(instanceDFunId inst, mkInlineMe $ abstract body)]
   where
     tvs = tyConTyVars arr_tc
     arg_tys = mkTyVarTys tvs
 
-    mk_method (name, build)
+    mk_method shape (name, build)
       = localV
       $ do
-          body <- build vect_tc arr_tc
+          body <- build shape vect_tc arr_tc
           var  <- newLocalVar name (exprType body)
           return (var, mkInlineMe body)
           
 paMethods = [(FSLIT("lengthPA"),    buildLengthPA),
              (FSLIT("replicatePA"), buildReplicatePA)]
 
-buildLengthPA :: TyCon -> TyCon -> VM CoreExpr
-buildLengthPA _ arr_tc
+buildLengthPA :: Shape -> TyCon -> TyCon -> VM CoreExpr
+buildLengthPA shape vect_tc arr_tc
   = do
-      arg   <- newLocalVar FSLIT("xs") arg_ty
-      shape <- newLocalVar FSLIT("sel") shape_ty
-      body  <- lengthPA (Var shape)
+      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 (Var arg) (mkWildId arg_ty) intPrimTy
-                    [(DataAlt repr_dc, shape : map mkWildId repr_tys, body)]
+             $ Case scrut (mkWildId scrut_ty) intPrimTy
+                    [(DataAlt repr_dc, shapes ++ wilds, body)]
   where
-    arg_ty = mkTyConApp arr_tc . mkTyVarTys $ tyConTyVars arr_tc
+    arg_tys = mkTyVarTys $ tyConTyVars arr_tc
     [repr_dc] = tyConDataCons arr_tc
-    shape_ty : repr_tys = dataConRepArgTys repr_dc
-
+    
+    shape_tys = shapeReprTys shape
+    repr_tys  = drop (length shape_tys) (dataConRepArgTys repr_dc)
 
 -- data T = C0 t1 ... tm
 --          ...
@@ -356,8 +393,8 @@ buildLengthPA _ arr_tc
 --
 --
 
-buildReplicatePA :: TyCon -> TyCon -> VM CoreExpr
-buildReplicatePA vect_tc arr_tc
+buildReplicatePA :: Shape -> TyCon -> TyCon -> VM CoreExpr
+buildReplicatePA shape vect_tc arr_tc
   = do
       len_var <- newLocalVar FSLIT("n") intPrimTy
       val_var <- newLocalVar FSLIT("x") val_ty
@@ -365,14 +402,16 @@ buildReplicatePA vect_tc arr_tc
       let len = Var len_var
           val = Var val_var
 
-      shape <- replicatePA len (ctr_num val)
+      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]
-             $ mkConApp arr_dc (map (Type . TyVarTy) (tyConTyVars arr_tc) ++ (shape : reprs))
+             . wrapFamInstBody arr_tc arg_tys
+             $ mkConApp arr_dc (map Type arg_tys ++ shape_reprs ++ reprs)
   where
-    val_ty = mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars arr_tc
-    wild   = mkWildId val_ty
+    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
 
@@ -395,7 +434,7 @@ buildReplicatePA vect_tc arr_tc
           arr_ty <- mkPArrayType ty
 
           return $ Case val wild arr_ty
-                     [(DataAlt dc, pre ++ (var : post), rep), (DEFAULT, [], empty)]
+                     [(DEFAULT, [], empty), (DataAlt dc, pre ++ (var : post), rep)]
 
 -- | 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