Incomplete support for boxing during vectorisation

[ghc-hetmet.git] / compiler / vectorise / VectType.hs

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 781131e..c7046d4 100644 (file)
--- 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"
@@ -70,7 +71,7 @@ vectType (TyVarTy tv) = return $ TyVarTy tv
 vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
 vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
 vectType (FunTy ty1 ty2)   = liftM2 TyConApp (builtin closureTyCon)
-                                             (mapM vectType [ty1,ty2])
+                                             (mapM vectAndBoxType [ty1,ty2])
 vectType ty@(ForAllTy _ _)
   = do
       mdicts   <- mapM paDictArgType tyvars
@@ -81,6 +82,23 @@ vectType ty@(ForAllTy _ _)
 
 vectType ty = pprPanic "vectType:" (ppr ty)
 
+vectAndBoxType :: Type -> VM Type
+vectAndBoxType ty = vectType ty >>= boxType
+
+-- ----------------------------------------------------------------------------
+-- Boxing
+
+boxType :: Type -> VM Type
+boxType ty
+  | Just (tycon, []) <- splitTyConApp_maybe ty
+  , isUnLiftedTyCon tycon
+  = do
+      r <- lookupBoxedTyCon tycon
+      case r of
+        Just tycon' -> return $ mkTyConApp tycon' []
+        Nothing     -> return ty
+boxType ty = return ty
+
 -- ----------------------------------------------------------------------------
 -- Type definitions
 
@@ -284,7 +302,8 @@ boxedProductRepr tys
       tycon <- builtin (prodTyCon arity)
       let [data_con] = tyConDataCons tycon
 
-      (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys
+      tys' <- mapM boxType tys
+      (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys'
       let [arr_data_con] = tyConDataCons arr_tycon
 
       return $ ProdRepr {
@@ -982,3 +1001,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 ()
+
+