Associate vectorised tycons with their PA dfuns

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index b7e4b89..6838338 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -21,7 +21,7 @@ module VectMonad (
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,
-  lookupTyConPA, defTyConPA, defTyConRdrPAs,
+  lookupTyConPA, defTyConPA, defTyConPAs, defTyConRdrPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst
@@ -408,6 +408,11 @@ defTyConPA :: TyCon -> Var -> VM ()
 defTyConPA tc pa = updGEnv $ \env ->
   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 
+defTyConPAs :: [(TyCon, Var)] -> VM ()
+defTyConPAs ps = updGEnv $ \env ->
+  env { global_pa_funs = extendNameEnvList (global_pa_funs env)
+                                           [(tyConName tc, pa) | (tc, pa) <- ps] }
+
 defTyConRdrPAs :: [(Name, RdrName)] -> VM ()
 defTyConRdrPAs ps
   = do

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 896139f..871779a 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -98,7 +98,9 @@ vectTypeEnv env
           vect_tcs  = keep_tcs ++ new_tcs
 
       parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
-      pa_insts <- sequence $ zipWith3 buildPAInstance orig_tcs vect_tcs parr_tcs
+      dfuns    <- mapM mkPADFun vect_tcs
+      defTyConPAs (zip vect_tcs dfuns)
+      -- pa_insts <- sequence $ zipWith3 buildPAInstance orig_tcs vect_tcs parr_tcs
       
       let all_new_tcs = new_tcs ++ parr_tcs
 
@@ -359,6 +361,10 @@ buildPArrayDataCon orig_name vect_tc repr_tc
     types = [ty | dc <- tyConDataCons vect_tc
                 , ty <- dataConRepArgTys dc]
 
+mkPADFun :: TyCon -> VM Var
+mkPADFun vect_tc
+  = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
+
 buildPAInstance :: TyCon -> TyCon -> TyCon -> VM PAInstance
 buildPAInstance orig_tc vect_tc arr_tc
   = do