X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=a1f554db50e8d1de4157912e0a6f554a138966d9;hb=430cdcde07075d7e2a6d81578e8b889b53bf24b7;hp=8e95b809656b59e0dc58a4f8413481b24a85517d;hpb=742db8bde59c1175a50e5045332f05ec22d12e80;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 8e95b80..a1f554d 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,11 +3,15 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
-  mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
-  mkPADictType, mkPArrayType,
-  parrayReprTyCon, parrayReprDataCon, mkVScrut,
+
+  TyConRepr(..), mkTyConRepr,
+  mkToArrPRepr, mkFromArrPRepr,
+  mkPADictType, mkPArrayType, mkPReprType,
+
+  parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut,
+  prDFunOfTyCon, prCoerce,
   paDictArgType, paDictOfType, paDFunType,
-  paMethod, lengthPA, replicatePA, emptyPA, liftPA,
+  paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
   hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
   buildClosure, buildClosures,
@@ -22,21 +26,25 @@ import VectMonad
 import DsUtils
 import CoreSyn
 import CoreUtils
+import Coercion
 import Type
 import TypeRep
 import TyCon
-import DataCon            ( DataCon, dataConWrapId, dataConTag )
+import DataCon
 import Var
 import Id                 ( mkWildId )
 import MkId               ( unwrapFamInstScrut )
+import Name               ( Name )
 import PrelNames
 import TysWiredIn
 import BasicTypes         ( Boxity(..) )
 
 import Outputable
 import FastString
+import Maybes             ( orElse )
 
-import Control.Monad         ( liftM, zipWithM_ )
+import Data.List             ( zipWith4 )
+import Control.Monad         ( liftM, liftM2, zipWithM_ )
 
 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
 collectAnnTypeArgs expr = go expr []
@@ -63,27 +71,35 @@ isAnnTypeArg _              = False
 mkDataConTag :: DataCon -> CoreExpr
 mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
 
