X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=c7046d4ba5cd0d4cf7feb13c9cbd5f9b2dbdeffb;hb=7c737416e30137e7053b4bcd0fdd563f07fa43b0;hp=aa8e4f8d298496939b1a2788053f82ad00d027d2;hpb=f64384c40b3db4fddb8fad5463da39464e52ab13;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index aa8e4f8..c7046d4 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,5 +1,14 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module VectType ( vectTyCon, vectType, vectTypeEnv,
-                   PAInstance, buildPADict )
+                  mkRepr, arrShapeTys, arrShapeVars, arrSelector,
+                  PAInstance, buildPADict,
+                  fromVect )
 where
 
 #include "HsVersions.h"
@@ -62,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
@@ -73,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
 
@@ -276,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 {
@@ -355,6 +382,9 @@ replicateShape (IdRepr _) _ _ = return []
 replicateShape (VoidRepr {}) len _ = return [len]
 replicateShape (EnumRepr {}) len _ = return [len]
 
+arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr)
+arrSelector (SumRepr {}) [len, sel, is] = return (len, sel, is)
+
 emptyArrRepr :: Repr -> VM [CoreExpr]
 emptyArrRepr (SumRepr { sum_components = prods })
   = liftM concat $ mapM emptyArrRepr prods
@@ -971,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 ()
+
+