Fix vectorisation of sum type constructors

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

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index a50b4de..958c5e6 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -4,10 +4,11 @@ module VectUtils (
   mkDataConTag,
   splitClosureTy,
 
+  mkBuiltinCo,
   mkPADictType, mkPArrayType, mkPReprType,
 
-  parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut,
-  prDFunOfTyCon, prCoerce,
+  parrayReprTyCon, parrayReprDataCon, mkVScrut,
+  prDFunOfTyCon,
   paDictArgType, paDictOfType, paDFunType,
   paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
@@ -67,7 +68,7 @@ isAnnTypeArg (_, AnnType t) = True
 isAnnTypeArg _              = False
 
 mkDataConTag :: DataCon -> CoreExpr
-mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
+mkDataConTag = mkIntLitInt . dataConTag
 
 splitUnTy :: String -> Name -> Type -> Type
 splitUnTy s name ty
@@ -99,6 +100,14 @@ splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
 splitPArrayTy :: Type -> Type
 splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
+splitPrimTyCon :: Type -> Maybe TyCon
+splitPrimTyCon ty
+  | Just (tycon, []) <- splitTyConApp_maybe ty
+  , isPrimTyCon tycon
+  = Just tycon
+
+  | otherwise = Nothing
+
 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 mkBuiltinTyConApp get_tc tys
   = do
@@ -137,18 +146,19 @@ 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]
 
-parrayCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
-parrayCoerce repr_tc args expr
-  | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
+mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
+mkBuiltinCo get_tc
   = do
-      parray <- builtin parrayTyCon
-
-      let co = mkAppCoercion (mkTyConApp parray [])
-                             (mkSymCoercion (mkTyConApp arg_co args))
-
-      return $ mkCoerce co expr
+      tc <- builtin get_tc
+      return $ mkTyConApp tc []
 
 parrayReprTyCon :: Type -> VM (TyCon, [Type])
 parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
@@ -170,17 +180,6 @@ 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
@@ -236,27 +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 = paMethod mkPRVar
+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