Added a VECTORISE pragma

[ghc-hetmet.git] / compiler / vectorise / Vectorise / Monad.hs

diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 2597430..5fcd2ac 100644 (file)
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -22,8 +22,8 @@ module Vectorise.Monad (
        -- * Primitives
        lookupPrimPArray,
        lookupPrimMethod
-)
-where
+) where
+
 import Vectorise.Monad.Base
 import Vectorise.Monad.Naming
 import Vectorise.Monad.Local
@@ -32,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 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.
@@ -139,17 +146,20 @@ dumpVar var
        | otherwise
        = cantVectorise "Variable not vectorised:" (ppr var)
 
--- local scalars --------------------------------------------------------------
--- | Check if the variable is a locally defined scalar function
 
+-- local scalars --------------------------------------------------------------
 
 addGlobalScalar :: Var -> VM ()
 addGlobalScalar var 
-  = updGEnv $ \env -> pprTrace "addGLobalScalar" (ppr var) env{global_scalars = extendVarSet (global_scalars env) var}
+  = do { traceVt "addGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var}
+     }
      
 deleteGlobalScalar :: Var -> VM ()
 deleteGlobalScalar var 
-  = updGEnv $ \env -> pprTrace "deleteGLobalScalar" (ppr var) env{global_scalars = delVarSet (global_scalars env) var}
+  = do { traceVt "deleteGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var}
+     }
      
      
 -- Primitives -----------------------------------------------------------------