X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=6bc2f4d656c5ec35d5ec811df6f35d5f58992091;hb=f17c76a4fc51a52ccda154ec9e4990f13f78c8c2;hp=75df2b7738a2d1a71b83205725376bec714184e0;hpb=135a48ab3b1173701cc2192fe3f57ec08f85ce31;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 75df2b7..6bc2f4d 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -22,7 +22,8 @@ module VectMonad (
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,
-  lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
+  lookupTyConPA, defTyConPA, defTyConPAs,
+  lookupTyConPR,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst
@@ -47,6 +48,7 @@ import NameEnv
 import TysPrim       ( intPrimTy )
 import Module
 import IfaceEnv
+import IOEnv         ( ioToIOEnv )
 
 import DsMonad
 import PrelNames
@@ -89,6 +91,9 @@ data GlobalEnv = GlobalEnv {
                   --
                 , global_pa_funs :: NameEnv Var
 
+                  -- Mapping from TyCons to their PR dfuns
+                , global_pr_funs :: NameEnv Var
+
                 -- External package inst-env & home-package inst-env for class
                 -- instances
                 --
@@ -119,19 +124,16 @@ data LocalEnv = LocalEnv {
                  -- Local binding name
                , local_bind_name :: FastString
                }
-              
 
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins
-              -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs bi
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs
   = GlobalEnv {
       global_vars          = mapVarEnv snd $ vectInfoVar info
     , global_exported_vars = emptyVarEnv
-    , global_tycons        = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
-                                           (tyConName funTyCon) (closureTyCon bi)
-                              
+    , global_tycons        = mapNameEnv snd $ vectInfoTyCon info
     , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
     , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
+    , global_pr_funs       = emptyVarEnv
     , global_inst_env      = instEnvs
     , global_fam_inst_env  = famInstEnvs
     , global_bindings      = []
@@ -143,6 +145,18 @@ setFamInstEnv l_fam_inst genv
   where
     (g_fam_inst, _) = global_fam_inst_env genv
 
+extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+extendTyConsEnv ps genv
+  = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+
+extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+extendPAFunsEnv ps genv
+  = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+
+setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPRFunsEnv ps genv
+  = genv { global_pr_funs = mkNameEnv ps }
+
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []
@@ -258,11 +272,6 @@ inBind id p
   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
        p
 
-lookupExternalVar :: Module -> FastString -> VM Var
-lookupExternalVar mod fs
-  = liftDs
-  $ dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
-
 cloneName :: (OccName -> OccName) -> Name -> VM Name
 cloneName mk_occ name = liftM make (liftDs newUnique)
   where
@@ -354,18 +363,11 @@ defTyConPAs ps = updGEnv $ \env ->
   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 
-defTyConBuiltinPAs :: [(Name, Module, FastString)] -> VM ()
-defTyConBuiltinPAs ps
-  = do
-      pas <- zipWithM lookupExternalVar mods fss
-      updGEnv $ \env ->
-        env { global_pa_funs = extendNameEnvList (global_pa_funs env)
-                                                 (zip tcs pas) }
-  where
-    (tcs, mods, fss) = unzip3 ps
-
 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
-lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
+lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+
+lookupTyConPR :: TyCon -> VM (Maybe Var)
+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
 
 defLocalTyVar :: TyVar -> VM ()
 defLocalTyVar tv = updLEnv $ \env ->
@@ -440,25 +442,30 @@ lookupFamInst tycon tys
 initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info p
   = do
-      eps <- hscEPS hsc_env
-      let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
-      let instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
-
       Just r <- initDs hsc_env (mg_module guts)
                                (mg_rdr_env guts)
                                (mg_types guts)
-                               (go instEnvs famInstEnvs)
+                               go
       return r
   where
 
-    go instEnvs famInstEnvs = 
+    go =
       do
-        builtins <- initBuiltins
-        r <- runVM p builtins (initGlobalEnv info
-                                             instEnvs
-                                             famInstEnvs
-                                             builtins)
-                   emptyLocalEnv
+        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)
+            instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+
+        let genv = extendTyConsEnv builtin_tycons
+                 . extendPAFunsEnv builtin_pas
+                 . setPRFunsEnv    builtin_prs
+                 $ initGlobalEnv info instEnvs famInstEnvs
+
+        r <- runVM p builtins genv emptyLocalEnv
         case r of
           Yes genv _ x -> return $ Just (new_info genv, x)
           No           -> return Nothing