X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=958c5e6fd7a03c95b17c499da950ce1415f47853;hb=ee79af08084c320762b6b684e2ce8198395cf089;hp=f7df2779b3a6cf733ad32c8f8f64a33444c0c25a;hpb=263a30f1db8fc4f5b6cecc26176c6f881807e348;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index f7df277..958c5e6 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,11 +3,15 @@ module VectUtils (
   collectAnnValBinders,
   mkDataConTag,
   splitClosureTy,
-  mkPADictType, mkPArrayType,
+
+  mkBuiltinCo,
+  mkPADictType, mkPArrayType, mkPReprType,
+
+  parrayReprTyCon, parrayReprDataCon, mkVScrut,
+  prDFunOfTyCon,
   paDictArgType, paDictOfType, paDFunType,
-  paMethod, lengthPA, replicatePA, emptyPA, liftPA,
+  paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
-  lookupPArrayFamInst,
   hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
   buildClosure, buildClosures,
   mkClosureApp
@@ -21,21 +25,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 TysPrim            ( intPrimTy )
 import BasicTypes         ( Boxity(..) )
 
 import Outputable
 import FastString
 
-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 []
@@ -60,55 +68,117 @@ isAnnTypeArg (_, AnnType t) = True
 isAnnTypeArg _              = False
 
 mkDataConTag :: DataCon -> CoreExpr
-mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
+mkDataConTag = mkIntLitInt . dataConTag
 
-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)
+
+splitBinTy :: String -> Name -> Type -> (Type, Type)
+splitBinTy s name ty
+  | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty
+  , tyConName tc == name
+  = (ty1, ty2)
+
+  | otherwise = pprPanic s (ppr ty)
 
-  | otherwise = pprPanic "splitClosureTy" (ppr ty)
+splitFixedTyConApp :: TyCon -> Type -> [Type]
+splitFixedTyConApp tc ty
+  | Just (tc', tys) <- splitTyConApp_maybe ty
+  , tc == tc'
+  = tys
 
-isPArrayTyCon :: TyCon -> Bool
-isPArrayTyCon tc = tyConName tc == parrayTyConName
+  | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty)
+
+splitClosureTy :: Type -> (Type, Type)
+splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
 
 splitPArrayTy :: Type -> Type
-splitPArrayTy ty
-  | Just (tc, [arg_ty]) <- splitTyConApp_maybe ty
-  , isPArrayTyCon tc
-  = arg_ty
+splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
-  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+splitPrimTyCon :: Type -> Maybe TyCon
+splitPrimTyCon ty
+  | Just (tycon, []) <- splitTyConApp_maybe ty
+  , isPrimTyCon tycon
+  = Just tycon
 
-mkClosureType :: Type -> Type -> VM Type
-mkClosureType arg_ty res_ty
+  | otherwise = Nothing
+
+mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
+mkBuiltinTyConApp get_tc tys
   = do
-      tc <- builtin closureTyCon
-      return $ mkTyConApp tc [arg_ty, res_ty]
+      tc <- builtin get_tc
+      return $ mkTyConApp tc tys
 
-mkClosureTypes :: [Type] -> Type -> VM Type
-mkClosureTypes arg_tys res_ty
+mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
+mkBuiltinTyConApps get_tc tys ty
   = do
-      tc <- builtin closureTyCon
-      return $ foldr (mk tc) res_ty arg_tys
+      tc <- builtin get_tc
+      return $ foldr (mk tc) ty tys
   where
-    mk tc arg_ty res_ty = mkTyConApp tc [arg_ty, res_ty]
+    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
-mkPADictType :: Type -> VM Type
-mkPADictType ty
+mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
+mkBuiltinTyConApps1 get_tc dft [] = return dft
+mkBuiltinTyConApps1 get_tc dft tys
   = do
