merge upstream

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

diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 5fcd2ac..73cba88 100644 (file)
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -1,27 +1,26 @@
 
 module Vectorise.Monad (
-       module Vectorise.Monad.Base,
-       module Vectorise.Monad.Naming,
-       module Vectorise.Monad.Local,
-       module Vectorise.Monad.Global,
-       module Vectorise.Monad.InstEnv,
-       initV,
-
-       -- * Builtins
-       liftBuiltinDs,
-       builtin,
-       builtins,
-       
-       -- * Variables
-       lookupVar,
-       maybeCantVectoriseVarM,
-       dumpVar,
-       addGlobalScalar, 
-    deleteGlobalScalar,
+  module Vectorise.Monad.Base,
+  module Vectorise.Monad.Naming,
+  module Vectorise.Monad.Local,
+  module Vectorise.Monad.Global,
+  module Vectorise.Monad.InstEnv,
+  initV,
+
+  -- * Builtins
+  liftBuiltinDs,
+  builtin,
+  builtins,
+  
+  -- * Variables
+  lookupVar,
+  maybeCantVectoriseVarM,
+  dumpVar,
+  addGlobalScalar, 
     
-       -- * Primitives
-       lookupPrimPArray,
-       lookupPrimMethod
+  -- * Primitives
+  lookupPrimPArray,
+  lookupPrimMethod
 ) where
 
 import Vectorise.Monad.Base
@@ -82,6 +81,7 @@ initV hsc_env guts info thing_inside
            ; builtin_pas <- initBuiltinPAs builtins instEnvs
 
                -- construct the initial global environment
+           ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
            ; let genv = extendImportedVarsEnv builtin_vars
                         . extendScalars       builtin_scalars
                         . extendTyConsEnv     builtin_tycons
@@ -92,13 +92,13 @@ initV hsc_env guts info thing_inside
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
  
                -- perform vectorisation
-           ; r <- runVM thing_inside builtins genv emptyLocalEnv
+           ; 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
+    new_info genv = modVectInfo genv (mg_types guts) info
 
     selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
 
@@ -120,7 +120,7 @@ builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
 
 -- Var ------------------------------------------------------------------------
 -- | Lookup the vectorised and\/or lifted versions of this variable.
---     If it's in the global environment we get the vectorised version.
+--  If it's in the global environment we get the vectorised version.
 --      If it's in the local environment we get both the vectorised and lifted version.
 lookupVar :: Var -> VM (Scope Var (Var, Var))
 lookupVar v
@@ -140,29 +140,24 @@ maybeCantVectoriseVarM v p
 
 dumpVar :: Var -> a
 dumpVar var
-       | Just _                <- isClassOpId_maybe var
-       = cantVectorise "ClassOpId not vectorised:" (ppr var)
+  | Just _    <- isClassOpId_maybe var
+  = cantVectorise "ClassOpId not vectorised:" (ppr var)
 
-       | otherwise
-       = cantVectorise "Variable not vectorised:" (ppr var)
+  | otherwise
+  = cantVectorise "Variable not vectorised:" (ppr var)
 
 
--- local scalars --------------------------------------------------------------
+-- Global 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}
-     }
+       ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
+       }
      
      
 -- Primitives -----------------------------------------------------------------
+
 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
 lookupPrimPArray = liftBuiltinDs . primPArray