X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=6cb1679403b1a63504babf5beb3bead7873ffc5c;hp=b7e4b894e260835d808733fa6c1ee1569165e751;hb=21d9b432b676af304dff8d7f4e1e31e1678bcae3;hpb=fe5405d4b97a521e32899f6dc2153c556723ca62

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index b7e4b89..6cb1679 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -2,7 +2,8 @@ module VectMonad (
   Scope(..),
   VM,
 
-  noV, tryV, maybeV, orElseV, fixV, localV, closedV, initV,
+  noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
+  liftDs,
   cloneName, cloneId,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
   
@@ -21,7 +22,7 @@ module VectMonad (
   lookupVar, defGlobalVar,
   lookupTyCon, defTyCon,
   lookupDataCon, defDataCon,
-  lookupTyConPA, defTyConPA, defTyConRdrPAs,
+  lookupTyConPA, defTyConPA, defTyConPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst
@@ -29,11 +30,14 @@ module VectMonad (
 
 #include "HsVersions.h"
 
+import VectBuiltIn
+
 import HscTypes
 import CoreSyn
 import TyCon
 import DataCon
 import Type
+import Class
 import Var
 import VarEnv
 import Id
@@ -41,7 +45,8 @@ import OccName
 import Name
 import NameEnv
 import TysPrim       ( intPrimTy )
-import RdrName
+import Module
+import IfaceEnv
 
 import DsMonad
 import PrelNames
@@ -54,62 +59,13 @@ import Outputable
 import FastString
 import SrcLoc        ( noSrcSpan )
 
-import Control.Monad ( liftM )
+import Control.Monad ( liftM, zipWithM )
 
 data Scope a b = Global a | Local b
 
 -- ----------------------------------------------------------------------------
 -- Vectorisation monad
 
-data Builtins = Builtins {
-                  parrayTyCon      :: TyCon
-                , paTyCon          :: TyCon
-                , paDataCon        :: DataCon
-                , closureTyCon     :: TyCon
-                , mkClosureVar     :: Var
-                , applyClosureVar  :: Var
-                , mkClosurePVar    :: Var
-                , applyClosurePVar :: Var
-                , lengthPAVar      :: Var
-                , replicatePAVar   :: Var
-                , emptyPAVar       :: Var
-                , liftingContext   :: Var
-                }
-
-initBuiltins :: DsM Builtins
-initBuiltins
-  = do
-      parrayTyCon  <- dsLookupTyCon parrayTyConName
-      paTyCon      <- dsLookupTyCon paTyConName
-      let paDataCon = case tyConDataCons paTyCon of [dc] -> dc
-      closureTyCon <- dsLookupTyCon closureTyConName
-
-      mkClosureVar     <- dsLookupGlobalId mkClosureName
-      applyClosureVar  <- dsLookupGlobalId applyClosureName
-      mkClosurePVar    <- dsLookupGlobalId mkClosurePName
-      applyClosurePVar <- dsLookupGlobalId applyClosurePName
-      lengthPAVar      <- dsLookupGlobalId lengthPAName
-      replicatePAVar   <- dsLookupGlobalId replicatePAName
-      emptyPAVar       <- dsLookupGlobalId emptyPAName
-
-      liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
-                              newUnique
-
-      return $ Builtins {
-                 parrayTyCon      = parrayTyCon
-               , paTyCon          = paTyCon
-               , paDataCon        = paDataCon
-               , closureTyCon     = closureTyCon
-               , mkClosureVar     = mkClosureVar
-               , applyClosureVar  = applyClosureVar
-               , mkClosurePVar    = mkClosurePVar
-               , applyClosurePVar = applyClosurePVar
-               , lengthPAVar      = lengthPAVar
-               , replicatePAVar   = replicatePAVar
-               , emptyPAVar       = emptyPAVar
-               , liftingContext   = liftingContext
-               }
-
 data GlobalEnv = GlobalEnv {
                   -- Mapping from global variables to their vectorised versions.
                   -- 
@@ -145,10 +101,6 @@ data GlobalEnv = GlobalEnv {
 
                 -- Hoisted bindings
                 , global_bindings :: [(Var, CoreExpr)]
-
-                  -- Global Rdr environment (from ModGuts)
-                  --
-                , global_rdr_env :: GlobalRdrEnv
                 }
 
 data LocalEnv = LocalEnv {
@@ -167,23 +119,18 @@ data LocalEnv = LocalEnv {
                  -- Local binding name
                , local_bind_name :: FastString
                }
-              
 
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalRdrEnv
-              -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs bi rdr_env
+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_inst_env      = instEnvs
     , global_fam_inst_env  = famInstEnvs
     , global_bindings      = []
-    , global_rdr_env       = rdr_env
     }
 
 setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
@@ -192,6 +139,14 @@ 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 }
+
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []
@@ -307,21 +262,6 @@ inBind id p
   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
        p
 
-lookupRdrName :: RdrName -> VM Name
-lookupRdrName rdr_name
-  = do
-      rdr_env <- readGEnv global_rdr_env
-      case lookupGRE_RdrName rdr_name rdr_env of
-        [gre] -> return (gre_name gre)
-        []    -> pprPanic "VectMonad.lookupRdrName: not found" (ppr rdr_name)
-        _     -> pprPanic "VectMonad.lookupRdrName: ambiguous" (ppr rdr_name)
-
-lookupRdrVar :: RdrName -> VM Var
-lookupRdrVar rdr_name
-  = do
-      name <- lookupRdrName rdr_name
-      liftDs (dsLookupGlobalId name)
-
 cloneName :: (OccName -> OccName) -> Name -> VM Name
 cloneName mk_occ name = liftM make (liftDs newUnique)
   where
@@ -408,15 +348,10 @@ defTyConPA :: TyCon -> Var -> VM ()
 defTyConPA tc pa = updGEnv $ \env ->
   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 
-defTyConRdrPAs :: [(Name, RdrName)] -> VM ()
-defTyConRdrPAs ps
-  = do
-      pas <- mapM lookupRdrVar rdr_names
-      updGEnv $ \env ->
-        env { global_pa_funs = extendNameEnvList (global_pa_funs env)
-                                                 (zip tcs pas) }
-  where
-    (tcs, rdr_names) = unzip ps
+defTyConPAs :: [(TyCon, Var)] -> VM ()
+defTyConPAs ps = updGEnv $ \env ->
+  env { global_pa_funs = extendNameEnvList (global_pa_funs env)
+                                           [(tyConName tc, pa) | (tc, pa) <- ps] }
 
 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
@@ -508,12 +443,14 @@ initV hsc_env guts info p
     go instEnvs famInstEnvs = 
       do
         builtins <- initBuiltins
-        r <- runVM p builtins (initGlobalEnv info
-                                             instEnvs
-                                             famInstEnvs
-                                             builtins
-                                             (mg_rdr_env guts))
-                   emptyLocalEnv
+        builtin_tycons <- initBuiltinTyCons
+        builtin_pas    <- initBuiltinPAs
+
+        let genv = extendTyConsEnv builtin_tycons
+                 . extendPAFunsEnv builtin_pas
+                 $ 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