Adapt PArray instance generation to new scheme

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

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index e505cd3..10c3bbf 100644 (file)
--- 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        ( unitTy, intTy, intDataCon, unitDataConId )
+import TysWiredIn        ( unitTy, unitTyCon, intTy, intDataCon, unitDataConId )
 import TysPrim           ( intPrimTy )
 
 import Unique
@@ -213,11 +213,11 @@ buildPReprType = liftM repr_type . mkTyConRepr
 
 buildToPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildToPRepr (TyConRepr {
-                repr_tys         = repr_tys
-              , repr_prod_tycons = prod_tycons
-              , repr_prod_tys    = prod_tys
-              , repr_sum_tycon   = repr_sum_tycon
-              , repr_type        = repr_type
+                repr_tys            = repr_tys
+              , repr_prod_data_cons = prod_data_cons
+              , repr_prod_tys       = prod_tys
+              , repr_sum_data_cons  = sum_data_cons
+              , repr_type           = repr_type
               })
               vect_tc prepr_tc _
   = do
@@ -228,15 +228,12 @@ buildToPRepr (TyConRepr {
              . wrapFamInstBody prepr_tc var_tys
              . Case (Var arg) (mkWildId arg_ty) repr_type
              . mk_alts data_cons vars
-             . zipWith3 mk_prod prod_tycons repr_tys $ map (map Var) vars
+             . zipWith3 mk_prod prod_data_cons repr_tys $ map (map Var) vars
   where
     var_tys   = mkTyVarTys $ tyConTyVars vect_tc
     arg_ty    = mkTyConApp vect_tc var_tys
     data_cons = tyConDataCons vect_tc
 
-    Just sum_tycon = repr_sum_tycon
-    sum_data_cons  = tyConDataCons sum_tycon
-
     mk_alts _    _      []     = [(DEFAULT, [], Var unitDataConId)]
     mk_alts [dc] [vars] [expr] = [(DataAlt dc, vars, expr)]
     mk_alts dcs  vars   exprs  = zipWith4 mk_alt dcs vars sum_data_cons exprs 
@@ -246,17 +243,15 @@ buildToPRepr (TyConRepr {
 
     mk_prod _         _   []     = Var unitDataConId
     mk_prod _         _   [expr] = expr
-    mk_prod (Just tc) tys exprs  = mkConApp dc (map Type tys ++ exprs)
-      where
-        [dc] = tyConDataCons tc
+    mk_prod (Just dc) tys exprs  = mkConApp dc (map Type tys ++ exprs)
 
 buildFromPRepr :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildFromPRepr (TyConRepr {
-                repr_tys         = repr_tys
-              , repr_prod_tycons = prod_tycons
-              , repr_prod_tys    = prod_tys
-              , repr_sum_tycon   = repr_sum_tycon
-              , repr_type        = repr_type
+                repr_tys            = repr_tys
+              , repr_prod_data_cons = prod_data_cons
+              , repr_prod_tys       = prod_tys
+              , repr_sum_data_cons  = sum_data_cons
+              , repr_type           = repr_type
               })
               vect_tc prepr_tc _
   = do
@@ -265,16 +260,14 @@ buildFromPRepr (TyConRepr {
 
       liftM (Lam arg
              . un_sum (unwrapFamInstScrut prepr_tc var_tys (Var arg)))
-            (sequence $ zipWith4 un_prod data_cons prod_tycons prod_tys repr_tys)
+            (sequence
+             $ zipWith4 un_prod data_cons prod_data_cons prod_tys repr_tys)
   where
     var_tys   = mkTyVarTys $ tyConTyVars vect_tc
     ty_args   = map Type var_tys
     res_ty    = mkTyConApp vect_tc var_tys
     data_cons = tyConDataCons vect_tc
 
-    Just sum_tc   = repr_sum_tycon
-    sum_data_cons = tyConDataCons sum_tc
-
     un_prod dc _ _ []
       = do
           var <- newLocalVar FSLIT("u") unitTy
@@ -284,7 +277,7 @@ buildFromPRepr (TyConRepr {
           var <- newLocalVar FSLIT("x") ty
           return (var, mkConApp dc (ty_args ++ [Var var]))
 
-    un_prod dc (Just prod_tc) prod_ty tys
+    un_prod dc (Just prod_dc) prod_ty tys
       = do
           vars  <- mapM (newLocalVar FSLIT("x")) tys
           pv    <- newLocalVar FSLIT("p") prod_ty
@@ -294,9 +287,6 @@ buildFromPRepr (TyConRepr {
                         [(DataAlt prod_dc, vars, res)]
 
           return (pv, expr)
-      where
-        [prod_dc] = tyConDataCons prod_tc
-
 
     un_sum scrut [(var, expr)] = Let (NonRec var scrut) expr
     un_sum scrut alts
@@ -347,12 +337,36 @@ buildFromArrPRepr _ vect_tc prepr_tc arr_tc
   = mkFromArrPRepr undefined undefined undefined undefined undefined undefined
 
 buildPRDict :: TyConRepr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
-buildPRDict _ vect_tc prepr_tc _
-  = prCoerce prepr_tc var_tys
-  =<< prDictOfType (mkTyConApp prepr_tc var_tys)
+buildPRDict (TyConRepr {
+                repr_tys         = repr_tys
+              , repr_prod_tycons = prod_tycons
+              , repr_prod_tys    = prod_tys
+              , repr_sum_tycon   = repr_sum_tycon
+              })
+            vect_tc prepr_tc _
+  = do
+      prs      <- mapM (mapM mkPR) repr_tys
+      prod_prs <- sequence $ zipWith3 mk_prod_pr prod_tycons repr_tys prs
+      sum_pr   <- mk_sum_pr prod_prs
+      prCoerce prepr_tc var_tys sum_pr
   where
     var_tys = mkTyVarTys $ tyConTyVars vect_tc
 
+    Just sum_tycon = repr_sum_tycon
+
+    mk_prod_pr _         _   []   = prDFunOfTyCon unitTyCon
+    mk_prod_pr _         _   [pr] = return pr
+    mk_prod_pr (Just tc) tys prs
+      = do
+          dfun <- prDFunOfTyCon tc
+          return $ dfun `mkTyApps` tys `mkApps` prs
+
+    mk_sum_pr [pr] = return pr
+    mk_sum_pr prs
+      = do
+          dfun <- prDFunOfTyCon sum_tycon
+          return $ dfun `mkTyApps` prod_tys `mkApps` prs
+
 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
   do
@@ -384,22 +398,20 @@ buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
 buildPArrayDataCon orig_name vect_tc repr_tc
   = do
       dc_name  <- cloneName mkPArrayDataConOcc orig_name
-      shape    <- tyConShape vect_tc
-      repr_tys <- mapM mkPArrayType types
+      repr     <- mkTyConRepr vect_tc
+
+      let all_tys = arr_shape_tys repr ++ concat (arr_repr_tys repr)
 
       liftDs $ buildDataCon dc_name
                             False                  -- not infix
-                            (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
+                            (map (const NotMarkedStrict) all_tys)
                             []                     -- no field labels
                             (tyConTyVars vect_tc)
                             []                     -- no existentials
                             []                     -- no eq spec
                             []                     -- no context
-                            (shapeReprTys shape ++ repr_tys)
+                            all_tys
                             repr_tc
-  where
-    types = [ty | dc <- tyConDataCons vect_tc
-                , ty <- dataConRepArgTys dc]
 
 mkPADFun :: TyCon -> VM Var
 mkPADFun vect_tc