Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / simplCore / CoreMonad.lhs
index 7f43ce5..ab69916 100644 (file)
@@ -4,19 +4,30 @@
 \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(..),
+    CoreToDo(..), runWhen, runMaybe,
     SimplifierMode(..),
-    SimplifierSwitch(..),
     FloatOutSwitches(..),
-    getCoreToDo, dumpSimplPhase,
+    dumpSimplPhase, pprPassDetails, 
+
+    -- * Plugins
+    PluginPass, Plugin(..), CommandLineOption, 
+    defaultPlugin, bindsOnlyPass,
 
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
-    pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
+    pprSimplCount, plusSimplCount, zeroSimplCount, 
+    isZeroSimplCount, hasDetailedCounts, Tick(..),
 
     -- * The monad
     CoreM, runCoreM,
@@ -32,11 +43,14 @@ module CoreMonad (
     liftIO, liftIOWithCount,
     liftIO1, liftIO2, liftIO3, liftIO4,
     
+    -- ** Global initialization
+    reinitializeGlobals,
+    
     -- ** Dealing with annotations
     getAnnotations, getFirstAnnotations,
     
     -- ** Debug output
-    showPass, endPass, endIteration, dumpIfSet,
+    showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet,
 
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
@@ -59,11 +73,11 @@ import CoreUtils
 import CoreLint                ( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes
-import Module           ( PackageId, Module )
+import Module           ( Module )
 import DynFlags
 import StaticFlags     
 import Rules            ( RuleBase )
-import BasicTypes      ( CompilerPhase )
+import BasicTypes       ( CompilerPhase(..) )
 import Annotations
 import Id              ( Id )
 
@@ -79,20 +93,31 @@ import Bag
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
-import FiniteMap
+import MonadUtils
 
-import Util            ( split )
+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 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}
 
@@ -110,52 +135,56 @@ stuff before and after core passes, and do Core Lint when necessary.
 showPass :: DynFlags -> CoreToDo -> IO ()
 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 
-endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
-endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
-
--- Same as endPass but doesn't dump Core even with -dverbose-core2core
-endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
-endIteration dflags pass n
-  = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
-                (Just Opt_D_dump_simpl_iterations)
+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
 
-dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
-            -> [CoreBind] -> [CoreRule] -> IO ()
--- The "show_all" parameter says to print dump if -dverbose-core2core is on
-dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
-  = do {  -- Report result size if required
+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
-       ; Err.debugTraceMsg dflags 2 $
-               (text "    Result size =" <+> int (coreBindsSize binds))
-
-       -- Report verbosely, if required
-       ; let pass_name = showSDoc (ppr pass <+> extra_info)
-             dump_doc  = pprCoreBindings binds 
-                         $$ ppUnless (null rules) pp_rules
-
-       ; case mb_dump_flag of
-            Nothing        -> return ()
-            Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
-               where
-                 dump_flags | show_all  = [dump_flag, Opt_D_verbose_core2core]
-                           | otherwise = [dump_flag] 
-
-       -- Type check
-       ; when (dopt Opt_DoCoreLinting dflags) $
-         do { let (warns, errs) = lintCoreBindings binds
-            ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
-            ; displayLintResults dflags pass warns errs binds  } }
+
   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 -> [CoreBind]
+                   -> Bag Err.Message -> Bag Err.Message -> CoreProgram
                    -> IO ()
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
@@ -184,8 +213,8 @@ displayLintResults dflags pass warns errs binds
 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 (SimplGently {}) _ _) = False
-showLintWarnings _                                     = True
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
 \end{code}
 
 
@@ -197,15 +226,15 @@ showLintWarnings _                                     = True
 %************************************************************************
 
 \begin{code}
+
 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
-       Int                    -- Max iterations
-        [SimplifierSwitch]     -- Each run of the simplifier can take a different
-                               -- set of simplifier-specific flags.
+  | CoreDoPluginPass String PluginPass
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
@@ -215,22 +244,26 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
   | CoreDoSpecConstr
