Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / simplCore / CoreMonad.lhs
index ae45ba4..ab69916 100644 (file)
@@ -4,14 +4,36 @@
 \section[CoreMonad]{The core pipeline monad}
 
 \begin{code}
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
 {-# LANGUAGE UndecidableInstances #-}
 
 module CoreMonad (
+    -- * Configuration of the core-to-core passes
+    CoreToDo(..), runWhen, runMaybe,
+    SimplifierMode(..),
+    FloatOutSwitches(..),
+    dumpSimplPhase, pprPassDetails, 
+
+    -- * Plugins
+    PluginPass, Plugin(..), CommandLineOption, 
+    defaultPlugin, bindsOnlyPass,
+
+    -- * Counting
+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
+    pprSimplCount, plusSimplCount, zeroSimplCount, 
+    isZeroSimplCount, hasDetailedCounts, Tick(..),
+
     -- * The monad
     CoreM, runCoreM,
     
     -- ** Reading from the monad
-    getHscEnv, getAnnEnv, getRuleBase, getModule,
+    getHscEnv, getRuleBase, getModule,
     getDynFlags, getOrigNameCache,
     
     -- ** Writing to the monad
@@ -21,14 +43,20 @@ module CoreMonad (
     liftIO, liftIOWithCount,
     liftIO1, liftIO2, liftIO3, liftIO4,
     
+    -- ** Global initialization
+    reinitializeGlobals,
+    
     -- ** Dealing with annotations
-    findAnnotations, addAnnotation,
+    getAnnotations, getFirstAnnotations,
     
+    -- ** Debug output
+    showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet,
+
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
     fatalErrorMsg, fatalErrorMsgS, 
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
+    dumpIfSet_dyn, 
 
 #ifdef GHCI
     -- * Getting 'Name's
@@ -39,14 +67,19 @@ 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 )
-import DynFlags         ( DynFlags, DynFlag )
-import SimplMonad       ( SimplCount, plusSimplCount, zeroSimplCount )
+import DynFlags
+import StaticFlags     
 import Rules            ( RuleBase )
+import BasicTypes       ( CompilerPhase(..) )
 import Annotations
-import Serialized
+import Id              ( Id )
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
@@ -54,37 +87,641 @@ import TcEnv            ( tcLookupGlobal )
 import TcRnMonad        ( TcM, initTc )
 
 import Outputable
+import FastString
 import qualified ErrUtils as Err
-import MonadUtils
+import Bag
 import Maybes
 import UniqSupply
+import UniqFM       ( UniqFM, mapUFM, filterUFM )
+import MonadUtils
 
+import Util            ( split, sortLe )
+import ListSetOps      ( runs )
+import Data.List       ( intersperse )
 import Data.Dynamic
 import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Word
 import Control.Monad
-import Control.Applicative
 
 import Prelude hiding   ( read )
 
 #ifdef GHCI
+import Control.Concurrent.MVar (MVar)
+import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
 import qualified Language.Haskell.TH as TH
+#else
+saveLinkerGlobals :: IO ()
+saveLinkerGlobals = return ()
+
+restoreLinkerGlobals :: () -> IO ()
+restoreLinkerGlobals () = return ()
 #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}
+showPass :: DynFlags -> CoreToDo -> IO ()
+showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
+
+endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+endPass dflags pass binds rules
+  = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
+       ; lintPassResult dflags pass binds }      
+  where
+    mb_flag = case coreDumpFlag pass of
+                Just dflag | dopt dflag dflags                   -> Just dflag
+                           | dopt Opt_D_verbose_core2core dflags -> Just dflag
+                _ -> Nothing
+
+dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dump_me pass extra_info doc
+  = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
+
+dumpPassResult :: DynFlags 
+               -> Maybe DynFlag                -- Just df => show details in a file whose
+                                       --            name is specified by df
+               -> SDoc                         -- Header
+               -> SDoc                         -- Extra info to appear after header
+               -> CoreProgram -> [CoreRule] 
+               -> IO ()
+dumpPassResult dflags mb_flag hdr extra_info binds rules
+  | Just dflag <- mb_flag
+  = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc
+
+  | otherwise
+  = Err.debugTraceMsg dflags 2 $
+    (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds))
+          -- Report result size 
+         -- This has the side effect of forcing the intermediate to be evaluated
+
+  where
+    dump_doc  = vcat [ text "Result size =" <+> int (coreBindsSize binds)
+                     , extra_info
+                    , blankLine
+                     , pprCoreBindings binds 
+                     , ppUnless (null rules) pp_rules ]
+    pp_rules = vcat [ blankLine
+                    , ptext (sLit "------ Local rules for imported ids --------")
+                    , pprRules rules ]
+
+lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult dflags pass binds
+  = when (dopt Opt_DoCoreLinting dflags) $
+    do { let (warns, errs) = lintCoreBindings binds
+       ; Err.showPass dflags ("Core Linted result of " ++ showSDoc (ppr pass))
+       ; displayLintResults dflags pass warns errs binds  }
+
+displayLintResults :: DynFlags -> CoreToDo
+                   -> Bag Err.Message -> Bag Err.Message -> CoreProgram
+                   -> IO ()
+displayLintResults dflags pass warns errs binds
+  | not (isEmptyBag errs)
+  = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
+                        , ptext (sLit "*** Offending Program ***")
+                        , pprCoreBindings binds
+                        , ptext (sLit "*** End of Offense ***") ])
+       ; Err.ghcExit dflags 1 }
+
+  | not (isEmptyBag warns)
+  , not (case pass of { CoreDesugar -> True; _ -> False })
+       -- Suppress warnings after desugaring pass because some
+       -- are legitimate. Notably, the desugarer generates instance
+       -- methods with INLINE pragmas that form a mutually recursive
+       -- group.  Only afer a round of simplification are they unravelled.
+  , not opt_NoDebugOutput
+  , showLintWarnings pass
+  = printDump (banner "warnings" $$ Err.pprMessageBag warns)
+
+  | otherwise = return ()
+  where
+    banner string = ptext (sLit "*** Core Lint")      <+> text string 
+                    <+> ptext (sLit ": in result of") <+> ppr pass
+                    <+> ptext (sLit "***")
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+              The CoreToDo type and related types
+         Abstraction of core-to-core passes to run.
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-data CoreState = CoreState {
-        cs_uniq_supply :: UniqSupply,
-        cs_ann_env :: AnnEnv
+
+data CoreToDo           -- These are diff core-to-core passes,
+                        -- which may be invoked in any order,
+                        -- as many times as you like.
+
+  = CoreDoSimplify      -- The core-to-core simplifier.
+        Int                    -- Max iterations
+        SimplifierMode
+  | CoreDoPluginPass String PluginPass
+  | CoreDoFloatInwards
+  | CoreDoFloatOutwards FloatOutSwitches
+  | CoreLiberateCase
+  | CoreDoPrintCore
+  | CoreDoStaticArgs
+  | CoreDoStrictness
+  | CoreDoWorkerWrapper
+  | CoreDoSpecialising
+  | CoreDoSpecConstr
+  | CoreCSE
+  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
+                                           -- matching this string
+  | CoreDoVectorisation
+  | CoreDoNothing                -- Useful when building up
+  | CoreDoPasses [CoreToDo]      -- lists of these things
+
+  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
+                       --                 Core output, and hence useful to pass to endPass
+
+  | CoreTidy
+  | CorePrep
+
+\end{code}
+
+\begin{code}
+coreDumpFlag :: CoreToDo -> Maybe DynFlag
+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs        = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStrictness        = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
+coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds 
+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
+
+coreDumpFlag CoreDoPrintCore         = Nothing
+coreDumpFlag (CoreDoRuleCheck {})    = Nothing
+coreDumpFlag CoreDoNothing           = Nothing
+coreDumpFlag (CoreDoPasses {})       = Nothing
+
+instance Outputable CoreToDo where
+  ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
+  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
+  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
+  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
+  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
+  ppr CoreDoStaticArgs                = ptext (sLit "Static argument")
+  ppr CoreDoStrictness                = ptext (sLit "Demand analysis")
+  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
+  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
+  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
+  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
+  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
+  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
+  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
+  ppr CoreTidy                 = ptext (sLit "Tidy Core")
+  ppr CorePrep                        = ptext (sLit "CorePrep")
+  ppr CoreDoPrintCore          = ptext (sLit "Print core")
+  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
+  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
+  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
+
+pprPassDetails :: CoreToDo -> SDoc
+pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n
+pprPassDetails _ = empty
+\end{code}
+
+\begin{code}
+data SimplifierMode             -- See comments in SimplMonad
+  = SimplMode
+        { sm_names      :: [String] -- Name(s) of the phase
+        , sm_phase      :: CompilerPhase
+        , sm_rules      :: Bool     -- Whether RULES are enabled
+        , sm_inline     :: Bool     -- Whether inlining is enabled
+        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
+        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+        }
+
+instance Outputable SimplifierMode where
+    ppr (SimplMode { sm_phase = p, sm_names = ss
+                   , sm_rules = r, sm_inline = i
+                   , sm_eta_expand = eta, sm_case_case = cc })
+       = ptext (sLit "SimplMode") <+> braces (
+         sep [ ptext (sLit "Phase =") <+> ppr p <+>
+               brackets (text (concat $ intersperse "," ss)) <> comma
+             , pp_flag i   (sLit "inline") <> comma
+             , pp_flag r   (sLit "rules") <> comma
+             , pp_flag eta (sLit "eta-expand") <> comma
+             , pp_flag cc  (sLit "case-of-case") ])
+        where
+           pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
+\end{code}
+
+
+\begin{code}
+data FloatOutSwitches = FloatOutSwitches {
+  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
+                                   -- doing so will abstract over n or fewer 
+                                   -- value variables
+                                  -- Nothing <=> float all lambdas to top level,
+                                   --             regardless of how many free variables
+                                   -- Just 0 is the vanilla case: float a lambda
+                                   --    iff it has no free vars
+
+  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
+                                   --            even if they do not escape a lambda
+  floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
+                                            --            based on arity information.
+  }
+instance Outputable FloatOutSwitches where
+    ppr = pprFloatOutSwitches
+
+pprFloatOutSwitches :: FloatOutSwitches -> SDoc
+pprFloatOutSwitches sw 
+  = ptext (sLit "FOS") <+> (braces $
+     sep $ punctuate comma $ 
+     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
+     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
+     , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
+
+-- The core-to-core pass ordering is derived from the DynFlags:
+runWhen :: Bool -> CoreToDo -> CoreToDo
+runWhen True  do_this = do_this
+runWhen False _       = CoreDoNothing
+
+runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
+runMaybe (Just x) f = f x
+runMaybe Nothing  _ = CoreDoNothing
+
+
+dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
+dumpSimplPhase dflags mode
+   | Just spec_string <- shouldDumpSimplPhase dflags
+   = match_spec spec_string
+   | otherwise
+   = dopt Opt_D_verbose_core2core dflags
+
+  where
+    match_spec :: String -> Bool
+    match_spec spec_string 
+      = or $ map (and . map match . split ':') 
+           $ split ',' spec_string
+
+    match :: String -> Bool
+    match "" = True
+    match s  = case reads s of
+                [(n,"")] -> phase_num  n
+                _        -> phase_name s
+
+    phase_num :: Int -> Bool
+    phase_num n = case sm_phase mode of
+                    Phase k -> n == k
+                    _       -> False
+
+    phase_name :: String -> Bool
+    phase_name s = s `elem` sm_names mode
+\end{code}
+
+
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification.  Two reasons:
+
+  * We really want the class-op cancellation to happen:
+        op (df d1 d2) --> $cop3 d1 d2
+    because this breaks the mutual recursion between 'op' and 'df'
+
+  * I wanted the RULE
+        lift String ===> ...
+    to work in Template Haskell when simplifying
+    splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating.  So use phase control
+to switch off those rules until after floating.
+
+
+%************************************************************************
+%*                                                                     *
+             Types for Plugins
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
+type CommandLineOption = String
+
+-- | 'Plugin' is the core compiler plugin data type. Try to avoid
+-- constructing one of these directly, and just modify some fields of
+-- 'defaultPlugin' instead: this is to try and preserve source-code
+-- compatability when we add fields to this.
+--
+-- Nonetheless, this API is preliminary and highly likely to change in the future.
+data Plugin = Plugin { 
+        installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+                -- ^ Modify the Core pipeline that will be used for compilation. 
+                -- This is called as the Core pipeline is built for every module
+                --  being compiled, and plugins get the opportunity to modify 
+                -- the pipeline in a nondeterministic order.
+     }
+
+-- | Default plugin: does nothing at all! For compatability reasons you should base all your
+-- plugin definitions on this default value.
+defaultPlugin :: Plugin
+defaultPlugin = Plugin {
+        installCoreToDos = const return
+    }
+
+-- | A description of the plugin pass itself
+type PluginPass = ModGuts -> CoreM ModGuts
+
+bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
+bindsOnlyPass pass guts
+  = do { binds' <- pass (mg_binds guts)
+       ; return (guts { mg_binds = binds' }) }
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+             Counting and logging
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+verboseSimplStats :: Bool
+verboseSimplStats = opt_PprStyle_Debug         -- For now, anyway
+
+zeroSimplCount    :: DynFlags -> SimplCount
+isZeroSimplCount   :: SimplCount -> Bool
+hasDetailedCounts  :: SimplCount -> Bool
+pprSimplCount     :: SimplCount -> SDoc
+doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
+plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
+\end{code}
+
+\begin{code}
+data SimplCount 
+   = VerySimplCount !Int       -- Used when don't want detailed stats
+
+   | SimplCount        {
+       ticks   :: !Int,        -- Total ticks
+       details :: !TickCounts, -- How many of each type
+
+       n_log   :: !Int,        -- N
+       log1    :: [Tick],      -- Last N events; <= opt_HistorySize, 
+                               --   most recent first
+       log2    :: [Tick]       -- Last opt_HistorySize events before that
+                               -- Having log1, log2 lets us accumulate the
+                               -- recent history reasonably efficiently
+     }
+
+type TickCounts = Map Tick Int
+
+simplCountN :: SimplCount -> Int
+simplCountN (VerySimplCount n)         = n
+simplCountN (SimplCount { ticks = n }) = n
+
+zeroSimplCount dflags
+               -- This is where we decide whether to do
+               -- the VerySimpl version or the full-stats version
+  | dopt Opt_D_dump_simpl_stats dflags
+  = SimplCount {ticks = 0, details = Map.empty,
+                n_log = 0, log1 = [], log2 = []}
+  | otherwise
+  = VerySimplCount 0
+
+isZeroSimplCount (VerySimplCount n)                = n==0
+isZeroSimplCount (SimplCount { ticks = n }) = n==0
+
+hasDetailedCounts (VerySimplCount {}) = False
+hasDetailedCounts (SimplCount {})     = True
+
+doFreeSimplTick tick sc@SimplCount { details = dts } 
+  = sc { details = dts `addTick` tick }
+doFreeSimplTick _ sc = sc 
+
+doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
+  | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+  | otherwise            = sc1 { n_log = nl+1, log1 = tick : l1 }
+  where
+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+
+doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
+
+
+-- Don't use Map.unionWith because that's lazy, and we want to 
+-- be pretty strict here!
+addTick :: TickCounts -> Tick -> TickCounts
+addTick fm tick = case Map.lookup tick fm of
+                       Nothing -> Map.insert tick 1 fm
+                       Just n  -> n1 `seq` Map.insert tick n1 fm
+                               where
+                                  n1 = n+1
+
+
+plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
+              sc2@(SimplCount { ticks = tks2, details = dts2 })
+  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
+  where
+       -- A hackish way of getting recent log info
+    log_base | null (log1 sc2) = sc1   -- Nothing at all in sc2
+            | null (log2 sc2) = sc2 { log2 = log1 sc1 }
+            | otherwise       = sc2
+
+plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
+plusSimplCount _                  _                  = panic "plusSimplCount"
+       -- We use one or the other consistently
+
+pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
+  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
+         blankLine,
+         pprTickCounts dts,
+         if verboseSimplStats then
+               vcat [blankLine,
+                     ptext (sLit "Log (most recent first)"),
+                     nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
+         else empty
+    ]
+
+pprTickCounts :: Map Tick Int -> SDoc
+pprTickCounts counts
+  = vcat (map pprTickGroup groups)
+  where
+    groups :: [[(Tick,Int)]]   -- Each group shares a comon tag
+                               -- toList returns common tags adjacent
+    groups = runs same_tag (Map.toList counts)
+    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
+
+pprTickGroup :: [(Tick, Int)] -> SDoc
+pprTickGroup group@((tick1,_):_)
+  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
+       2 (vcat [ int n <+> pprTickCts tick  
+               | (tick,n) <- sortLe le group])
+  where
+    le (_,n1) (_,n2) = n2 <= n1   -- We want largest first
+pprTickGroup [] = panic "pprTickGroup"
+\end{code}
+
+
+\begin{code}
+data Tick
+  = PreInlineUnconditionally   Id
+  | PostInlineUnconditionally  Id
+
+  | UnfoldingDone              Id
+  | RuleFired                  FastString      -- Rule name
+
+  | LetFloatFromLet
+  | EtaExpansion               Id      -- LHS binder
+  | EtaReduction               Id      -- Binder on outer lambda
+  | BetaReduction              Id      -- Lambda binder
+
+
+  | CaseOfCase                 Id      -- Bndr on *inner* case
+  | KnownBranch                        Id      -- Case binder
+  | CaseMerge                  Id      -- Binder on outer case
+  | AltMerge                   Id      -- Case binder
+  | CaseElim                   Id      -- Case binder
+  | CaseIdentity               Id      -- Case binder
+  | FillInCaseDefault          Id      -- Case binder
+
+  | BottomFound                
+  | SimplifierDone             -- Ticked at each iteration of the simplifier
+
+instance Outputable Tick where
+  ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+  a == b = case a `cmpTick` b of
+           EQ -> True
+           _ -> False
+
+instance Ord Tick where
+  compare = cmpTick
+
+tickToTag :: Tick -> Int
+tickToTag (PreInlineUnconditionally _) = 0
+tickToTag (PostInlineUnconditionally _)        = 1
+tickToTag (UnfoldingDone _)            = 2
+tickToTag (RuleFired _)                        = 3
+tickToTag LetFloatFromLet              = 4
+tickToTag (EtaExpansion _)             = 5
+tickToTag (EtaReduction _)             = 6
+tickToTag (BetaReduction _)            = 7
+tickToTag (CaseOfCase _)               = 8
+tickToTag (KnownBranch _)              = 9
+tickToTag (CaseMerge _)                        = 10
+tickToTag (CaseElim _)                 = 11
+tickToTag (CaseIdentity _)             = 12
+tickToTag (FillInCaseDefault _)                = 13
+tickToTag BottomFound                  = 14
+tickToTag SimplifierDone               = 16
+tickToTag (AltMerge _)                 = 17
+
+tickString :: Tick -> String
+tickString (PreInlineUnconditionally _)        = "PreInlineUnconditionally"
+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
+tickString (UnfoldingDone _)           = "UnfoldingDone"
+tickString (RuleFired _)               = "RuleFired"
+tickString LetFloatFromLet             = "LetFloatFromLet"
+tickString (EtaExpansion _)            = "EtaExpansion"
+tickString (EtaReduction _)            = "EtaReduction"
+tickString (BetaReduction _)           = "BetaReduction"
+tickString (CaseOfCase _)              = "CaseOfCase"
+tickString (KnownBranch _)             = "KnownBranch"
+tickString (CaseMerge _)               = "CaseMerge"
+tickString (AltMerge _)                        = "AltMerge"
+tickString (CaseElim _)                        = "CaseElim"
+tickString (CaseIdentity _)            = "CaseIdentity"
+tickString (FillInCaseDefault _)       = "FillInCaseDefault"
+tickString BottomFound                 = "BottomFound"
+tickString SimplifierDone              = "SimplifierDone"
+
+pprTickCts :: Tick -> SDoc
+pprTickCts (PreInlineUnconditionally v)        = ppr v
+pprTickCts (PostInlineUnconditionally v)= ppr v
+pprTickCts (UnfoldingDone v)           = ppr v
+pprTickCts (RuleFired v)               = ppr v
+pprTickCts LetFloatFromLet             = empty
+pprTickCts (EtaExpansion v)            = ppr v
+pprTickCts (EtaReduction v)            = ppr v
+pprTickCts (BetaReduction v)           = ppr v
+pprTickCts (CaseOfCase v)              = ppr v
+pprTickCts (KnownBranch v)             = ppr v
+pprTickCts (CaseMerge v)               = ppr v
+pprTickCts (AltMerge v)                        = ppr v
+pprTickCts (CaseElim v)                        = ppr v
+pprTickCts (CaseIdentity v)            = ppr v
+pprTickCts (FillInCaseDefault v)       = ppr v
+pprTickCts _                           = empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+               GT -> GT
+               EQ -> cmpEqTick a b
+               LT -> LT
+
+cmpEqTick :: Tick -> Tick -> Ordering
+cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b)    = a `compare` b
+cmpEqTick (PostInlineUnconditionally a)        (PostInlineUnconditionally b)   = a `compare` b
+cmpEqTick (UnfoldingDone a)            (UnfoldingDone b)               = a `compare` b
+cmpEqTick (RuleFired a)                        (RuleFired b)                   = a `compare` b
+cmpEqTick (EtaExpansion a)             (EtaExpansion b)                = a `compare` b
+cmpEqTick (EtaReduction a)             (EtaReduction b)                = a `compare` b
+cmpEqTick (BetaReduction a)            (BetaReduction b)               = a `compare` b
+cmpEqTick (CaseOfCase a)               (CaseOfCase b)                  = a `compare` b
+cmpEqTick (KnownBranch a)              (KnownBranch b)                 = a `compare` b
+cmpEqTick (CaseMerge a)                        (CaseMerge b)                   = a `compare` b
+cmpEqTick (AltMerge a)                 (AltMerge b)                    = a `compare` b
+cmpEqTick (CaseElim a)                 (CaseElim b)                    = a `compare` b
+cmpEqTick (CaseIdentity a)             (CaseIdentity b)                = a `compare` b
+cmpEqTick (FillInCaseDefault a)                (FillInCaseDefault b)           = a `compare` b
+cmpEqTick _                            _                               = EQ
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+             Monad and carried data structure definitions
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+newtype CoreState = CoreState {
+        cs_uniq_supply :: UniqSupply
 }
 
 data CoreReader = CoreReader {
         cr_hsc_env :: HscEnv,
         cr_rule_base :: RuleBase,
-        cr_module :: Module
+        cr_module :: Module,
+        cr_globals :: ((Bool, [String], [Way]),
+#ifdef GHCI
+                       (MVar PersistentLinkerState, Bool))
+#else
+                       ())
+#endif
 }
 
 data CoreWriter = CoreWriter {
@@ -137,23 +774,23 @@ instance MonadUnique CoreM where
         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
+runCoreM hsc_env rule_base us mod m = do
+        glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals
+        liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
   where
-    reader = CoreReader {
+    reader glbls = CoreReader {
             cr_hsc_env = hsc_env,
             cr_rule_base = rule_base,
-            cr_module = mod
+            cr_module = mod,
+            cr_globals = glbls
         }
     state = CoreState { 
-            cs_uniq_supply = us,
-            cs_ann_env = ann_env
+            cs_uniq_supply = us
         }
 
     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
@@ -161,7 +798,12 @@ runCoreM hsc_env ann_env rule_base us mod m =
 
 \end{code}
 
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%*                                                                     *
+             Core combinators, not exported
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
 
@@ -201,16 +843,17 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 
 \end{code}
 
-\subsection{Reader, writer and state accessors}
 
-\begin{code}
+%************************************************************************
+%*                                                                     *
+             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
 
@@ -222,8 +865,8 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 
 -- Convenience accessors for useful fields of HscEnv
 
-getDynFlags :: CoreM DynFlags
-getDynFlags = fmap hsc_dflags getHscEnv
+instance HasDynFlags CoreM where
+    getDynFlags = fmap hsc_dflags getHscEnv
 
 -- | The original name cache is the current mapping from 'Module' and
 -- 'OccName' to a compiler-wide unique 'Name'
@@ -231,37 +874,104 @@ getOrigNameCache :: CoreM OrigNameCache
 getOrigNameCache = do
     nameCacheRef <- fmap hsc_NC getHscEnv
     liftIO $ fmap nsNames $ readIORef nameCacheRef
-
 \end{code}
 
-\subsection{Dealing with annotations}
+%************************************************************************
+%*                                                                     *
+             Initializing globals
+%*                                                                     *
+%************************************************************************
 
-\begin{code}
+This is a rather annoying function. When a plugin is loaded, it currently
+gets linked against a *newly loaded* copy of the GHC package. This would
+not be a problem, except that the new copy has its own mutable state
+that is not shared with that state that has already been initialized by
+the original GHC package.
 
--- | 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)
+This leads to loaded plugins calling GHC code which pokes the static flags,
+and then dying with a panic because the static flags *it* sees are uninitialized.
+
+There are two possible solutions:
+  1. Export the symbols from the GHC executable from the GHC library and link
+     against this existing copy rather than a new copy of the GHC library
+  2. Carefully ensure that the global state in the two copies of the GHC
+     library matches
+
+I tried 1. and it *almost* works (and speeds up plugin load times!) except
+on Windows. On Windows the GHC library tends to export more than 65536 symbols
+(see #5292) which overflows the limit of what we can export from the EXE and
+causes breakage.
 
-addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
-addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
+(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem,
+because we could share the GHC library it links to.)
 
-addAnnotationToEnv :: Annotation -> CoreM ()
-addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
+We are going to try 2. instead. Unfortunately, this means that every plugin
+will have to say `reinitializeGlobals` before it does anything, but never mind.
 
+I've threaded the cr_globals through CoreM rather than giving them as an
+argument to the plugin function so that we can turn this function into
+(return ()) without breaking any plugins when we eventually get 1. working.
+
+\begin{code}
+reinitializeGlobals :: CoreM ()
+reinitializeGlobals = do
+    (sf_globals, linker_globals) <- read cr_globals
+    liftIO $ restoreStaticFlagGlobals sf_globals
+    liftIO $ restoreLinkerGlobals linker_globals
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+             Dealing with annotations
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | Get 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).
+--
+-- This should be done once at the start of a Core-to-Core pass that uses
+-- annotations.
+--
+-- See Note [Annotations]
+getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
+getAnnotations deserialize guts = do
+     hsc_env <- getHscEnv
+     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
+     return (deserializeAnns deserialize ann_env)
+
+-- | Get at most one annotation of a given type per Unique.
+getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
+getFirstAnnotations deserialize guts
+  = liftM (mapUFM head . filterUFM (not . null))
+  $ getAnnotations deserialize guts
+  
 \end{code}
 
-\subsection{Direct screen output}
+Note [Annotations]
+~~~~~~~~~~~~~~~~~~
+A Core-to-Core pass that wants to make use of annotations calls
+getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
+annotations of a specific type. This produces all annotations from interface
+files read so far. However, annotations from interface files read during the
+pass will not be visible until getAnnotations is called again. This is similar
+to how rules work and probably isn't too bad.
+
+The current implementation could be optimised a bit: when looking up
+annotations for a thing from the HomePackageTable, we could search directly in
+the module where the thing is defined rather than building one UniqFM which
+contains all annotations we know of. This would work because annotations can
+only be given to things defined in the same module. However, since we would
+only want to deserialise every annotation once, we would have to build a cache
+for every module in the HTP. In the end, it's probably not worth it as long as
+we aren't using annotations heavily.
+
+%************************************************************************
+%*                                                                     *
+                Direct screen output
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
 
@@ -305,7 +1015,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}
@@ -315,18 +1024,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