From: benl@ouroborus.net Date: Mon, 30 Aug 2010 04:27:22 +0000 (+0000) Subject: Comments and formatting to vectoriser, and split out varish stuff into own module X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8a027f2827fd1997bb2791cfcf67c10d7a77d874 Comments and formatting to vectoriser, and split out varish stuff into own module --- 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)) diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 0ce6930..41c0cc4 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -365,9 +365,11 @@ updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) readLEnv :: (LocalEnv -> a) -> VM a readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv)) +-- | Set the local environment. setLEnv :: LocalEnv -> VM () setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ()) +-- | Update the enviroment using a provided function. updLEnv :: (LocalEnv -> LocalEnv) -> VM () updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) diff --git a/compiler/vectorise/VectVar.hs b/compiler/vectorise/VectVar.hs new file mode 100644 index 0000000..68bc9b5 --- /dev/null +++ b/compiler/vectorise/VectVar.hs @@ -0,0 +1,126 @@ + +-- | Vectorise variables and literals. +module VectVar ( + vectBndr, + vectBndrNew, + vectBndrIn, + vectBndrNewIn, + vectBndrsIn, + vectVar, + vectPolyVar, + vectLiteral +) where +import VectUtils +import VectCore +import VectMonad +import VectType +import CoreSyn +import Type +import Var +import VarEnv +import Literal +import Id +import FastString +import Control.Monad + + +-- Binders ---------------------------------------------------------------------------------------- +-- | Vectorise a binder variable, along with its attached type. +vectBndr :: Var -> VM VVar +vectBndr v + = do (vty, lty) <- vectAndLiftType (idType v) + let vv = v `Id.setIdType` vty + lv = v `Id.setIdType` lty + + updLEnv (mapTo vv lv) + + return (vv, lv) + where + mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) } + + +-- | Vectorise a binder variable, along with its attached type, +-- but give the result a new name. +vectBndrNew :: Var -> FastString -> VM VVar +vectBndrNew v fs + = do vty <- vectType (idType v) + vv <- newLocalVVar fs vty + updLEnv (upd vv) + return vv + where + upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv } + + +-- | Vectorise a binder then run a computation with that binder in scope. +vectBndrIn :: Var -> VM a -> VM (VVar, a) +vectBndrIn v p + = localV + $ do vv <- vectBndr v + x <- p + return (vv, x) + + +-- | Vectorise a binder, give it a new name, then run a computation with that binder in scope. +vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a) +vectBndrNewIn v fs p + = localV + $ do vv <- vectBndrNew v fs + x <- p + return (vv, x) + + +-- | Vectorise some binders, then run a computation with them in scope. +vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a) +vectBndrsIn vs p + = localV + $ do vvs <- mapM vectBndr vs + x <- p + return (vvs, x) + + +-- Variables -------------------------------------------------------------------------------------- +-- | Vectorise a variable, producing the vectorised and lifted versions. +vectVar :: Var -> VM VExpr +vectVar v + = do + -- lookup the variable from the environment. + r <- lookupVar v + + case r of + -- If it's been locally bound then we'll already have both versions available. + Local (vv,lv) + -> return (Var vv, Var lv) + + -- To create the lifted version of a global variable we replicate it + -- using the integer context in the VM state for the number of elements. + Global vv + -> do let vexpr = Var vv + lexpr <- liftPD vexpr + return (vexpr, lexpr) + + +-- | Like `vectVar` but also add type applications to the variables. +vectPolyVar :: Var -> [Type] -> VM VExpr +vectPolyVar v tys + = do vtys <- mapM vectType tys + r <- lookupVar v + case r of + Local (vv, lv) + -> liftM2 (,) (polyApply (Var vv) vtys) + (polyApply (Var lv) vtys) + + Global poly + -> do vexpr <- polyApply (Var poly) vtys + lexpr <- liftPD vexpr + return (vexpr, lexpr) + + +-- Literals --------------------------------------------------------------------------------------- +-- | Lifted literals are created by replicating them +-- We use the the integer context in the `VM` state for the number +-- of elements in the output array. +vectLiteral :: Literal -> VM VExpr +vectLiteral lit + = do lexpr <- liftPD (Lit lit) + return (Lit lit, lexpr) + diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index f60ed6f..7aae48c 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -5,6 +5,7 @@ where import VectMonad import VectUtils +import VectVar import VectType import VectCore @@ -28,7 +29,7 @@ import Id import OccName import BasicTypes ( isLoopBreaker ) -import Literal ( Literal, mkMachInt ) +import Literal import TysWiredIn import TysPrim ( intPrimTy ) @@ -221,109 +222,8 @@ tryConvert var vect_var rhs -- ---------------------------------------------------------------------------- --- Bindings - --- | Vectorise a binder variable, along with its attached type. -vectBndr :: Var -> VM VVar -vectBndr v - = do - (vty, lty) <- vectAndLiftType (idType v) - let vv = v `Id.setIdType` vty - lv = v `Id.setIdType` lty - updLEnv (mapTo vv lv) - return (vv, lv) - where - mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) } - - --- | Vectorise a binder variable, along with its attached type, --- but give the result a new name. -vectBndrNew :: Var -> FastString -> VM VVar -vectBndrNew v fs - = do - vty <- vectType (idType v) - vv <- newLocalVVar fs vty - updLEnv (upd vv) - return vv - where - upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv } - - --- | Vectorise a binder then run a computation with that binder in scope. -vectBndrIn :: Var -> VM a -> VM (VVar, a) -vectBndrIn v p - = localV - $ do - vv <- vectBndr v - x <- p - return (vv, x) - - --- | Vectorise a binder, give it a new name, then run a computation with that binder in scope. -vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a) -vectBndrNewIn v fs p - = localV - $ do - vv <- vectBndrNew v fs - x <- p - return (vv, x) - --- | Vectorise some binders, then run a computation with them in scope. -vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a) -vectBndrsIn vs p - = localV - $ do - vvs <- mapM vectBndr vs - x <- p - return (vvs, x) - - --- ---------------------------------------------------------------------------- -- Expressions --- | Vectorise a variable, producing the vectorised and lifted versions. -vectVar :: Var -> VM VExpr -vectVar v - = do - -- lookup the variable from the environment. - r <- lookupVar v - - case r of - -- If it's been locally bound then we'll already have both versions available. - Local (vv,lv) - -> return (Var vv, Var lv) - - -- To create the lifted version of a global variable we replicate it. - Global vv - -> do let vexpr = Var vv - lexpr <- liftPD vexpr - return (vexpr, lexpr) - - --- | Like `vectVar` but also add type applications to the variables. -vectPolyVar :: Var -> [Type] -> VM VExpr -vectPolyVar v tys - = do - vtys <- mapM vectType tys - r <- lookupVar v - case r of - Local (vv, lv) - -> liftM2 (,) (polyApply (Var vv) vtys) - (polyApply (Var lv) vtys) - - Global poly - -> do vexpr <- polyApply (Var poly) vtys - lexpr <- liftPD vexpr - return (vexpr, lexpr) - - --- | Lifted literals are created by replicating them. -vectLiteral :: Literal -> VM VExpr -vectLiteral lit - = do - lexpr <- liftPD (Lit lit) - return (Lit lit, lexpr) - -- | Vectorise a polymorphic expression vectPolyExpr