X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=7b0e4af4e12ba37c128e216ac784b4b8ca5f2dd3;hb=86193bcfc847f1a1f844508224489456f08d6b83;hp=0d200a8ccbdfcdccdf595d5634dfd0090f9f1445;hpb=76fb33900748c86d97aa528bae91cd1844aed97d;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 0d200a8..7b0e4af 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -4,7 +4,7 @@ module VectUtils (
   mkPADictType, mkPArrayType,
   paDictArgType, paDictOfType,
   paMethod, lengthPA, replicatePA, emptyPA,
-  abstractOverTyVars, applyToTypes,
+  polyAbstract, polyApply,
   lookupPArrayFamInst,
   hoistExpr, takeHoisted
 ) where
@@ -43,7 +43,7 @@ isAnnTypeArg (_, AnnType t) = True
 isAnnTypeArg _              = False
 
 isClosureTyCon :: TyCon -> Bool
-isClosureTyCon tc = tyConUnique tc == closureTyConKey
+isClosureTyCon tc = tyConName tc == closureTyConName
 
 splitClosureTy :: Type -> (Type, Type)
 splitClosureTy ty
@@ -53,6 +53,17 @@ splitClosureTy ty
 
   | otherwise = pprPanic "splitClosureTy" (ppr ty)
 
+isPArrayTyCon :: TyCon -> Bool
+isPArrayTyCon tc = tyConName tc == parrayTyConName
+
+splitPArrayTy :: Type -> Type
+splitPArrayTy ty
+  | Just (tc, [arg_ty]) <- splitTyConApp_maybe ty
+  , isPArrayTyCon tc
+  = arg_ty
+
+  | otherwise = pprPanic "splitPArrayTy" (ppr ty)
+
 mkPADictType :: Type -> VM Type
 mkPADictType ty
   = do
@@ -118,7 +129,9 @@ paMethod method ty
       return $ mkApps (Var fn) [Type ty, dict]
 
 lengthPA :: CoreExpr -> VM CoreExpr
-lengthPA x = liftM (`App` x) (paMethod lengthPAVar (exprType x))
+lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
+  where
+    ty = splitPArrayTy (exprType x)
 
 replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr
 replicatePA len x = liftM (`mkApps` [len,x])
@@ -127,9 +140,10 @@ replicatePA len x = liftM (`mkApps` [len,x])
 emptyPA :: Type -> VM CoreExpr
 emptyPA = paMethod emptyPAVar
 
-abstractOverTyVars :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
-abstractOverTyVars tvs p
-  = do
+polyAbstract :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
+polyAbstract tvs p
+  = localV
+  $ do
       mdicts <- mapM mk_dict_var tvs
       zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts
       p (mk_lams mdicts)
@@ -142,8 +156,8 @@ abstractOverTyVars tvs p
 
     mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
 
-applyToTypes :: CoreExpr -> [Type] -> VM CoreExpr
-applyToTypes expr tys
+polyApply :: CoreExpr -> [Type] -> VM CoreExpr
+polyApply expr tys
   = do
       dicts <- mapM paDictOfType tys
       return $ expr `mkTyApps` tys `mkApps` dicts