-  | CoreDoGlomBinds
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
-  | CoreDoVectorisation PackageId
+  | CoreDoVectorisation
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
-  | CoreDesugar         -- Not strictly a core-to-core pass, but produces
-                 -- Core output, and hence useful to pass to endPass
+  | 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
@@ -240,21 +273,20 @@ 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 CoreTidy                = Just Opt_D_dump_simpl
-coreDumpFlag CorePrep                = Just Opt_D_dump_prep
+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 CoreDoGlomBinds         = Nothing
 coreDumpFlag (CoreDoPasses {})       = Nothing
 
 instance Outputable CoreToDo where
-  ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier") 
-                                 <+> ppr md
-                                 <+> ptext (sLit "max-iterations=") <> int n
+  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")
@@ -264,227 +296,73 @@ instance Outputable CoreToDo where
   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")
-  ppr CoreTidy                        = ptext (sLit "Tidy Core")
+  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 CoreDoGlomBinds          = ptext (sLit "Glom binds")
   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
-  = SimplGently
-       { sm_rules :: Bool      -- Whether RULES are enabled 
-        , sm_inline :: Bool }  -- Whether inlining is enabled
-
-  | SimplPhase 
-        { sm_num :: Int          -- Phase number; counts downward so 0 is last phase
-        , sm_names :: [String] }  -- Name(s) of the phase
+  = 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 (SimplPhase { sm_num = n, sm_names = ss })
-       = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
-    ppr (SimplGently { sm_rules = r, sm_inline = i }) 
-       = ptext (sLit "gentle") <> 
-           brackets (pp_flag r (sLit "rules") <> comma <>
-                     pp_flag i (sLit "inline"))
+    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
-
-data SimplifierSwitch
-  = NoCaseOfCase
 \end{code}
 
 
 \begin{code}
 data FloatOutSwitches = FloatOutSwitches {
-        floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
-        floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
-                                     --            even if they do not escape a lambda
-    }
+  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 = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
-                     <+> pp_not (floatOutConstants sw) <+> text "constants"
-  where
-    pp_not True  = empty
-    pp_not False = text "not"
-
--- | Switches that specify the minimum amount of floating out
--- gentleFloatOutSwitches :: FloatOutSwitches
--- gentleFloatOutSwitches = FloatOutSwitches False False
-
--- | Switches that do not specify floating out of lambdas, just of constants
-constantsOnlyFloatOutSwitches :: FloatOutSwitches
-constantsOnlyFloatOutSwitches = FloatOutSwitches False True
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-           Generating the main optimisation pipeline
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-getCoreToDo :: DynFlags -> [CoreToDo]
-getCoreToDo dflags
-  = core_todo
-  where
-    opt_level     = optLevel dflags
-    phases        = simplPhases dflags
-    max_iter      = maxSimplIterations dflags
-    strictness    = dopt Opt_Strictness dflags
-    full_laziness = dopt Opt_FullLaziness dflags
-    do_specialise = dopt Opt_Specialise dflags
-    do_float_in   = dopt Opt_FloatIn dflags
-    cse           = dopt Opt_CSE dflags
-    spec_constr   = dopt Opt_SpecConstr dflags
-    liberate_case = dopt Opt_LiberateCase dflags
-    rule_check    = ruleCheck dflags
-    static_args   = dopt Opt_StaticArgumentTransformation dflags
-
-    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
-
-    maybe_strictness_before phase
-      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
-
-    simpl_phase phase names iter
-      = CoreDoPasses
-          [ maybe_strictness_before phase
-          , CoreDoSimplify (SimplPhase phase names) 
-                           iter []
-          , maybe_rule_check phase
-          ]
-
-    vectorisation
-      = runWhen (dopt Opt_Vectorise dflags)
-        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
-
-
-                -- By default, we have 2 phases before phase 0.
-
-                -- Want to run with inline phase 2 after the specialiser to give
-                -- maximum chance for fusion to work before we inline build/augment
-                -- in phase 1.  This made a difference in 'ansi' where an
-                -- overloaded function wasn't inlined till too late.
-
-                -- Need phase 1 so that build/augment get
-                -- inlined.  I found that spectral/hartel/genfft lost some useful
-                -- strictness in the function sumcode' if augment is not inlined
-                -- before strictness analysis runs
-    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
-                                  | phase <- [phases, phases-1 .. 1] ]
-
-
-        -- initial simplify: mk specialiser happy: minimum effort please
-    simpl_gently = CoreDoSimplify 
-                       (SimplGently { sm_rules = True, sm_inline = False })
-                         -- See Note [Gentle mode] and
-                         -- Note [RULEs enabled in SimplGently] in SimplUtils
-                       max_iter
-                       [
-
-
-            NoCaseOfCase        -- Don't do case-of-case transformations.
-                                -- This makes full laziness work better
-        ]
-
-    core_todo =
-     if opt_level == 0 then
-       [vectorisation,
-        simpl_phase 0 ["final"] max_iter]
-     else {- opt_level >= 1 -} [
-
-    -- We want to do the static argument transform before full laziness as it
-    -- may expose extra opportunities to float things outwards. However, to fix
-    -- up the output of the transformation we need at do at least one simplify
-    -- after this before anything else
-        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
-
-        -- We run vectorisation here for now, but we might also try to run
-        -- it later
-        vectorisation,
-
-        -- initial simplify: mk specialiser happy: minimum effort please
-        simpl_gently,
-
-        -- Specialisation is best done before full laziness
-        -- so that overloaded functions have all their dictionary lambdas manifest
-        runWhen do_specialise CoreDoSpecialising,
-
-        runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
-               -- Was: gentleFloatOutSwitches  
-               -- I have no idea why, but not floating constants to top level is
-               -- very bad in some cases. 
-               -- Notably: p_ident in spectral/rewrite
-               --          Changing from "gentle" to "constantsOnly" improved
-               --          rewrite's allocation by 19%, and made  0.0% difference
-               --          to any other nofib benchmark
-
-        runWhen do_float_in CoreDoFloatInwards,
-
-        simpl_phases,
-
-                -- Phase 0: allow all Ids to be inlined now
-                -- This gets foldr inlined before strictness analysis
-
-                -- At least 3 iterations because otherwise we land up with
-                -- huge dead expressions because of an infelicity in the
-                -- simpifier.
-                --      let k = BIG in foldr k z xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
-                -- Don't stop now!
-        simpl_phase 0 ["main"] (max max_iter 3),
-
-        runWhen strictness (CoreDoPasses [
-                CoreDoStrictness,
-                CoreDoWorkerWrapper,
-                CoreDoGlomBinds,
-                simpl_phase 0 ["post-worker-wrapper"] max_iter
-                ]),
-
-        runWhen full_laziness
-          (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
-                -- nofib/spectral/hartel/wang doubles in speed if you
-                -- do full laziness late in the day.  It only happens
-                -- after fusion and other stuff, so the early pass doesn't
-                -- catch it.  For the record, the redex is
-                --        f_el22 (f_el21 r_midblock)
-
-
-        runWhen cse CoreCSE,
-                -- We want CSE to follow the final full-laziness pass, because it may
-                -- succeed in commoning up things floated out by full laziness.
-                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
-
-        runWhen do_float_in CoreDoFloatInwards,
-
-        maybe_rule_check 0,
-
-                -- Case-liberation for -O2.  This should be after
-                -- strictness analysis and the simplification which follows it.
-        runWhen liberate_case (CoreDoPasses [
-            CoreLiberateCase,
-            simpl_phase 0 ["post-liberate-case"] max_iter
-            ]),         -- Run the simplifier after LiberateCase to vastly
-                        -- reduce the possiblility of shadowing
-                        -- Reason: see Note [Shadowing] in SpecConstr.lhs
-
-        runWhen spec_constr CoreDoSpecConstr,
-
-        maybe_rule_check 0,
-
-        -- Final clean-up simplification:
-        simpl_phase 0 ["final"] max_iter
-     ]
+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
@@ -495,6 +373,7 @@ 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
@@ -515,14 +394,70 @@ dumpSimplPhase dflags mode
                 _        -> phase_name s
 
     phase_num :: Int -> Bool
-    phase_num n = case mode of
-                    SimplPhase k _ -> n == k
-                    _              -> False
+    phase_num n = case sm_phase mode of
+                    Phase k -> n == k
+                    _       -> False
 
     phase_name :: String -> Bool
-    phase_name s = case mode of
-                     SimplGently {}               -> s == "gentle"
-                     SimplPhase { sm_names = ss } -> s `elem` ss
+    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}
 
 
@@ -538,6 +473,7 @@ 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
@@ -559,7 +495,7 @@ data SimplCount
                                -- recent history reasonably efficiently
      }
 
