X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FMonad%2FBase.hs;fp=compiler%2Fvectorise%2FVectorise%2FMonad%2FBase.hs;h=aa73e25264b52529d395f8b191fe9cbe61d47da6;hp=c2c314faf98dc5ee11ef5181119b5a2659775ef9;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=19d8dcbdaac5dc10e551703b824e8237e7d5f0a1

diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index c2c314f..aa73e25 100644
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/compiler/vectorise/Vectorise/Monad/Base.hs
@@ -13,6 +13,9 @@ module Vectorise.Monad.Base (
 	maybeCantVectorise,
 	maybeCantVectoriseM,
 	
+	-- * Debugging
+	traceVt, dumpOptVt, dumpVt,
+	
 	-- * Control
 	noV,	 traceNoV,
 	ensureV, traceEnsureV,
@@ -22,14 +25,23 @@ module Vectorise.Monad.Base (
 	orElseV,
 	fixV,
 ) where
+
 import Vectorise.Builtins
 import Vectorise.Env
 
 import DsMonad
+import TcRnMonad
+import ErrUtils
 import Outputable
-	
+import DynFlags
+import StaticFlags
+
+import Control.Monad
+import System.IO (stderr)
+
 
 -- The Vectorisation Monad ----------------------------------------------------
+
 -- | Vectorisation can either succeed with new envionment and a value,
 --   or return with failure.
 data VResult a 
@@ -46,6 +58,12 @@ instance Monad VM where
                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
                                         No                -> return No
 
+instance Functor VM where
+  fmap = liftM
+  
+instance MonadIO VM where
+  liftIO = liftDs . liftIO
+
 
 -- Lifting --------------------------------------------------------------------
 -- | Lift a desugaring computation into the vectorisation monad.
@@ -77,6 +95,36 @@ maybeCantVectoriseM s d p
         Just x  -> return x
         Nothing -> cantVectorise s d
 
+
+-- Debugging ------------------------------------------------------------------
+
+-- |Output a trace message if -ddump-vt-trace is active.
+--
+traceVt :: String -> SDoc -> VM () 
+traceVt herald doc
+  | 1 <= opt_TraceLevel = liftDs $
+                            traceOptIf Opt_D_dump_vt_trace $
+                              hang (text herald) 2 doc
+  | otherwise           = return ()
+
+-- |Dump the given program conditionally.
+--
+dumpOptVt :: DynFlag -> String -> SDoc -> VM ()
+dumpOptVt flag header doc 
+  = do { b <- liftDs $ doptM flag
+       ; if b 
+         then dumpVt header doc 
+         else return () 
+       }
+
+-- |Dump the given program unconditionally.
+--
+dumpVt :: String -> SDoc -> VM ()
+dumpVt header doc 
+  = do { unqual <- liftDs mkPrintUnqualifiedDs
+       ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc)
+       }
+
 -- Control --------------------------------------------------------------------
 -- | Return some result saying we've failed.
 noV :: VM a