Add (a) CoreM monad, (b) new Annotations feature

This patch, written by Max Bolingbroke,  does two things

1.  It adds a new CoreM monad (defined in simplCore/CoreMonad),
    which is used as the top-level monad for all the Core-to-Core
    transformations (starting at SimplCore).  It supports
       * I/O (for debug printing)
       * Unique supply
       * Statistics gathering
       * Access to the HscEnv, RuleBase, Annotations, Module
    The patch therefore refactors the top "skin" of every Core-to-Core
    pass, but does not change their functionality.

2.  It adds a completely new facility to GHC: Core "annotations".
    The idea is that you can say
       {#- ANN foo (Just "Hello") #-}
    which adds the annotation (Just "Hello") to the top level function
    foo.  These annotations can be looked up in any Core-to-Core pass,
    and are persisted into interface files.  (Hence a Core-to-Core pass
    can also query the annotations of imported things.)  Furthermore,
    a Core-to-Core pass can add new annotations (eg strictness info)
    of its own, which can be queried by importing modules.

The design of the annotation system is somewhat in flux.  It's
designed to work with the (upcoming) dynamic plug-ins mechanism,
but is meanwhile independently useful.

Do not merge to 6.10!  

8 files changed, 575 insertions, 191 deletions

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 1386197eba..8b5825bf6a 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -10,14 +10,12 @@ module CSE (
 
 #include "HsVersions.h"
 
-import DynFlags	( DynFlag(..), DynFlags )
 import Id		( Id, idType, idInlinePragma, zapIdOccInfo )
 import CoreUtils	( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
 import DataCon		( isUnboxedTupleCon )
 import Type		( tyConAppArgs )
 import CoreSyn
 import VarEnv	
-import CoreLint		( showPass, endPass )
 import Outputable
 import StaticFlags	( opt_PprStyle_Debug )
 import BasicTypes	( isAlwaysActive )
@@ -178,14 +176,8 @@ happen now that we don't look inside INLINEs (which wrappers are).
 %************************************************************************
 
 \begin{code}
-cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-cseProgram dflags binds
-  = do {
-	showPass dflags "Common sub-expression";
-	let { binds' = cseBinds emptyCSEnv binds };
-	endPass dflags "Common sub-expression" 	Opt_D_dump_cse binds'	
-    }
+cseProgram :: [CoreBind] -> [CoreBind]
+cseProgram binds = cseBinds emptyCSEnv binds
 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 cseBinds _   []     = []
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
new file mode 100644
index 0000000000..f480eb3ce7
--- /dev/null
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -0,0 +1,341 @@
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[CoreMonad]{The core pipeline monad}
+
+\begin{code}
+{-# LANGUAGE UndecidableInstances #-}
+
+module CoreMonad (
+    -- * The monad
+    CoreM, runCoreM,
+    
+    -- ** Reading from the monad
+    getHscEnv, getAnnEnv, getRuleBase, getModule,
+    getDynFlags, getOrigNameCache,
+    
+    -- ** Writing to the monad
+    addSimplCount,
+    
+    -- ** Lifting into the monad
+    liftIO, liftIOWithCount,
+    liftIO1, liftIO2, liftIO3, liftIO4,
+    
+    -- ** Dealing with annotations
+    findAnnotations, addAnnotation,
+    
+    -- ** Screen output
+    putMsg, putMsgS, errorMsg, errorMsgS, 
+    fatalErrorMsg, fatalErrorMsgS, 
+    debugTraceMsg, debugTraceMsgS,
+    dumpIfSet_dyn,
+
+#ifdef GHCI
+    -- * Getting 'Name's
+    thNameToGhcName
+#endif
+  ) where
+
+import Name
+import PrelNames        ( iNTERACTIVE )
+import HscTypes
+import Module           ( Module )
+import DynFlags         ( DynFlags, DynFlag )
+import SimplMonad       ( SimplCount, plusSimplCount, zeroSimplCount )
+import Rules            ( RuleBase )
+import Annotations
+import Serialized
+
+import IOEnv hiding     ( liftIO, failM, failWithM )
+import qualified IOEnv  ( liftIO )
+import TcEnv            ( tcLookupGlobal )
+import TcRnMonad        ( TcM, initTc )
+
+import Outputable
+import qualified ErrUtils as Err
+import MonadUtils
+import Maybes
+import UniqSupply
+
+import Data.Dynamic
+import Data.IORef
+import Data.Word
+import Control.Monad
+import Control.Applicative
+
+import Prelude hiding   ( read )
+
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
+import qualified Language.Haskell.TH as TH
+#endif
+\end{code}
+
+\subsection{Monad and carried data structure definitions}
+
+\begin{code}
+data CoreState = CoreState {
+        cs_uniq_supply :: UniqSupply,
+        cs_ann_env :: AnnEnv
+}
+
+data CoreReader = CoreReader {
+        cr_hsc_env :: HscEnv,
+        cr_rule_base :: RuleBase,
+        cr_module :: Module
+}
+
+data CoreWriter = CoreWriter {
+        cw_simpl_count :: SimplCount
+}
+
+emptyWriter :: DynFlags -> CoreWriter
+emptyWriter dflags = CoreWriter {
+        cw_simpl_count = zeroSimplCount dflags
+    }
+
+plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
+plusWriter w1 w2 = CoreWriter {
+        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
+    }
+
+type CoreIOEnv = IOEnv CoreReader
+
+-- | The monad used by Core-to-Core passes to access common state, register simplification
+-- statistics and so on
+newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
+
+instance Functor CoreM where
+    fmap f ma = do
+        a <- ma
+        return (f a)
+
+instance Monad CoreM where
+    return x = CoreM (\s -> nop s x)
+    mx >>= f = CoreM $ \s -> do
+            (x, s', w1) <- unCoreM mx s
+            (y, s'', w2) <- unCoreM (f x) s'
+            return (y, s'', w1 `plusWriter` w2)
+
+instance Applicative CoreM where
+    pure = return
+    (<*>) = ap
+
+-- For use if the user has imported Control.Monad.Error from MTL
+-- Requires UndecidableInstances
+instance MonadPlus IO => MonadPlus CoreM where
+    mzero = CoreM (const mzero)
+    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
+
+instance MonadUnique CoreM where
+    getUniqueSupplyM = do
+        us <- getS cs_uniq_supply
+        let (us1, us2) = splitUniqSupply us
+        modifyS (\s -> s { cs_uniq_supply = us2 })
+        return us1
+
+runCoreM :: HscEnv
+         -> AnnEnv
+         -> RuleBase
+         -> UniqSupply
+         -> Module
+         -> CoreM a
+         -> IO (a, SimplCount)
+runCoreM hsc_env ann_env rule_base us mod m =
+        liftM extract $ runIOEnv reader $ unCoreM m state
+  where
+    reader = CoreReader {
+            cr_hsc_env = hsc_env,
+            cr_rule_base = rule_base,
+            cr_module = mod
+        }
+    state = CoreState { 
+            cs_uniq_supply = us,
+            cs_ann_env = ann_env
+        }
+
+    extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
+    extract (value, _, writer) = (value, cw_simpl_count writer)
+
+\end{code}
+
+\subsection{Core combinators, not exported}
+
+\begin{code}
+
+nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
+nop s x = do
+    r <- getEnv
+    return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
+
+read :: (CoreReader -> a) -> CoreM a
+read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
+
+getS :: (CoreState -> a) -> CoreM a
+getS f = CoreM (\s -> nop s (f s))
+
+modifyS :: (CoreState -> CoreState) -> CoreM ()
+modifyS f = CoreM (\s -> nop (f s) ())
+
+write :: CoreWriter -> CoreM ()
+write w = CoreM (\s -> return ((), s, w))
+
+\end{code}
+
+\subsection{Lifting IO into the monad}
+
+\begin{code}
+
+-- | Lift an 'IOEnv' operation into 'CoreM'
+liftIOEnv :: CoreIOEnv a -> CoreM a
+liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
+
+instance MonadIO CoreM where
+    liftIO = liftIOEnv . IOEnv.liftIO
+
+-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
+liftIOWithCount :: IO (SimplCount, a) -> CoreM a
+liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
+
+\end{code}
+
+\subsection{Reader, writer and state accessors}
+
+\begin{code}
+
+getHscEnv :: CoreM HscEnv
+getHscEnv = read cr_hsc_env
+
+getAnnEnv :: CoreM AnnEnv
+getAnnEnv = getS cs_ann_env
+
+getRuleBase :: CoreM RuleBase
+getRuleBase = read cr_rule_base
+
+getModule :: CoreM Module
+getModule = read cr_module
+
+addSimplCount :: SimplCount -> CoreM ()
+addSimplCount count = write (CoreWriter { cw_simpl_count = count })
+
+-- Convenience accessors for useful fields of HscEnv
+
+getDynFlags :: CoreM DynFlags
+getDynFlags = fmap hsc_dflags getHscEnv
+
+-- | The original name cache is the current mapping from 'Module' and
+-- 'OccName' to a compiler-wide unique 'Name'
+getOrigNameCache :: CoreM OrigNameCache
+getOrigNameCache = do
+    nameCacheRef <- fmap hsc_NC getHscEnv
+    liftIO $ fmap nsNames $ readIORef nameCacheRef
+
+\end{code}
+
+\subsection{Dealing with annotations}
+
+\begin{code}
+
+-- | Find all the annotations we currently know about for the given target. Note that no
+-- annotations will be returned if we haven't loaded information about the particular target
+-- you are inquiring about: by default, only those modules that have been imported by the
+-- program being compiled will have been loaded in this way.
+--
+-- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
+-- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
+-- will impose a performance penalty.
+--
+-- If no deserialization function is supplied, only transient annotations will be returned.
+findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
+findAnnotations deserialize target = do
+     ann_env <- getAnnEnv
+     return (findAnns deserialize ann_env target)
+
+addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
+addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
+
+addAnnotationToEnv :: Annotation -> CoreM ()
+addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
+
+\end{code}
+
+\subsection{Direct screen output}
+
+\begin{code}
+
+msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
+msg how doc = do
+        dflags <- getDynFlags
+        liftIO $ how dflags doc
+
+-- | Output a String message to the screen
+putMsgS :: String -> CoreM ()
+putMsgS = putMsg . text
+
+-- | Output a message to the screen
+putMsg :: SDoc -> CoreM ()
+putMsg = msg Err.putMsg
+
+-- | Output a string error to the screen
+errorMsgS :: String -> CoreM ()
+errorMsgS = errorMsg . text
+
+-- | Output an error to the screen
+errorMsg :: SDoc -> CoreM ()
+errorMsg = msg Err.errorMsg
+
+-- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
+fatalErrorMsgS :: String -> CoreM ()
+fatalErrorMsgS = fatalErrorMsg . text
+
+-- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
+fatalErrorMsg :: SDoc -> CoreM ()
+fatalErrorMsg = msg Err.fatalErrorMsg
+
+-- | Output a string debugging message at verbosity level of @-v@ or higher
+debugTraceMsgS :: String -> CoreM ()
+debugTraceMsgS = debugTraceMsg . text
+
+-- | Outputs a debugging message at verbosity level of @-v@ or higher
+debugTraceMsg :: SDoc -> CoreM ()
+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}
+
+initTcForLookup :: HscEnv -> TcM a -> IO a
+initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
+
+\end{code}
+
+\subsection{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}
+
+\begin{code}
+
+#ifdef GHCI
+-- | Attempt to convert a Template Haskell name to one that GHC can understand. Original TH names such as those you get when you
+-- use the @'foo@ syntax will be translated to their equivalent GHC name exactly. Qualified or unqualifed TH names will be dynamically
+-- bound to names in the module being compiled, if possible. Exact TH names will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name = do
+    hsc_env <- getHscEnv
+    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
+#endif
+
+\end{code}
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index 8dbec27bf5..1146c77031 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -16,10 +16,8 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
-import DynFlags	( DynFlags, DynFlag(..) )
 import CoreSyn
 import CoreUtils	( exprIsHNF, exprIsDupable )
-import CoreLint		( showPass, endPass )
 import CoreFVs		( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
 import Id		( isOneShotBndr, idType )
 import Var
@@ -34,16 +32,8 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 
 \begin{code}
-floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-floatInwards dflags binds
-  = do {
-	showPass dflags "Float inwards";
-	let { binds' = map fi_top_bind binds };
-	endPass dflags "Float inwards" Opt_D_verbose_core2core binds'	
-				{- no specific flag for dumping float-in -} 
-    }
-			  
+floatInwards :: [CoreBind] -> [CoreBind]
+floatInwards = map fi_top_bind
   where
     fi_top_bind (NonRec binder rhs)
       = NonRec binder (fiExpr [] (freeVars rhs))
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index f1b190316b..6562c84e8c 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -16,7 +16,6 @@ import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
 import Id		( Id, idType )
 import Type		( isUnLiftedType )
-import CoreLint		( showPass, endPass )
 import SetLevels	( Level(..), LevelledExpr, LevelledBind,
 			  setLevels, ltMajLvl, ltLvl, isTopLvl )
 import UniqSupply       ( UniqSupply )
@@ -116,8 +115,6 @@ floatOutwards :: FloatOutSwitches
 
 floatOutwards float_sws dflags us pgm
   = do {
-	showPass dflags float_msg ;
-
 	let { annotated_w_levels = setLevels float_sws pgm us ;
 	      (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
 	    } ;
@@ -132,15 +129,8 @@ floatOutwards float_sws dflags us pgm
 			int ntlets, ptext (sLit " Lets floated elsewhere; from "),
 			int lams,   ptext (sLit " Lambda groups")]);
 
-	endPass dflags float_msg  Opt_D_verbose_core2core (concat binds_s')
-			{- no specific flag for dumping float-out -} 
+	return (concat binds_s')
     }
-  where
-    float_msg = showSDoc (text "Float out" <+> parens (sws float_sws))
-    sws (FloatOutSw lam const) = pp_not lam   <+> text "lambdas" <> comma <+>
-				 pp_not const <+> text "constants"
-    pp_not True  = empty
-    pp_not False = text "not"
 
 floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
 floatTopBind bind
diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 9fe6b87481..4b1055bbed 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -9,13 +9,8 @@ module LiberateCase ( liberateCase ) where
 #include "HsVersions.h"
 
 import DynFlags
-import HscTypes
-import CoreLint		( showPass, endPass )
 import CoreSyn
 import CoreUnfold	( couldBeSmallEnoughToInline )
-import Rules		( RuleBase )
-import UniqSupply	( UniqSupply )
-import SimplMonad	( SimplCount, zeroSimplCount )
 import Id
 import VarEnv
 import Util             ( notNull )
@@ -122,17 +117,8 @@ and the level of @h@ is zero (NB not one).
 %************************************************************************
 
 \begin{code}
-liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-	     -> IO (SimplCount, ModGuts)
-liberateCase hsc_env _ _ guts
-  = do	{ let dflags = hsc_dflags hsc_env
-
-	; showPass dflags "Liberate case"
-	; let { env = initEnv dflags
-	      ; binds' = do_prog env (mg_binds guts) }
-	; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
-			{- no specific flag for dumping -} 
-	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
+liberateCase dflags binds = do_prog (initEnv dflags) binds
   where
     do_prog _   [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds
diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs
index 329c95ca11..ca251568a7 100644
--- a/compiler/simplCore/SAT.lhs
+++ b/compiler/simplCore/SAT.lhs
@@ -52,10 +52,8 @@ essential to make this work well!
 
 module SAT ( doStaticArgs ) where
 
-import DynFlags
 import Var
 import CoreSyn
-import CoreLint
 import CoreUtils
 import Type
 import TcType
@@ -78,11 +76,8 @@ import FastString
 \end{code}
 
 \begin{code}
-doStaticArgs :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-doStaticArgs dflags us binds = do
-    showPass dflags "Static argument"
-    let binds' = snd $ mapAccumL sat_bind_threaded_us us binds
-    endPass dflags "Static argument" Opt_D_verbose_core2core binds'
+doStaticArgs :: UniqSupply -> [CoreBind] -> [CoreBind]
+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
   where
     sat_bind_threaded_us us bind =
         let (us1, us2) = splitUniqSupply us
@@ -428,4 +423,4 @@ isStaticValue :: Staticness App -> Bool
 isStaticValue (Static (VarApp _)) = True
 isStaticValue _                   = False
 
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index e20bc833c7..270ce17095 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -691,10 +691,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv
 initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
 
 floatLams :: LevelEnv -> Bool
-floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+floatLams (fos, _, _, _) = floatOutLambdas fos
 
 floatConsts :: LevelEnv -> Bool
-floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+floatConsts (fos, _, _, _) = floatOutConstants fos
 
 extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
 -- Used when *not* cloning
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 5b52d2d2d7..5c3c789c79 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -22,7 +22,8 @@ import CoreSyn
 import HscTypes
 import CSE		( cseProgram )
 import Rules		( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
-			  extendRuleBaseList, pprRuleBase, ruleCheckProgram,
+			  extendRuleBaseList, pprRuleBase, pprRulesForUser,
+			  ruleCheckProgram, rulesOfBinds,
 			  addSpecInfo, addIdSpecialisations )
 import PprCore		( pprCoreBindings, pprCoreExpr, pprRules )
 import OccurAnal	( occurAnalysePgm, occurAnalyseExpr )
@@ -34,8 +35,9 @@ import CoreUtils	( coreBindsSize )
 import Simplify		( simplTopBinds, simplExpr )
 import SimplEnv		( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
 import SimplMonad
-import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint		( endPassIf, endIteration )
+import CoreMonad
+import qualified ErrUtils as Err        ( dumpIfSet_dyn, dumpIfSet, showPass )
+import CoreLint		( showPass, endPass, endPassIf, endIteration )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FamInstEnv
@@ -43,6 +45,7 @@ import Id
 import DataCon
 import TyCon		( tyConSelIds, tyConDataCons )
 import Class		( classSelIds )
+import BasicTypes       ( CompilerPhase, isActive )
 import VarSet
 import VarEnv
 import NameEnv		( lookupNameEnv )
@@ -57,6 +60,7 @@ import StrictAnal	( saBinds )
 import CprAnalyse       ( cprAnalyse )
 #endif
 import Vectorise        ( vectorise )
+import FastString
 import Util
 
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
@@ -78,32 +82,43 @@ core2core :: HscEnv
 	  -> ModGuts
 	  -> IO ModGuts
 
-core2core hsc_env guts
-  = do	{
-	; let dflags = hsc_dflags hsc_env
-	      core_todos = getCoreToDo dflags
+core2core hsc_env guts = do
+    let dflags = hsc_dflags hsc_env
+
+    us <- mkSplitUniqSupply 's'
+    let (cp_us, ru_us) = splitUniqSupply us
+
+    -- COMPUTE THE ANNOTATIONS TO USE
+    ann_env <- prepareAnnotations hsc_env (Just guts)
+
+    -- COMPUTE THE RULE BASE TO USE
+    (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
 
-	; us <- mkSplitUniqSupply 's'
-	; let (cp_us, ru_us) = splitUniqSupply us
+    -- Get the module out of the current HscEnv so we can retrieve it from the monad.
+    -- This is very convienent for the users of the monad (e.g. plugins do not have to
+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
+    -- would mean our cached value would go out of date.
+    let mod = mg_module guts
+    (guts, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+        -- FIND BUILT-IN PASSES
+        let builtin_core_todos = getCoreToDo dflags
 
-		-- COMPUTE THE RULE BASE TO USE
-	; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+        -- Note [Injecting implicit bindings]
+        let implicit_binds = getImplicitBinds (mg_types guts1)
+            guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
 
-		-- Note [Injecting implicit bindings]
-        ; let implicit_binds = getImplicitBinds (mg_types guts1)
-	      guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
+        -- DO THE BUSINESS
+        doCorePasses builtin_core_todos guts2
 
-		-- DO THE BUSINESS
-	; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
-			 		 (zeroSimplCount dflags) 
-				 	 guts2 core_todos
+    Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+        "Grand total simplifier statistics"
+        (pprSimplCount stats)
 
-	; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
-		  "Grand total simplifier statistics"
-		  (pprSimplCount stats)
+    return guts
 
-	; return guts3 }
 
+type CorePass = CoreToDo
 
 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 	     -> CoreExpr
@@ -112,14 +127,14 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 -- expression typed in at the interactive prompt
 simplifyExpr dflags expr
   = do	{
-	; showPass dflags "Simplify"
+	; Err.showPass dflags "Simplify"
 
 	; us <-  mkSplitUniqSupply 's'
 
 	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 				 simplExprGently gentleSimplEnv expr
 
-	; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 			(pprCoreExpr expr')
 
 	; return expr'
@@ -128,93 +143,165 @@ simplifyExpr dflags expr
 gentleSimplEnv :: SimplEnv
 gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
 
-doCorePasses :: HscEnv
-             -> RuleBase        -- the imported main rule base
-             -> UniqSupply      -- uniques
-	     -> SimplCount      -- simplifier stats
-             -> ModGuts	        -- local binds in (with rules attached)
-             -> [CoreToDo]      -- which passes to do
-             -> IO (SimplCount, ModGuts)
-
-doCorePasses hsc_env rb us stats guts []
-  = return (stats, guts)
-
-doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) 
-  = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2) 
-
-doCorePasses hsc_env rb us stats guts (to_do : to_dos) 
-  = do
-	let (us1, us2) = splitUniqSupply us
-	(stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
-	doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
-
-doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
-	   -> ModGuts -> IO (SimplCount, ModGuts)
-doCorePass (CoreDoSimplify mode sws)   = {-# SCC "Simplify" #-}      simplifyPgm mode sws
-doCorePass CoreCSE		       = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
-doCorePass CoreLiberateCase	       = {-# SCC "LiberateCase" #-}  liberateCase
-doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
-doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs	       = {-# SCC "StaticArgs" #-}    trBindsU  doStaticArgs
-doCorePass CoreDoStrictness	       = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
-doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
-doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
-doCorePass CoreDoSpecConstr	       = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
-doCorePass CoreDoGlomBinds	       = trBinds glomBinds
-doCorePass (CoreDoVectorisation be)    = {-# SCC "Vectorise" #-}     vectorise be
-doCorePass CoreDoPrintCore	       = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
-doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
-#ifdef OLD_STRICTNESS		       
-doCorePass CoreDoOldStrictness	       = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
-#else
-doCorePass CoreDoOldStrictness	       = panic "CoreDoOldStrictness"
+doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
+doCorePasses passes guts = foldM (flip doCorePass) guts passes
+
+doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
+doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
+                                       simplifyPgm mode sws
+
+doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
+	   			       describePass "Common sub-expression" Opt_D_dump_cse $ 
+				       doPass cseProgram
+
+doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+	   			       describePass "Liberate case" Opt_D_verbose_core2core $ 
+                                       doPassD liberateCase
+
+doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                       describePass "Float inwards" Opt_D_verbose_core2core $ 
+                                       doPass floatInwards
+
+doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                       describePassD (text "Float out" <+> parens (ppr f)) 
+                                                     Opt_D_verbose_core2core $ 
+                                       doPassDUM (floatOutwards f)
+
+doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                       describePass "Static argument" Opt_D_verbose_core2core $ 
+                                       doPassU doStaticArgs
+
+doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
+                                       describePass "Demand analysis" Opt_D_dump_stranal $
+                                       doPassDM dmdAnalPgm
+
+doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                       describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
+                                       doPassU wwTopBinds
+
+doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                       describePassR "Specialise" Opt_D_dump_spec $ 
+                                       doPassU specProgram
+
+doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                       describePassR "SpecConstr" Opt_D_dump_spec $
+                                       doPassDU  specConstrProgram
+
+doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
+                                       describePass "Vectorisation" Opt_D_dump_vect $ 
+                                       vectorise be
+
+doCorePass CoreDoGlomBinds              = dontDescribePass $ doPassDM  glomBinds
+doCorePass CoreDoPrintCore              = dontDescribePass $ observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = dontDescribePass $ ruleCheck phase pat
+
+#ifdef OLD_STRICTNESS
+doCorePass CoreDoOldStrictness          = {-# SCC "OldStrictness" #-} doOldStrictness
 #endif
-doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
+
+doCorePass CoreDoNothing                = return
+doCorePass (CoreDoPasses passes)        = doCorePasses passes
 
 #ifdef OLD_STRICTNESS
-doOldStrictness dfs binds
-  = do binds1 <- saBinds dfs binds
-       binds2 <- cprAnalyse dfs binds1
-       return binds2
+doOldStrictness :: ModGuts -> CoreM ModGuts
+doOldStrictness guts
+  = do dfs <- getDynFlags
+       guts'  <- describePass "Strictness analysis" Opt_D_dump_stranal $ 
+                 doPassM (saBinds dfs) guts
+       guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $ 
+                 doPass cprAnalyse guts'
+       return guts''
 #endif
 
-printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-
-ruleCheck phase pat hsc_env us rb guts 
-  =  do let dflags = hsc_dflags hsc_env
-	showPass dflags "RuleCheck"
-        printDump (ruleCheckProgram phase pat rb (mg_binds guts))
-	return (zeroSimplCount dflags, guts)
-
--- Most passes return no stats and don't change rules
-trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
-	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-	-> IO (SimplCount, ModGuts)
-trBinds do_pass hsc_env us rb guts
-  = do	{ binds' <- do_pass dflags (mg_binds guts)
-	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
-  where
-    dflags = hsc_dflags hsc_env
-
-trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
-	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-	-> IO (SimplCount, ModGuts)
-trBindsU do_pass hsc_env us rb guts
-  = do	{ binds' <- do_pass dflags us (mg_binds guts)
-	; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
-  where
-    dflags = hsc_dflags hsc_env
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Core pass combinators}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+dontDescribePass = ($)
+
+describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePass name dflag pass guts = do
+    dflags <- getDynFlags
+    
+    liftIO $ showPass dflags name
+    guts' <- pass guts
+    liftIO $ endPass dflags name dflag (mg_binds guts')
+    
+    return guts'
+
+describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePassD doc = describePass (showSDoc doc)
+
+describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePassR name dflag pass guts = do
+    guts' <- describePass name dflag pass guts
+    dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
+                (pprRulesForUser (rulesOfBinds (mg_binds guts')))
+    return guts'
+
+printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
+
+ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheck current_phase pat guts = do
+    let is_active = isActive current_phase
+    rb <- getRuleBase
+    dflags <- getDynFlags
+    liftIO $ Err.showPass dflags "RuleCheck"
+    liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
+    return guts
+
+
+doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
+doPassDMS do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    liftIOWithCount $ do_pass dflags binds
+
+doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDUM do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    liftIO $ do_pass dflags us binds
+
+doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
+
+doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
+
+doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
+
+doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassU do_pass = doPassDU (const do_pass)
+
+-- Most passes return no stats and don't change rules: these combinators
+-- let us lift them to the full blown ModGuts+CoreM world
+doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassM bind_f guts = do
+    binds' <- bind_f (mg_binds guts)
+    return (guts { mg_binds = binds' })
+
+doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassMG bind_f guts = do
+    binds' <- bind_f guts
+    return (guts { mg_binds = binds' })
+
+doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
 
 -- Observer passes just peek; don't modify the bindings at all
-observe :: (DynFlags -> [CoreBind] -> IO a)
-	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-	-> IO (SimplCount, ModGuts)
-observe do_pass hsc_env us rb guts 
-  = do	{ binds <- do_pass dflags (mg_binds guts)
-	; return (zeroSimplCount dflags, guts) }
-  where
-    dflags = hsc_dflags hsc_env
+observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
+observe do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    liftIO $ do_pass dflags binds
+    return binds
 \end{code}
 
 
@@ -317,7 +404,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	      hpt_rule_base = mkRuleBase home_pkg_rules
 	      imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
 
-	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+	; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
 		(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
 		 vcat [text "Local rules", pprRules better_rules,
 		       text "",
@@ -435,7 +522,7 @@ glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 -- analyser as free in f.
 
 glomBinds dflags binds
-  = do { showPass dflags "GlomBinds" ;
+  = do { Err.showPass dflags "GlomBinds" ;
 	 let { recd_binds = [Rec (flattenBinds binds)] } ;
 	 return recd_binds }
 	-- Not much point in printing the result... 
@@ -450,43 +537,46 @@ glomBinds dflags binds
 %************************************************************************
 
 \begin{code}
-simplifyPgm :: SimplifierMode
+simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
+simplifyPgm mode switches
+  = describePassD doc Opt_D_dump_simpl_phases $ \guts -> 
+    do { hsc_env <- getHscEnv
+       ; us <- getUniqueSupplyM
+       ; rb <- getRuleBase
+       ; let fam_inst_env = mg_fam_inst_env guts
+             dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
+	     simplify_pgm = simplifyPgmIO dump_phase mode switches 
+                                          hsc_env us rb fam_inst_env
+
+       ; doPassM (liftIOWithCount . simplify_pgm) guts }
+  where
+    doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) 
+
+simplifyPgmIO :: Bool
+            -> SimplifierMode
 	    -> [SimplifierSwitch]
 	    -> HscEnv
 	    -> UniqSupply
 	    -> RuleBase
-	    -> ModGuts
-	    -> IO (SimplCount, ModGuts)  -- New bindings
+	    -> FamInstEnv
+	    -> [CoreBind]
+	    -> IO (SimplCount, [CoreBind])  -- New bindings
 
-simplifyPgm mode switches hsc_env us imp_rule_base guts
+simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
   = do {
-	showPass dflags "Simplify";
-
 	(termination_msg, it_count, counts_out, binds') 
-	   <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
+	   <- do_iteration us 1 (zeroSimplCount dflags) binds ;
 
-	dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
-		  "Simplifier statistics"
+	Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+		  "Simplifier statistics for following pass"
 		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 			 text "",
 			 pprSimplCount counts_out]);
 
-	endPassIf dump_phase dflags
-                  ("Simplify phase " ++ phase_info ++ " done")
-                  Opt_D_dump_simpl_phases binds';
-
-	return (counts_out, guts { mg_binds = binds' })
+	return (counts_out, binds')
     }
   where
     dflags 	   = hsc_dflags hsc_env
-    phase_info	   = case mode of
-		   	  SimplGently     -> "gentle"
-		   	  SimplPhase n ss -> shows n
-                                           . showString " ["
-                                           . showString (concat $ intersperse "," ss)
-                                           $ "]"
-
-    dump_phase     = shouldDumpSimplPhase dflags mode
 		   
     sw_chkr	   = isAmongSimpl switches
     max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
@@ -509,7 +599,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
       = do {
 		-- Occurrence analysis
 	   let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
-	   dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+	   Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
 		     (pprCoreBindings tagged_binds);
 
 	   	-- Get any new rules, and extend the rule base
@@ -522,7 +612,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
 		; simpl_env  = mkSimplEnv mode sw_chkr 
 		; simpl_binds = {-# SCC "SimplTopBinds" #-} 
 				simplTopBinds simpl_env tagged_binds
-		; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
+		; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
 	   
 		-- Simplify the program
 		-- We do this with a *case* not a *let* because lazy pattern
@@ -539,7 +629,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
 	  	(binds', counts') -> do {
 
 	   let	{ all_counts = counts `plusSimplCount` counts'
-		; herald     = "Simplifier phase " ++ phase_info ++ 
+		; herald     = "Simplifier mode " ++ showPpr mode ++ 
 			      ", iteration " ++ show iteration_no ++
 			      " out of " ++ show max_iterations
 	        } ;
@@ -560,7 +650,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
 	   let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
 
 		-- Dump the result of this iteration
-	   dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+	   Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
 		         (pprSimplCount counts') ;
 	   endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;