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

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 3c9d921..958c5e6 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -68,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
@@ -100,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
@@ -138,6 +146,12 @@ 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
@@ -229,8 +243,7 @@ pa_empty     = (emptyPAVar,     "emptyPA")
 
 paMethod :: PAMethod -> Type -> VM CoreExpr
 paMethod (method, name) ty
-  | Just (tycon, []) <- splitTyConApp_maybe ty
-  , isPrimTyCon tycon
+  | Just tycon <- splitPrimTyCon ty
   = do
       fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
           $ lookupPrimMethod tycon name