From ee79af08084c320762b6b684e2ce8198395cf089 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Thu, 30 Aug 2007 03:52:25 +0000 Subject: [PATCH] Fix vectorisation of sum type constructors --- compiler/prelude/PrelNames.lhs | 6 ++++++ compiler/vectorise/VectBuiltIn.hs | 6 ++++++ compiler/vectorise/VectType.hs | 5 +++++ compiler/vectorise/VectUtils.hs | 2 +- 4 files changed, 18 insertions(+), 1 deletion(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 1f09675..2740d26 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -223,6 +223,7 @@ ndpNames = [ parrayTyConName, paTyConName, preprTyConName, prTyConName , closureTyConName , mkClosureName, applyClosureName , mkClosurePName, applyClosurePName + , replicatePAIntPrimName, upToPAIntPrimName , lengthPAName, replicatePAName, emptyPAName, packPAName, combinePAName ] \end{code} @@ -702,6 +703,9 @@ prTyConName = tcQual nDP_PARRAY FSLIT("PR") prTyConKey parrayIntPrimTyConName = tcQual nDP_PRIM FSLIT("PArray_Int#") parrayIntPrimTyConKey mkPRName = varQual nDP_PARRAY FSLIT("mkPR") mkPRIdKey +replicatePAIntPrimName = varQual nDP_PRIM FSLIT("replicatePA_Int#") + replicatePAIntPrimIdKey +upToPAIntPrimName = varQual nDP_PRIM FSLIT("upToPA_Int#") upToPAIntPrimIdKey lengthPAName = varQual nDP_PARRAY FSLIT("lengthPA") lengthPAIdKey replicatePAName = varQual nDP_PARRAY FSLIT("replicatePA") replicatePAIdKey emptyPAName = varQual nDP_PARRAY FSLIT("emptyPA") emptyPAIdKey @@ -1090,6 +1094,8 @@ emptyPAIdKey = mkPreludeMiscIdUnique 133 packPAIdKey = mkPreludeMiscIdUnique 134 combinePAIdKey = mkPreludeMiscIdUnique 135 mkPRIdKey = mkPreludeMiscIdUnique 136 +replicatePAIntPrimIdKey = mkPreludeMiscIdUnique 137 +upToPAIntPrimIdKey = mkPreludeMiscIdUnique 138 ---------------- Template Haskell ------------------- -- USES IdUniques 200-399 diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 2338d87..e340cd1 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -53,6 +53,8 @@ data Builtins = Builtins { , applyClosureVar :: Var , mkClosurePVar :: Var , applyClosurePVar :: Var + , replicatePAIntPrimVar :: Var + , upToPAIntPrimVar :: Var , lengthPAVar :: Var , replicatePAVar :: Var , emptyPAVar :: Var @@ -93,6 +95,8 @@ initBuiltins applyClosureVar <- dsLookupGlobalId applyClosureName mkClosurePVar <- dsLookupGlobalId mkClosurePName applyClosurePVar <- dsLookupGlobalId applyClosurePName + replicatePAIntPrimVar <- dsLookupGlobalId replicatePAIntPrimName + upToPAIntPrimVar <- dsLookupGlobalId upToPAIntPrimName lengthPAVar <- dsLookupGlobalId lengthPAName replicatePAVar <- dsLookupGlobalId replicatePAName emptyPAVar <- dsLookupGlobalId emptyPAName @@ -117,6 +121,8 @@ initBuiltins , applyClosureVar = applyClosureVar , mkClosurePVar = mkClosurePVar , applyClosurePVar = applyClosurePVar + , replicatePAIntPrimVar = replicatePAIntPrimVar + , upToPAIntPrimVar = upToPAIntPrimVar , lengthPAVar = lengthPAVar , replicatePAVar = replicatePAVar , emptyPAVar = emptyPAVar diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 0e397ba..ba64d3b 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -297,6 +297,11 @@ arrShapeVars repr = mapM (newLocalVar FSLIT("sh")) =<< arrShapeTys repr replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr] replicateShape (ProdRepr {}) len _ = return [len] +replicateShape (SumRepr {}) len tag + = do + rep <- builtin replicatePAIntPrimVar + up <- builtin upToPAIntPrimVar + return [len, Var rep `mkApps` [len, tag], Var up `App` len] arrReprElemTys :: Repr -> [[Type]] arrReprElemTys (SumRepr { sum_components = prods }) diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index b9c4597..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 -- 1.7.10.4