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

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 8e95b80..d1c1dab 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,9 +3,10 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
-  mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
-  mkPADictType, mkPArrayType,
+  mkPRepr, mkToPRepr, mkFromPRepr,
+  mkPADictType, mkPArrayType, mkPReprType,
   parrayReprTyCon, parrayReprDataCon, mkVScrut,
+  prDictOfType, prCoerce,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
@@ -22,6 +23,7 @@ import VectMonad
 import DsUtils
 import CoreSyn
 import CoreUtils
+import Coercion
 import Type
 import TypeRep
 import TyCon
@@ -29,6 +31,7 @@ import DataCon            ( DataCon, dataConWrapId, dataConTag )
 import Var
 import Id                 ( mkWildId )
 import MkId               ( unwrapFamInstScrut )
+import Name               ( Name )
 import PrelNames
 import TysWiredIn
 import BasicTypes         ( Boxity(..) )
@@ -36,7 +39,7 @@ import BasicTypes         ( Boxity(..) )
 import Outputable
 import FastString
 
-import Control.Monad         ( liftM, zipWithM_ )
+import Control.Monad         ( liftM, liftM2, zipWithM_ )
 
 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
 collectAnnTypeArgs expr = go expr []
@@ -63,27 +66,36 @@ 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
+splitCrossTy :: Type -> (Type, Type)
+splitCrossTy = splitBinTy "splitCrossTy" ndpCrossTyConName
+
+splitPlusTy :: Type -> (Type, Type)
+splitPlusTy = splitBinTy "splitSumTy" ndpPlusTyConName
+
+splitEmbedTy :: Type -> Type
+splitEmbedTy = splitUnTy "splitEmbedTy" embedTyConName
 
-  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+splitClosureTy :: Type -> (Type, Type)
+splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
+
+splitPArrayTy :: Type -> Type
+splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 mkBuiltinTyConApp get_tc tys
@@ -110,20 +122,108 @@ 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]
+mkPRepr :: [[Type]] -> VM Type
+mkPRepr [] = return unitTy
+mkPRepr tys
+  = do
+      embed <- builtin embedTyCon
+      cross <- builtin crossTyCon
+      plus  <- builtin plusTyCon
+
+      let mk_embed ty      = mkTyConApp embed [ty]
+          mk_cross ty1 ty2 = mkTyConApp cross [ty1, ty2]
+          mk_plus  ty1 ty2 = mkTyConApp plus  [ty1, ty2]
 
-mkPlusTypes :: Type -> [Type] -> VM Type
-mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+          mk_tup   []      = unitTy
+          mk_tup   tys     = foldr1 mk_cross tys
 
-mkCrossType :: Type -> Type -> VM Type
-mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
+          mk_sum   []      = unitTy
+          mk_sum   tys     = foldr1 mk_plus  tys
 
-mkCrossTypes :: Type -> [Type] -> VM Type
-mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
+      return . mk_sum
+             . map (mk_tup . map mk_embed)
+             $ tys
 
-mkEmbedType :: Type -> VM Type
-mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
+mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type)
+mkToPRepr ess
+  = do
+      embed_tc <- builtin embedTyCon
+      embed_dc <- builtin embedDataCon
+      cross_tc <- builtin crossTyCon
+      cross_dc <- builtin crossDataCon
+      plus_tc  <- builtin plusTyCon
+      left_dc  <- builtin leftDataCon
+      right_dc <- builtin rightDataCon
+
+      let mk_embed expr
+            = (mkConApp   embed_dc [Type ty, expr],
+               mkTyConApp embed_tc [ty])
+            where ty = exprType expr
+
+          mk_cross (expr1, ty1) (expr2, ty2)
+            = (mkConApp   cross_dc [Type ty1, Type ty2, expr1, expr2],
+               mkTyConApp cross_tc [ty1, ty2])
+
+          mk_tup [] = (Var unitDataConId, unitTy)
+          mk_tup es = foldr1 mk_cross es
+
+          mk_sum []           = ([Var unitDataConId], unitTy)
+          mk_sum [(expr, ty)] = ([expr], ty)
+          mk_sum ((expr, lty) : es)
+            = let (alts, rty) = mk_sum es
+              in
+              (mkConApp left_dc [Type lty, Type rty, expr]
+                 : [mkConApp right_dc [Type lty, Type rty, alt] | alt <- alts],
+               mkTyConApp plus_tc [lty, rty])
+
+      return . mk_sum $ map (mk_tup . map mk_embed) ess
+
+mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr
+mkFromPRepr scrut res_ty alts
+  = do
+      embed_dc <- builtin embedDataCon
+      cross_dc <- builtin crossDataCon
+      left_dc  <- builtin leftDataCon
+      right_dc <- builtin rightDataCon
+      pa_tc    <- builtin paTyCon
+
+      let un_embed expr ty var res
+            = Case expr (mkWildId ty) res_ty
+                   [(DataAlt embed_dc, [var], res)]
+
+          un_cross expr ty var1 var2 res
+            = Case expr (mkWildId ty) res_ty
+                [(DataAlt cross_dc, [var1, var2], res)]
+
+          un_tup expr ty []    res = return res
+          un_tup expr ty [var] res = return $ un_embed expr ty var res
+          un_tup expr ty (var : vars) res
+            = do
+                lv <- newLocalVar FSLIT("x") lty
+                rv <- newLocalVar FSLIT("y") rty
+                liftM (un_cross expr ty lv rv
+                      . un_embed (Var lv) lty var)
+                      (un_tup (Var rv) rty vars res)
+            where
+              (lty, rty) = splitCrossTy ty
+
+          un_plus expr ty var1 var2 res1 res2
+            = Case expr (mkWildId ty) res_ty
+                [(DataAlt left_dc,  [var1], res1),
+                 (DataAlt right_dc, [var2], res2)]
+
+          un_sum expr ty [(vars, res)] = un_tup expr ty vars res
+          un_sum expr ty ((vars, res) : alts)
+            = do
+                lv <- newLocalVar FSLIT("l") lty
+                rv <- newLocalVar FSLIT("r") rty
+                liftM2 (un_plus expr ty lv rv)
+                         (un_tup (Var lv) lty vars res)
+                         (un_sum (Var rv) rty alts)
+            where
+              (lty, rty) = splitPlusTy ty
+
+      un_sum scrut (exprType scrut) alts
 
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
@@ -131,6 +231,9 @@ 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]
 
@@ -153,6 +256,47 @@ mkVScrut (ve, le)
       (tc, arg_tys) <- parrayReprTyCon (exprType ve)
       return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys)
 
+prDictOfType :: Type -> VM CoreExpr
+prDictOfType orig_ty
+  | Just (tycon, ty_args) <- splitTyConApp_maybe orig_ty
+  = do
+      dfun <- traceMaybeV "prDictOfType" (ppr tycon) (lookupTyConPR tycon)
+      prDFunApply (Var dfun) ty_args
+
+prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+  = do
+      args <- mapM mkDFunArg arg_tys
+      return $ mkApps mono_dfun args
+  where
+    mono_dfun    = mkTyApps dfun tys
+    (arg_tys, _) = splitFunTys (exprType mono_dfun)
+
+mkDFunArg :: Type -> VM CoreExpr
+mkDFunArg ty
+  | Just (tycon, [arg]) <- splitTyConApp_maybe ty
+
+  = let name = tyConName tycon
+
+        get_dict | name == paTyConName = paDictOfType
+                 | name == prTyConName = prDictOfType
+                 | otherwise           = pprPanic "mkDFunArg" (ppr ty)
+
+    in get_dict arg
+
+mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty)
+
+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