X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=896139fdd5ac0b5609316e51c0a4cf6a8826c306;hb=fe5405d4b97a521e32899f6dc2153c556723ca62;hp=af6665e8be19a2b4262c58515c01676fce5d30ce;hpb=3f00a7a5b697ff97533b051c53b44538f65fd3fd;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index af6665e..896139f 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,11 +1,13 @@
 module VectType ( vectTyCon, vectType, vectTypeEnv,
-                   PAInstance, painstInstance, buildPADict )
+                   PAInstance, buildPADict,
+                   vectDataConWorkers )
 where
 
 #include "HsVersions.h"
 
 import VectMonad
 import VectUtils
+import VectCore
 
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import CoreSyn
@@ -76,13 +78,13 @@ vectType ty = pprPanic "vectType:" (ppr ty)
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
 data PAInstance = PAInstance {
-                    painstInstance  :: Instance
+                    painstDFun      :: Var
                   , painstOrigTyCon :: TyCon
                   , painstVectTyCon :: TyCon
                   , painstArrTyCon  :: TyCon
                   }
 
-vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [PAInstance])
+vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst])
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons
@@ -105,7 +107,7 @@ vectTypeEnv env
                         ++ [ADataCon dc | tc <- all_new_tcs
                                         , dc <- tyConDataCons tc])
 
-      return (new_env, map mkLocalFamInst parr_tcs, pa_insts)
+      return (new_env, map mkLocalFamInst parr_tcs)
   where
     tycons = typeEnvTyCons env
     groups = tyConGroups tycons
@@ -192,6 +194,66 @@ vectDataCon dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
 
+vectDataConWorkers :: PAInstance -> VM [(Var, CoreExpr)]
+vectDataConWorkers (PAInstance { painstOrigTyCon = orig_tc
+                               , painstVectTyCon = vect_tc
+                               , painstArrTyCon  = arr_tc
+                               })
+  = do
+      shape <- tyConShape vect_tc
+      sequence_ (zipWith3 (vectDataConWorker shape vect_tc arr_tc arr_dc)
+                          num_dcs
+                          (inits repr_tys)
+                          (tails repr_tys))
+      takeHoisted
+  where
+    orig_dcs = tyConDataCons orig_tc
+    vect_dcs = tyConDataCons vect_tc
+    [arr_dc] = tyConDataCons arr_tc
+
+    num_dcs  = zip3 orig_dcs vect_dcs [0..]
+    repr_tys = map dataConRepArgTys vect_dcs
+
+vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon
+                  -> (DataCon, DataCon, Int) -> [[Type]] -> [[Type]]
+                  -> VM ()
+vectDataConWorker shape vect_tc arr_tc arr_dc (orig_dc, vect_dc, dc_num) pre (dc_tys : post)
+  = do
+      clo <- closedV
+           . inBind orig_worker
+           . polyAbstract tvs $ \abstract ->
+             liftM (abstract . vectorised)
+           $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift)
+
+      worker <- cloneId mkVectOcc orig_worker (exprType clo)
+      hoistBinding worker clo
+      defGlobalVar orig_worker worker
+      return ()
+  where
+    tvs     = tyConTyVars vect_tc
+    arg_tys = mkTyVarTys tvs
+    res_ty  = mkTyConApp vect_tc arg_tys
+
+    orig_worker = dataConWorkId orig_dc
+
+    mk_vect = return . mkConApp vect_dc $ map Type arg_tys
+    mk_lift = do
+                len     <- newLocalVar FSLIT("n") intPrimTy
+                arr_tys <- mapM mkPArrayType dc_tys
+                args    <- mapM (newLocalVar FSLIT("xs")) arr_tys
+                shapes  <- shapeReplicate shape (Var len) (mkIntLitInt dc_num)
+                
+                empty_pre  <- mapM emptyPA (concat pre)
+                empty_post <- mapM emptyPA (concat post)
+
+                return . mkLams (len : args)
+                       . wrapFamInstBody arr_tc arg_tys
+                       . mkConApp arr_dc
+                       $ map Type arg_tys ++ shapes
+                                          ++ empty_pre
+                                          ++ map Var args
+                                          ++ empty_post
+
 data Shape = Shape {
                shapeReprTys    :: [Type]
              , shapeStrictness :: [StrictnessMark]
@@ -300,26 +362,19 @@ buildPArrayDataCon orig_name vect_tc repr_tc
 buildPAInstance :: TyCon -> TyCon -> TyCon -> VM PAInstance
 buildPAInstance orig_tc vect_tc arr_tc
   = do
-      pa <- builtin paClass
-      let inst_ty = mkForAllTys tvs
-                  . (mkFunTys $ mkPredTys [ClassP pa [ty] | ty <- arg_tys])
-                  $ mkPredTy (ClassP pa [mkTyConApp vect_tc arg_tys])
-
-      dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) inst_ty
+      dfun_ty <- paDFunType vect_tc
+      dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) dfun_ty
 
       return $ PAInstance {
-                 painstInstance  = mkLocalInstance dfun NoOverlap
+                 painstDFun      = dfun
                , painstOrigTyCon = orig_tc
                , painstVectTyCon = vect_tc
                , painstArrTyCon  = arr_tc
                }
-  where
-    tvs = tyConTyVars arr_tc
-    arg_tys = mkTyVarTys tvs
 
 buildPADict :: PAInstance -> VM [(Var, CoreExpr)]
 buildPADict (PAInstance {
-               painstInstance  = inst
+               painstDFun      = dfun
              , painstVectTyCon = vect_tc
              , painstArrTyCon  = arr_tc })
   = polyAbstract (tyConTyVars arr_tc) $ \abstract ->
@@ -328,10 +383,10 @@ buildPADict (PAInstance {
       meth_binds <- mapM (mk_method shape) paMethods
       let meth_exprs = map (Var . fst) meth_binds
 
-      pa_dc <- builtin paDictDataCon
+      pa_dc <- builtin paDataCon
       let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
           body = Let (Rec meth_binds) dict
-      return [(instanceDFunId inst, mkInlineMe $ abstract body)]
+      return [(dfun, mkInlineMe $ abstract body)]
   where
     tvs = tyConTyVars arr_tc
     arg_tys = mkTyVarTys tvs