X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FMonad.hs;h=5fcd2ac0883f6431740ff0e96e63b4b4440612a2;hp=6ead3d07fc4739a47988f6aacabd09eca1fe8886;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=94bf0d3604ff0d2ecab246924af712bdd1c29a40

diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 6ead3d0..5fcd2ac 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -16,12 +16,14 @@ module Vectorise.Monad (
 	lookupVar,
 	maybeCantVectoriseVarM,
 	dumpVar,
-
+	addGlobalScalar, 
+    deleteGlobalScalar,
+    
 	-- * Primitives
 	lookupPrimPArray,
 	lookupPrimMethod
-)
-where
+) where
+
 import Vectorise.Monad.Base
 import Vectorise.Monad.Naming
 import Vectorise.Monad.Local
@@ -30,68 +32,75 @@ import Vectorise.Monad.InstEnv
 import Vectorise.Builtins
 import Vectorise.Env
 
-import HscTypes hiding  ( MonadThings(..) )
+import HscTypes hiding ( MonadThings(..) )
+import DynFlags
 import MonadUtils (liftIO)
-import Module
 import TyCon
 import Var
 import VarEnv
 import Id
 import DsMonad
 import Outputable
-import Control.Monad
+import FastString
 
+import Control.Monad
+import VarSet
 
 -- | Run a vectorisation computation.
-initV	:: PackageId
-	-> HscEnv
-	-> ModGuts
-	-> VectInfo
-	-> VM a
-	-> IO (Maybe (VectInfo, a))
-
-initV pkg hsc_env guts info p
-  = do
-         -- XXX: ignores error messages and warnings, check that this is
-         -- indeed ok (the use of "Just r" suggests so)
-      (_,Just r) <- initDs hsc_env (mg_module guts)
-                               (mg_rdr_env guts)
-                               (mg_types guts)
-                               go
-      return r
+--
+initV :: HscEnv
+      -> ModGuts
+      -> VectInfo
+      -> VM a
+      -> IO (Maybe (VectInfo, a))
+initV hsc_env guts info thing_inside
+  = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go
+       ; return r
+       }
   where
     go 
-     = do
-        builtins	<- initBuiltins pkg
-        builtin_vars	<- initBuiltinVars builtins
-        builtin_tycons	<- initBuiltinTyCons builtins
-        let builtin_datacons = initBuiltinDataCons builtins
-        builtin_boxed	<- initBuiltinBoxedTyCons builtins
-        builtin_scalars	<- initBuiltinScalars builtins
-
-        eps <- liftIO $ hscEPS hsc_env
-        let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
-            instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
-
-        builtin_prs	<- initBuiltinPRs builtins instEnvs
-        builtin_pas	<- initBuiltinPAs builtins instEnvs
-
-        let genv = extendImportedVarsEnv builtin_vars
-                 . extendScalars builtin_scalars
-                 . extendTyConsEnv builtin_tycons
-                 . extendDataConsEnv builtin_datacons
-                 . extendPAFunsEnv builtin_pas
-                 . setPRFunsEnv    builtin_prs
-                 . setBoxedTyConsEnv builtin_boxed
-                 $ 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
+      = do {   -- pick a DPH backend
+           ; dflags <- getDOptsDs
+           ; case dphPackageMaybe dflags of
+               Nothing  -> failWithDs $ ptext selectBackendErr
+               Just pkg -> do {
+
+               -- set up tables of builtin entities
+           ; let compilingDPH = dphBackend dflags == DPHThis  -- FIXME: temporary kludge support
+           ; builtins        <- initBuiltins pkg
+           ; builtin_vars    <- initBuiltinVars compilingDPH builtins
+           ; builtin_tycons  <- initBuiltinTyCons builtins
+           ; let builtin_datacons = initBuiltinDataCons builtins
+           ; builtin_boxed   <- initBuiltinBoxedTyCons builtins
+           ; builtin_scalars <- initBuiltinScalars compilingDPH builtins
+
+               -- set up class and type family envrionments
+           ; eps <- liftIO $ hscEPS hsc_env
+           ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+                 instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+           ; builtin_prs <- initBuiltinPRs builtins instEnvs
+           ; builtin_pas <- initBuiltinPAs builtins instEnvs
+
+               -- construct the initial global environment
+           ; let genv = extendImportedVarsEnv builtin_vars
+                        . extendScalars       builtin_scalars
+                        . extendTyConsEnv     builtin_tycons
+                        . extendDataConsEnv   builtin_datacons
+                        . extendPAFunsEnv     builtin_pas
+                        . setPRFunsEnv        builtin_prs
+                        . setBoxedTyConsEnv   builtin_boxed
+                        $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
+ 
+               -- perform vectorisation
+           ; r <- runVM thing_inside builtins genv emptyLocalEnv
+           ; case r of
+               Yes genv _ x -> return $ Just (new_info genv, x)
+               No           -> return Nothing
+           } }
 
     new_info genv = updVectInfo genv (mg_types guts) info
 
+    selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
 
 -- Builtins -------------------------------------------------------------------
 -- | Lift a desugaring computation using the `Builtins` into the vectorisation monad.
@@ -138,6 +147,21 @@ dumpVar var
 	= cantVectorise "Variable not vectorised:" (ppr var)
 
 
+-- local scalars --------------------------------------------------------------
+
+addGlobalScalar :: Var -> VM ()
+addGlobalScalar var 
+  = do { traceVt "addGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var}
+     }
+     
+deleteGlobalScalar :: Var -> VM ()
+deleteGlobalScalar var 
+  = do { traceVt "deleteGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var}
+     }
+     
+     
 -- Primitives -----------------------------------------------------------------
 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
 lookupPrimPArray = liftBuiltinDs . primPArray