From 097ce0211ba8fc7aef8cd7fefc33f21f92e559ea Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Thu, 23 Aug 2007 01:53:51 +0000
Subject: [PATCH] Initialise PR dictionaries in vectorisation monad

---
 compiler/vectorise/VectBuiltIn.hs |   45 ++++++++++++++++++++++++++-----------
 compiler/vectorise/VectMonad.hs   |    2 ++
 2 files changed, 34 insertions(+), 13 deletions(-)

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 7a96e25..e6c65ac 100644
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -1,6 +1,6 @@
 module VectBuiltIn (
   Builtins(..),
-  initBuiltins, initBuiltinTyCons, initBuiltinPAs
+  initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
 ) where
 
 #include "HsVersions.h"
@@ -124,32 +124,51 @@ initBuiltinTyCons
 builtinTyCons :: [(Name, DsM TyCon)]
 builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
 
-initBuiltinPAs :: DsM [(Name, Var)]
-initBuiltinPAs
+initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)]
+initBuiltinDicts ps
   = do
-      pas <- zipWithM lookupExternalVar mods fss
-      return $ zip tcs pas
+      dicts <- zipWithM lookupExternalVar mods fss
+      return $ zip tcs dicts
   where
-    (tcs, mods, fss) = unzip3 builtinPAs
+    (tcs, mods, fss) = unzip3 ps
+
+initBuiltinPAs = initBuiltinDicts 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)
 
-    temporary name fs = (name, nDP_INSTANCES, fs)
-
     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)
 
+unitTyConName = tyConName unitTyCon
+
diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 11f7b53..6bc2f4d 100644
--- 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
+        builtin_prs    <- initBuiltinPRs
 
         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
+                 . setPRFunsEnv    builtin_prs
                  $ initGlobalEnv info instEnvs famInstEnvs
 
         r <- runVM p builtins genv emptyLocalEnv
-- 
1.7.10.4