-isClosureTyCon :: TyCon -> Bool
-isClosureTyCon tc = tyConName tc == closureTyConName
+splitUnTy :: String -> Name -> Type -> Type
+splitUnTy s name ty
+  | Just (tc, [ty']) <- splitTyConApp_maybe ty
+  , tyConName tc == name
+  = ty'
 
-splitClosureTy :: Type -> (Type, Type)
-splitClosureTy ty
-  | Just (tc, [arg_ty, res_ty]) <- splitTyConApp_maybe ty
-  , isClosureTyCon tc
-  = (arg_ty, res_ty)
+  | otherwise = pprPanic s (ppr ty)
 
-  | otherwise = pprPanic "splitClosureTy" (ppr ty)
+splitBinTy :: String -> Name -> Type -> (Type, Type)
+splitBinTy s name ty
+  | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty
+  , tyConName tc == name
+  = (ty1, ty2)
 
-isPArrayTyCon :: TyCon -> Bool
-isPArrayTyCon tc = tyConName tc == parrayTyConName
+  | otherwise = pprPanic s (ppr ty)
 
-splitPArrayTy :: Type -> Type
-splitPArrayTy ty
-  | Just (tc, [arg_ty]) <- splitTyConApp_maybe ty
-  , isPArrayTyCon tc
-  = arg_ty
+splitFixedTyConApp :: TyCon -> Type -> [Type]
+splitFixedTyConApp tc ty
+  | Just (tc', tys) <- splitTyConApp_maybe ty
+  , tc == tc'
+  = tys
+
+  | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty)
+
+splitClosureTy :: Type -> (Type, Type)
+splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
 
-  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+splitPArrayTy :: Type -> Type
+splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 mkBuiltinTyConApp get_tc tys
@@ -110,20 +126,85 @@ mkBuiltinTyConApps1 get_tc dft tys
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
-mkPlusType :: Type -> Type -> VM Type
-mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
+data TyConRepr = TyConRepr {
+                   repr_tyvars         :: [TyVar]
+                 , repr_tys            :: [[Type]]
+
+                 , repr_prod_tycons    :: [Maybe TyCon]
+                 , repr_prod_data_cons :: [Maybe DataCon]
+                 , repr_prod_tys       :: [Type]
+                 , repr_sum_tycon      :: Maybe TyCon
+                 , repr_sum_data_cons  :: [DataCon]
+                 , repr_type           :: Type
+                 }
+
+mkTyConRepr :: TyCon -> VM TyConRepr
+mkTyConRepr vect_tc
+  = do
+      prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
+      let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
+      sum_tycon   <- mk_tycon sumTyCon prod_tys
+
+      return $ TyConRepr {
+                 repr_tyvars         = tyvars
+               , repr_tys            = rep_tys
+
+               , repr_prod_tycons    = prod_tycons
+               , repr_prod_data_cons = map (fmap mk_single_datacon) prod_tycons
+               , repr_prod_tys       = prod_tys
+               , repr_sum_tycon      = sum_tycon
+               , repr_sum_data_cons  = fmap tyConDataCons sum_tycon `orElse` []
+               , repr_type           = mk_tc_app_maybe sum_tycon prod_tys
+               }
+  where
+    tyvars = tyConTyVars vect_tc
+    data_cons = tyConDataCons vect_tc
+    rep_tys   = map dataConRepArgTys data_cons
 
-mkPlusTypes :: Type -> [Type] -> VM Type
-mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+    mk_tycon get_tc tys
+      | n > 1     = builtin (Just . get_tc n)
+      | otherwise = return Nothing
+      where n = length tys
 
-mkCrossType :: Type -> Type -> VM Type
-mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
+    mk_single_datacon tc | [dc] <- tyConDataCons tc = dc
 
-mkCrossTypes :: Type -> [Type] -> VM Type
-mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
+    mk_tc_app_maybe Nothing   []   = unitTy
+    mk_tc_app_maybe Nothing   [ty] = ty
+    mk_tc_app_maybe (Just tc) tys  = mkTyConApp tc tys
 
-mkEmbedType :: Type -> VM Type
-mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
+mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr
+mkToArrPRepr len sel ess
+  = do
+      let mk_sum [(expr, ty)] = return (expr, ty)
+          mk_sum es
+            = do
+                sum_tc <- builtin . sumTyCon $ length es
+                (sum_rtc, _) <- parrayReprTyCon (mkTyConApp sum_tc tys)
+                let [sum_rdc] = tyConDataCons sum_rtc
+
+                return (mkConApp sum_rdc (map Type tys ++ (len : sel : exprs)),
+                        mkTyConApp sum_tc tys)
+            where
+              (exprs, tys) = unzip es
+
+          mk_prod [expr] = return (expr, splitPArrayTy (exprType expr))
+          mk_prod exprs
+            = do
+                prod_tc <- builtin . prodTyCon $ length exprs
+                (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys)
+                let [prod_rdc] = tyConDataCons prod_rtc
+
+                return (mkConApp prod_rdc (map Type tys ++ (len : exprs)),
+                        mkTyConApp prod_tc tys)
+            where
+              tys = map (splitPArrayTy . exprType) exprs
+
+      liftM fst (mk_sum =<< mapM mk_prod ess)
+
+mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr
+               -> VM CoreExpr
+mkFromArrPRepr scrut res_ty len sel vars res
+  = return (Var unitDataConId)
 
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
@@ -131,12 +212,26 @@ mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
 mkClosureTypes :: [Type] -> Type -> VM Type
 mkClosureTypes = mkBuiltinTyConApps closureTyCon
 
+mkPReprType :: Type -> VM Type
+mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
+
 mkPADictType :: Type -> VM Type
 mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]
 
 mkPArrayType :: Type -> VM Type
 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
 
+parrayCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
+parrayCoerce repr_tc args expr
+  | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
+  = do
+      parray <- builtin parrayTyCon
+
+      let co = mkAppCoercion (mkTyConApp parray [])
+                             (mkSymCoercion (mkTyConApp arg_co args))
+
+      return $ mkCoerce co expr
+
 parrayReprTyCon :: Type -> VM (TyCon, [Type])
 parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
 
@@ -153,6 +248,21 @@ mkVScrut (ve, le)
       (tc, arg_tys) <- parrayReprTyCon (exprType ve)
       return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys)
 
+prDFunOfTyCon :: TyCon -> VM CoreExpr
+prDFunOfTyCon tycon
+  = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon))
+
+prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
+prCoerce repr_tc args expr
+  | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
+  = do
+      pr_tc <- builtin prTyCon
+
+      let co = mkAppCoercion (mkTyConApp pr_tc [])
+                             (mkSymCoercion (mkTyConApp arg_co args))
+
+      return $ mkCoerce co expr
+
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
   where
@@ -215,6 +325,9 @@ paMethod method ty
       dict <- paDictOfType ty
       return $ mkApps (Var fn) [Type ty, dict]
 
+mkPR :: Type -> VM CoreExpr
+mkPR = paMethod mkPRVar
+
 lengthPA :: CoreExpr -> VM CoreExpr
 lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
   where