X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=912eacfad7eb035a902c597f000a5aaf5ce59120;hb=8b3ebc412fc61eb1f2a6129190d85fcdd851235e;hp=781131e66ca20f1882fd7b403b6e019d44ccbd7a;hpb=ad7f0a6770d87600130fe4230d4546b340980eb7;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 781131e..912eacf 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -7,7 +7,8 @@
 
 module VectType ( vectTyCon, vectType, vectTypeEnv,
                   mkRepr, arrShapeTys, arrShapeVars, arrSelector,
-                  PAInstance, buildPADict )
+                  PAInstance, buildPADict,
+                  fromVect )
 where
 
 #include "HsVersions.h"
@@ -982,3 +983,40 @@ tyConsOfType other             = pprPanic "ClosureConv.tyConsOfType" $ ppr other
 tyConsOfTypes :: [Type] -> UniqSet TyCon
 tyConsOfTypes = unionManyUniqSets . map tyConsOfType
 
+
+-- ----------------------------------------------------------------------------
+-- Conversions
+
+fromVect :: Type -> CoreExpr -> VM CoreExpr
+fromVect ty expr | Just ty' <- coreView ty = fromVect ty' expr
+fromVect (FunTy arg_ty res_ty) expr
+  = do
+      arg     <- newLocalVar FSLIT("x") arg_ty
+      varg    <- toVect arg_ty (Var arg)
+      varg_ty <- vectType arg_ty
+      vres_ty <- vectType res_ty
+      apply   <- builtin applyClosureVar
+      body    <- fromVect res_ty
+               $ Var apply `mkTyApps` [arg_ty, res_ty] `mkApps` [expr, Var arg]
+      return $ Lam arg body
+fromVect ty expr
+  = identityConv ty >> return expr
+
+toVect :: Type -> CoreExpr -> VM CoreExpr
+toVect ty expr = identityConv ty >> return expr
+
+identityConv :: Type -> VM ()
+identityConv ty | Just ty' <- coreView ty = identityConv ty'
+identityConv (TyConApp tycon tys)
+  = do
+      mapM_ identityConv tys
+      identityConvTyCon tycon
+identityConv ty = noV
+
+identityConvTyCon :: TyCon -> VM ()
+identityConvTyCon tc
+  | isBoxedTupleTyCon tc = return ()
+  | isUnLiftedTyCon tc   = return ()
+  | otherwise            = maybeV (lookupTyCon tc) >> return ()
+
+