X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=9eef502e1a3c54b3e42f07d7c4ecd49b263fd858;hb=367e603d0136436e783ff9ed610809bf87376262;hp=a231103ec8a4edc85aeb292727fb922c17a1ca5d;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;p=ghc-hetmet.git

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index a231103..9eef502 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -22,8 +22,11 @@ module CoreMonad (
     liftIO1, liftIO2, liftIO3, liftIO4,
     
     -- ** Dealing with annotations
-    findAnnotations, addAnnotation,
+    findAnnotations, deserializeAnnotations, addAnnotation,
     
+    -- ** Debug output
+    endPass, endPassIf, endIteration,
+
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
     fatalErrorMsg, fatalErrorMsgS, 
@@ -39,6 +42,10 @@ module CoreMonad (
 #ifdef GHCI
 import Name( Name )
 #endif
+import CoreSyn
+import PprCore
+import CoreUtils
+import CoreLint		( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes
 import Module           ( Module )
@@ -54,9 +61,11 @@ import TcEnv            ( tcLookupGlobal )
 import TcRnMonad        ( TcM, initTc )
 
 import Outputable
+import FastString
 import qualified ErrUtils as Err
 import Maybes
 import UniqSupply
+import LazyUniqFM       ( UniqFM )
 
 import Data.Dynamic
 import Data.IORef
@@ -71,7 +80,54 @@ import qualified Language.Haskell.TH as TH
 #endif
 \end{code}
 
-\subsection{Monad and carried data structure definitions}
+%************************************************************************
+%*									*
+                       Debug output
+%*									*
+%************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a conveneint place.  place for them.  They print out
+stuff before and after core passes, and do Core Lint when necessary.
+
+\begin{code}
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPass = dumpAndLint Err.dumpIfSet_core
+
+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+
+-- Same as endPass but doesn't dump Core even with -dverbose-core2core
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endIteration = dumpAndLint Err.dumpIfSet_dyn
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+            -> DynFlags -> String -> DynFlag 
+            -> [CoreBind] -> [CoreRule] -> IO ()
+dumpAndLint dump dflags pass_name dump_flag binds rules
+  = do {  -- Report result size if required
+	  -- This has the side effect of forcing the intermediate to be evaluated
+       ; Err.debugTraceMsg dflags 2 $
+		(text "    Result size =" <+> int (coreBindsSize binds))
+
+	-- Report verbosely, if required
+       ; dump dflags dump_flag pass_name
+              (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+
+	-- Type check
+       ; lintCoreBindings dflags pass_name binds }
+  where
+    pp_rules = vcat [ blankLine
+                    , ptext (sLit "------ Local rules for imported ids --------")
+                    , pprRules rules ]
+\end{code}
+
+
+%************************************************************************
+%*									*
+             Monad and carried data structure definitions
+%*									*
+%************************************************************************
 
 \begin{code}
 data CoreState = CoreState {
@@ -159,7 +215,12 @@ runCoreM hsc_env ann_env rule_base us mod m =
 
 \end{code}
 
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%*									*
+             Core combinators, not exported
+%*									*
+%************************************************************************
 
 \begin{code}
 
@@ -199,7 +260,12 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 
 \end{code}
 
-\subsection{Reader, writer and state accessors}
+
+%************************************************************************
+%*									*
+             Reader, writer and state accessors
+%*									*
+%************************************************************************
 
 \begin{code}
 
@@ -232,7 +298,12 @@ getOrigNameCache = do
 
 \end{code}
 
-\subsection{Dealing with annotations}
+
+%************************************************************************
+%*									*
+             Dealing with annotations
+%*									*
+%************************************************************************
 
 \begin{code}
 
@@ -251,6 +322,14 @@ findAnnotations deserialize target = do
      ann_env <- getAnnEnv
      return (findAnns deserialize ann_env target)
 
+-- | Deserialize all annotations of a given type. This happens lazily, that is
+--   no deserialization will take place until the [a] is actually demanded and
+--   the [a] can also be empty (the UniqFM is not filtered).
+deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
+deserializeAnnotations deserialize = do
+     ann_env <- getAnnEnv
+     return (deserializeAnns deserialize ann_env)
+
 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
 
@@ -259,7 +338,12 @@ addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAn
 
 \end{code}
 
-\subsection{Direct screen output}
+
+%************************************************************************
+%*									*
+                Direct screen output
+%*									*
+%************************************************************************
 
 \begin{code}
 
@@ -303,7 +387,6 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3)
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
-
 \end{code}
 
 \begin{code}
@@ -313,18 +396,25 @@ initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc
 
 \end{code}
 
-\subsection{Finding TyThings}
 
-\begin{code}
+%************************************************************************
+%*									*
+               Finding TyThings
+%*									*
+%************************************************************************
 
+\begin{code}
 instance MonadThings CoreM where
     lookupThing name = do
         hsc_env <- getHscEnv
         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
-
 \end{code}
 
-\subsection{Template Haskell interoperability}
+%************************************************************************
+%*									*
+               Template Haskell interoperability
+%*									*
+%************************************************************************
 
 \begin{code}
 #ifdef GHCI