From 11ecc3de8d4aaea7bfb7ab41c862e77964bee557 Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Tue, 7 Aug 2007 06:05:53 +0000
Subject: [PATCH] Change DataCon worker vectorisation to use PA records

---
 compiler/vectorise/VectType.hs  |   19 ++++++++-----------
 compiler/vectorise/Vectorise.hs |    5 ++---
 2 files changed, 10 insertions(+), 14 deletions(-)

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 3e6fa2d..b2e1518 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,6 +1,5 @@
 module VectType ( vectTyCon, vectType, vectTypeEnv,
-                   PAInstance, buildPADict,
-                   vectDataConWorkers )
+                   PAInstance, buildPADict )
 where
 
 #include "HsVersions.h"
@@ -37,7 +36,7 @@ import Digraph           ( SCC(..), stronglyConnComp )
 import Outputable
 
 import Control.Monad  ( liftM, liftM2, zipWithM, zipWithM_ )
-import Data.List      ( inits, tails )
+import Data.List      ( inits, tails, zipWith4 )
 
 -- ----------------------------------------------------------------------------
 -- Types
@@ -84,7 +83,7 @@ data PAInstance = PAInstance {
                   , painstArrTyCon  :: TyCon
                   }
 
-vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst])
+vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons
@@ -100,6 +99,7 @@ vectTypeEnv env
       parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
       dfuns    <- mapM mkPADFun vect_tcs
       defTyConPAs (zip vect_tcs dfuns)
+      binds    <- sequence (zipWith4 buildTyConBindings orig_tcs vect_tcs parr_tcs dfuns)
       
       let all_new_tcs = new_tcs ++ parr_tcs
 
@@ -108,7 +108,7 @@ vectTypeEnv env
                         ++ [ADataCon dc | tc <- all_new_tcs
                                         , dc <- tyConDataCons tc])
 
-      return (new_env, map mkLocalFamInst parr_tcs)
+      return (new_env, map mkLocalFamInst parr_tcs, concat binds)
   where
     tycons = typeEnvTyCons env
     groups = tyConGroups tycons
@@ -303,12 +303,9 @@ tyConShape vect_tc
                                                e <- replicatePA len n
                                                return [e]
                }
-        
-vectDataConWorkers :: PAInstance -> VM [(Var, CoreExpr)]
-vectDataConWorkers (PAInstance { painstOrigTyCon = orig_tc
-                               , painstVectTyCon = vect_tc
-                               , painstArrTyCon  = arr_tc
-                               })
+
+buildTyConBindings :: TyCon -> TyCon -> TyCon -> Var -> VM [(Var, CoreExpr)]
+buildTyConBindings orig_tc vect_tc arr_tc dfun
   = do
       shape <- tyConShape vect_tc
       sequence_ (zipWith3 (vectDataConWorker shape vect_tc arr_tc arr_dc)
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 4116446..07293be 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -80,7 +80,7 @@ vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
       defTyConRdrPAs builtin_PAs
-      (types', fam_insts) <- vectTypeEnv (mg_types guts)
+      (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
       
       let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
       updGEnv (setFamInstEnv fam_inst_env')
@@ -89,8 +89,7 @@ vectModule guts
       -- workers <- mapM vectDataConWorkers pa_insts
       binds'  <- mapM vectTopBind (mg_binds guts)
       return $ guts { mg_types        = types'
-                    , mg_binds        = -- Rec (concat workers ++ concat dicts) :
-                                        binds'
+                    , mg_binds        = Rec tc_binds : binds'
                     , mg_fam_inst_env = fam_inst_env'
                     , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
                     }
-- 
1.7.10.4