Initialise PR dictionaries in vectorisation monad

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 7a96e25..e6c65ac 100644 (file)
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,6 +1,6 @@
 module VectBuiltIn (
   Builtins(..),
 module VectBuiltIn (
   Builtins(..),

-  initBuiltins, initBuiltinTyCons, initBuiltinPAs
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs

 ) where
 
 #include "HsVersions.h"
 ) where
 
 #include "HsVersions.h"

@@ -124,32 +124,51 @@ initBuiltinTyCons
 builtinTyCons :: [(Name, DsM TyCon)]
 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
 
 builtinTyCons :: [(Name, DsM TyCon)]
 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
 

-initBuiltinPAs :: DsM [(Name, Var)]
-initBuiltinPAs
+initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
+initBuiltinDicts ps

   = do
   = do

-      pas <- zipWithM lookupExternalVar mods fss
-      return $ zip tcs pas
+      dicts <- zipWithM lookupExternalVar mods fss
+      return $ zip tcs dicts

   where
   where

-    (tcs, mods, fss) = unzip3 builtinPAs
+    (tcs, mods, fss) = unzip3 ps
+
+initBuiltinPAs = initBuiltinDicts builtinPAs

 
 builtinPAs :: [(Name, Module, FastString)]
 builtinPAs = [
 
 builtinPAs :: [(Name, Module, FastString)]
 builtinPAs = [

-               mk closureTyConName      nDP_CLOSURE FSLIT("dPA_Clo")
-             , mk (tyConName unitTyCon) nDP_PARRAY  FSLIT("dPA_Unit")
+               mk closureTyConName  nDP_CLOSURE   FSLIT("dPA_Clo")
+             , mk unitTyConName     nDP_PARRAY    FSLIT("dPA_Unit")

 
 

-             , temporary intTyConName FSLIT("dPA_Int")
+             , mk intTyConName      nDP_INSTANCES FSLIT("dPA_Int")

              ]
              ++ tups
   where
     mk name mod fs = (name, mod, fs)
 
              ]
              ++ tups
   where
     mk name mod fs = (name, mod, fs)
 

-    temporary name fs = (name, nDP_INSTANCES, fs)
-

     tups = map mk_tup [2..3]
     tups = map mk_tup [2..3]

-    mk_tup n = temporary (tyConName $ tupleTyCon Boxed n)
-                         (mkFastString $ "dPA_" ++ show n)
+    mk_tup n = mk (tyConName $ tupleTyCon Boxed n)
+                  nDP_INSTANCES
+                  (mkFastString $ "dPA_" ++ show n)
+
+initBuiltinPRs = initBuiltinDicts builtinPRs
+
+builtinPRs :: [(Name, Module, FastString)]
+builtinPRs = [
+               mk (tyConName unitTyCon) nDP_PARRAY    FSLIT("dPR_Unit")
+             , mk ndpCrossTyConName     nDP_PARRAY    FSLIT("dPR_Cross")
+             , mk ndpPlusTyConName      nDP_PARRAY    FSLIT("dPR_Plus")
+             , mk embedTyConName        nDP_PARRAY    FSLIT("dPR_Embed")
+             , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
+
+               -- temporary
+             , mk intTyConName          nDP_INSTANCES FSLIT("dPR_Int")
+             ]
+  where
+    mk name mod fs = (name, mod, fs)

 
 lookupExternalVar :: Module -> FastString -> DsM Var
 lookupExternalVar mod fs
   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 
 
 lookupExternalVar :: Module -> FastString -> DsM Var
 lookupExternalVar mod fs
   = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
 

+unitTyConName = tyConName unitTyCon
+

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 11f7b53..6bc2f4d 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -454,6 +454,7 @@ initV hsc_env guts info p
         builtins       <- initBuiltins
         builtin_tycons <- initBuiltinTyCons
         builtin_pas    <- initBuiltinPAs
         builtins       <- initBuiltins
         builtin_tycons <- initBuiltinTyCons
         builtin_pas    <- initBuiltinPAs

+        builtin_prs    <- initBuiltinPRs

 
         eps <- ioToIOEnv $ hscEPS hsc_env
         let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
 
         eps <- ioToIOEnv $ hscEPS hsc_env
         let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)

@@ -461,6 +462,7 @@ initV hsc_env guts info p
 
         let genv = extendTyConsEnv builtin_tycons
                  . extendPAFunsEnv builtin_pas
 
         let genv = extendTyConsEnv builtin_tycons
                  . extendPAFunsEnv builtin_pas

+                 . setPRFunsEnv    builtin_prs

                  $ initGlobalEnv info instEnvs famInstEnvs
 
         r <- runVM p builtins genv emptyLocalEnv
                  $ initGlobalEnv info instEnvs famInstEnvs
 
         r <- runVM p builtins genv emptyLocalEnv