Trim redundant import

[ghc-hetmet.git] / compiler / vectorise / VectMonad.hs

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 1299683..56f5b8f 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -2,7 +2,8 @@ module VectMonad (
   Scope(..),
   VM,
 
-  noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
+  noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV,
+  initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
   liftDs,
   cloneName, cloneId, cloneVar,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
@@ -36,8 +37,8 @@ module VectMonad (
 
 import VectBuiltIn
 
-import HscTypes
-import Module        ( dphSeqPackageId )
+import HscTypes hiding  ( MonadThings(..) )
+import Module           ( PackageId )
 import CoreSyn
 import TyCon
 import DataCon
@@ -205,6 +206,25 @@ instance Monad VM where
                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
                                         No                -> return No
 
+
+cantVectorise :: String -> SDoc -> a
+cantVectorise s d = pgmError
+                  . showSDocDump
+                  $ vcat [text "*** Vectorisation error ***",
+                          nest 4 $ sep [text s, nest 4 d]]
+
+maybeCantVectorise :: String -> SDoc -> Maybe a -> a
+maybeCantVectorise s d Nothing  = cantVectorise s d
+maybeCantVectorise _ _ (Just x) = x
+
+maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
+maybeCantVectoriseM s d p
+  = do
+      r <- p
+      case r of
+        Just x  -> return x
+        Nothing -> cantVectorise s d
+
 noV :: VM a
 noV = VM $ \_ _ _ -> return No
 
@@ -335,7 +355,7 @@ newLocalVar fs ty
       return $ mkSysLocal fs u ty
 
 newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar (fsLit "ds")
+newDummyVar = newLocalVar (fsLit "vv")
 
 newTyVar :: FastString -> Kind -> VM Var
 newTyVar fs k
@@ -359,8 +379,8 @@ lookupVar v
       case r of
         Just e  -> return (Local e)
         Nothing -> liftM Global
-                 $  traceMaybeV "lookupVar" (ppr v)
-                                (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
+                . maybeCantVectoriseM "Variable not vectorised:" (ppr v)
+                . readGEnv $ \env -> lookupVarEnv (global_vars env) v
 
 lookupTyCon :: TyCon -> VM (Maybe TyCon)
 lookupTyCon tc
@@ -479,10 +499,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
@@ -491,7 +513,7 @@ initV hsc_env guts info p
 
     go =
       do
-        builtins       <- initBuiltins dphSeqPackageId
+        builtins       <- initBuiltins pkg
         builtin_vars   <- initBuiltinVars builtins
         builtin_tycons <- initBuiltinTyCons builtins
         let builtin_datacons = initBuiltinDataCons builtins