-type TickCounts = FiniteMap Tick Int
+type TickCounts = Map Tick Int
 
 simplCountN :: SimplCount -> Int
 simplCountN (VerySimplCount n)         = n
@@ -569,7 +505,7 @@ 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 = emptyFM,
+  = SimplCount {ticks = 0, details = Map.empty,
                 n_log = 0, log1 = [], log2 = []}
   | otherwise
   = VerySimplCount 0
@@ -577,6 +513,9 @@ zeroSimplCount dflags
 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 
@@ -590,19 +529,19 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 =
 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 
 
--- Don't use plusFM_C because that's lazy, and we want to 
+-- 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 lookupFM fm tick of
-                       Nothing -> addToFM fm tick 1
-                       Just n  -> n1 `seq` addToFM fm tick n1
+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 = plusFM_C (+) dts1 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
@@ -617,7 +556,7 @@ 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 (fmToList dts),
+         pprTickCounts dts,
          if verboseSimplStats then
                vcat [blankLine,
                      ptext (sLit "Log (most recent first)"),
@@ -625,23 +564,23 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
          else empty
     ]
 
-pprTickCounts :: [(Tick,Int)] -> SDoc
-pprTickCounts [] = empty
-pprTickCounts ((tick1,n1):ticks)
-  = vcat [int tot_n <+> text (tickString tick1),
-         pprTCDetails real_these,
-         pprTickCounts others
-    ]
+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
-    tick1_tag          = tickToTag tick1
-    (these, others)    = span same_tick ticks
-    real_these         = (tick1,n1):these
-    same_tick (tick2,_) = tickToTag tick2 == tick1_tag
-    tot_n              = sum [n | (_,n) <- real_these]
-
-pprTCDetails :: [(Tick, Int)] -> SDoc
-pprTCDetails ticks
-  = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+    le (_,n1) (_,n2) = n2 <= n1   -- We want largest first
+pprTickGroup [] = panic "pprTickGroup"
 \end{code}
 
 
@@ -776,7 +715,13 @@ newtype CoreState = CoreState {
 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 {
@@ -834,13 +779,15 @@ runCoreM :: HscEnv
          -> Module
          -> CoreM a
          -> IO (a, SimplCount)
-runCoreM hsc_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
@@ -904,7 +851,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 %************************************************************************
 
 \begin{code}
-
 getHscEnv :: CoreM HscEnv
 getHscEnv = read cr_hsc_env
 
@@ -919,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'
@@ -928,9 +874,51 @@ getOrigNameCache :: CoreM OrigNameCache
 getOrigNameCache = do
     nameCacheRef <- fmap hsc_NC getHscEnv
     liftIO $ fmap nsNames $ readIORef nameCacheRef
-
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+             Initializing globals
+%*                                                                     *
+%************************************************************************
+
+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.
+
+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.
+
+(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.)
+
+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}
 
 %************************************************************************
 %*                                                                     *