X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=ecbc7d970057c2882ff9c63db7027312aa8019d2;hb=c1572a8968e1a0fac2c70e0172d5f304d560b2f3;hp=836a0209a089911ef30a00789695fbee256669d1;hpb=bdcefe88baa952422da335cbd743a32db5b06fb6;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 836a020..ecbc7d9 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -2,12 +2,13 @@ module VectMonad (
   Scope(..),
   VM,
 
-  noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
+  noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV,
+  initV,
   liftDs,
   cloneName, cloneId, cloneVar,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
   
-  Builtins(..), sumTyCon, prodTyCon, uarrTy, intPrimArrayTy,
+  Builtins(..), sumTyCon, prodTyCon,
   combinePAVar,
   builtin, builtins,
 
@@ -36,7 +37,8 @@ module VectMonad (
 
 import VectBuiltIn
 
-import HscTypes
+import HscTypes hiding  ( MonadThings(..) )
+import Module           ( PackageId )
 import CoreSyn
 import TyCon
 import DataCon
@@ -174,7 +176,7 @@ emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
                  , local_tyvars   = []
                  , local_tyvar_pa = emptyVarEnv
-                 , local_bind_name  = FSLIT("fn")
+                 , local_bind_name  = fsLit "fn"
                  }
 
 -- FIXME
@@ -228,10 +230,12 @@ orElseV :: VM a -> VM a -> VM a
 orElseV p q = maybe q return =<< tryV p
 
 fixV :: (a -> VM a) -> VM a
-fixV f = VM $ \bi genv lenv -> fixDs $
-               \r -> case r of
-                       Yes _ _ x -> runVM (f x) bi genv lenv
-                       No        -> return No
+fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
+  where
+    -- NOTE: It is essential that we are lazy in r above so do not replace
+    --       calls to this function by an explicit case.
+    unYes (Yes _ _ x) = x
+    unYes No          = panic "VectMonad.fixV: no result"
 
 localV :: VM a -> VM a
 localV p = do
@@ -251,6 +255,9 @@ closedV p = do
 liftDs :: DsM a -> VM a
 liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
 
+liftBuiltinDs :: (Builtins -> DsM a) -> VM a
+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
+
 builtin :: (Builtins -> a) -> VM a
 builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
 
@@ -329,7 +336,7 @@ newLocalVar fs ty
       return $ mkSysLocal fs u ty
 
 newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar FSLIT("ds")
+newDummyVar = newLocalVar (fsLit "ds")
 
 newTyVar :: FastString -> Kind -> VM Var
 newTyVar fs k
@@ -376,10 +383,10 @@ defDataCon dc dc' = updGEnv $ \env ->
   env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
 
 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftDs . primPArray
+lookupPrimPArray = liftBuiltinDs . primPArray
 
 lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftDs . primMethod tycon
+lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
 
 lookupTyConPA :: TyCon -> VM (Maybe Var)
 lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
@@ -473,10 +480,12 @@ lookupFamInst tycon tys
                       (ppr $ mkTyConApp tycon tys)
        }
 
-initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
-initV hsc_env guts info p
+initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
+initV pkg hsc_env guts info p
   = do
-      Just r <- initDs hsc_env (mg_module guts)
+         -- 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
@@ -485,7 +494,7 @@ initV hsc_env guts info p
 
     go =
       do
-        builtins       <- initBuiltins
+        builtins       <- initBuiltins pkg
         builtin_vars   <- initBuiltinVars builtins
         builtin_tycons <- initBuiltinTyCons builtins
         let builtin_datacons = initBuiltinDataCons builtins