X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectCore.hs;h=39341ef1795b9b04239d4925587d59a056648c4b;hp=cdae4dd9968a17ce6054ede5096828d961402276;hb=8a027f2827fd1997bb2791cfcf67c10d7a77d874;hpb=ae9408573da499e87485cc2957b15893bbc8feb5 diff --git a/compiler/vectorise/VectCore.hs b/compiler/vectorise/VectCore.hs index cdae4dd..39341ef 100644 --- a/compiler/vectorise/VectCore.hs +++ b/compiler/vectorise/VectCore.hs @@ -1,3 +1,5 @@ + +-- | Simple vectorised constructors and projections. module VectCore ( Vect, VVar, VExpr, VBind, @@ -19,63 +21,109 @@ import CoreSyn import Type ( Type ) import Var +-- | Contains the vectorised and lifted versions of some thing. type Vect a = (a,a) type VVar = Vect Var type VExpr = Vect CoreExpr type VBind = Vect CoreBind + +-- | Get the vectorised version of a thing. vectorised :: Vect a -> a vectorised = fst + +-- | Get the lifted version of a thing. lifted :: Vect a -> a lifted = snd + +-- | Apply some function to both the vectorised and lifted versions of a thing. mapVect :: (a -> b) -> Vect a -> Vect b mapVect f (x,y) = (f x, f y) + +-- | Combine vectorised and lifted versions of two things componentwise. zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c zipWithVect f (x1,y1) (x2,y2) = (f x1 x2, f y1 y2) + +-- | Get the type of a vectorised variable. vVarType :: VVar -> Type vVarType = varType . vectorised + +-- | Wrap a vectorised variable as a vectorised expression. vVar :: VVar -> VExpr vVar = mapVect Var + +-- | Wrap a vectorised type as a vectorised expression. vType :: Type -> VExpr vType ty = (Type ty, Type ty) + +-- | Make a vectorised note. vNote :: Note -> VExpr -> VExpr vNote = mapVect . Note + +-- | Make a vectorised non-recursive binding. vNonRec :: VVar -> VExpr -> VBind vNonRec = zipWithVect NonRec + +-- | Make a vectorised recursive binding. vRec :: [VVar] -> [VExpr] -> VBind vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les)) where (vvs, lvs) = unzip vs (ves, les) = unzip es + +-- | Make a vectorised let expresion. vLet :: VBind -> VExpr -> VExpr vLet = zipWithVect Let -vLams :: Var -> [VVar] -> VExpr -> VExpr -vLams lc vs (ve, le) = (mkLams vvs ve, mkLams (lc:lvs) le) + +-- | Make a vectorised lambda abstraction. +-- The lifted version also binds the lifting context. +vLams :: Var -- ^ Var bound to the lifting context. + -> [VVar] -- ^ Parameter vars for the abstraction. + -> VExpr -- ^ Body of the abstraction. + -> VExpr + +vLams lc vs (ve, le) + = (mkLams vvs ve, mkLams (lc:lvs) le) where (vvs,lvs) = unzip vs + +-- | Like `vLams` but the lifted version doesn't bind the lifting context. vLamsWithoutLC :: [VVar] -> VExpr -> VExpr -vLamsWithoutLC vvs (ve,le) = (mkLams vs ve, mkLams ls le) +vLamsWithoutLC vvs (ve,le) + = (mkLams vs ve, mkLams ls le) where (vs,ls) = unzip vvs + +-- | Apply some argument variables to an expression. +-- The lifted version is also applied to the variable of the lifting context. vVarApps :: Var -> VExpr -> [VVar] -> VExpr -vVarApps lc (ve, le) vvs = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) +vVarApps lc (ve, le) vvs + = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) where (vs,ls) = unzip vvs -vCaseDEFAULT :: VExpr -> VVar -> Type -> Type -> VExpr -> VExpr + +vCaseDEFAULT + :: VExpr -- scrutiniy + -> VVar -- bnder + -> Type -- type of vectorised version + -> Type -- type of lifted version + -> VExpr -- body of alternative. + -> VExpr + vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) = (Case vscrut vbndr vty (mkDEFAULT vbody), Case lscrut lbndr lty (mkDEFAULT lbody))