-      tc <- builtin paTyCon
-      return $ TyConApp tc [ty]
+      tc <- builtin get_tc
+      case tys of
+        [] -> pprPanic "mkBuiltinTyConApps1" (ppr tc)
+        _  -> return $ foldr1 (mk tc) tys
+  where
+    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+
+mkClosureType :: Type -> Type -> VM Type
+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
+  | Just tycon <- splitPrimTyCon ty
+  = do
+      arr <- traceMaybeV "mkPArrayType" (ppr tycon)
+           $ lookupPrimPArray tycon
+      return $ mkTyConApp arr []
+mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
+
+mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
+mkBuiltinCo get_tc
   = do
-      tc <- builtin parrayTyCon
-      return $ TyConApp tc [ty]
+      tc <- builtin get_tc
+      return $ mkTyConApp tc []
+
+parrayReprTyCon :: Type -> VM (TyCon, [Type])
+parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
+
+parrayReprDataCon :: Type -> VM (DataCon, [Type])
+parrayReprDataCon ty
+  = do
+      (tc, arg_tys) <- parrayReprTyCon ty
+      let [dc] = tyConDataCons tc
+      return (dc, arg_tys)
+
+mkVScrut :: VExpr -> VM (VExpr, TyCon, [Type])
+mkVScrut (ve, le)
+  = do
+      (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))
 
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
@@ -165,24 +235,44 @@ paDFunApply dfun tys
       dicts <- mapM paDictOfType tys
       return $ mkApps (mkTyApps dfun tys) dicts
 
-paMethod :: (Builtins -> Var) -> Type -> VM CoreExpr
-paMethod method ty
+type PAMethod = (Builtins -> Var, String)
+
+pa_length    = (lengthPAVar,    "lengthPA")
+pa_replicate = (replicatePAVar, "replicatePA")
+pa_empty     = (emptyPAVar,     "emptyPA")
+
+paMethod :: PAMethod -> Type -> VM CoreExpr
+paMethod (method, name) ty
+  | Just tycon <- splitPrimTyCon ty
+  = do
+      fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
+          $ lookupPrimMethod tycon name
+      return (Var fn)
+
+paMethod (method, name) ty
   = do
       fn   <- builtin method
       dict <- paDictOfType ty
       return $ mkApps (Var fn) [Type ty, dict]
 
+mkPR :: Type -> VM CoreExpr
+mkPR ty
+  = do
+      fn   <- builtin mkPRVar
+      dict <- paDictOfType ty
+      return $ mkApps (Var fn) [Type ty, dict]
+
 lengthPA :: CoreExpr -> VM CoreExpr
-lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
+lengthPA x = liftM (`App` x) (paMethod pa_length ty)
   where
     ty = splitPArrayTy (exprType x)
 
 replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr
 replicatePA len x = liftM (`mkApps` [len,x])
-                          (paMethod replicatePAVar (exprType x))
+                          (paMethod pa_replicate (exprType x))
 
 emptyPA :: Type -> VM CoreExpr
-emptyPA = paMethod emptyPAVar
+emptyPA = paMethod pa_empty
 
 liftPA :: CoreExpr -> VM CoreExpr
 liftPA x
@@ -226,9 +316,6 @@ polyVApply expr tys
       dicts <- mapM paDictOfType tys
       return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 
-lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
-lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
-
 hoistBinding :: Var -> CoreExpr -> VM ()
 hoistBinding v e = updGEnv $ \env ->
   env { global_bindings = (v,e) : global_bindings env }
@@ -283,6 +370,8 @@ mkClosureApp (vclo, lclo) (varg, larg)
     (arg_ty, res_ty) = splitClosureTy (exprType vclo)
 
 buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
+buildClosures tvs vars [] res_ty mk_body
+  = mk_body
 buildClosures tvs vars [arg_ty] res_ty mk_body
   = buildClosure tvs vars arg_ty res_ty mk_body
 buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
@@ -354,7 +443,7 @@ mkLiftEnv lc [ty] [v]
 -- NOTE: this transparently deals with empty environments
 mkLiftEnv lc tys vs
   = do
-      (env_tc, env_tyargs) <- lookupPArrayFamInst vty
+      (env_tc, env_tyargs) <- parrayReprTyCon vty
       let [env_con] = tyConDataCons env_tc
           
           env = Var (dataConWrapId env_con)