Better simplifier counting

[ghc-hetmet.git] / compiler / simplCore / SimplCore.lhs

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 5636fed..9eba8e1 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -15,10 +15,9 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags                ( CoreToDo(..), SimplifierSwitch(..),
-                         SimplifierMode(..), DynFlags, DynFlag(..), dopt,
-                         getCoreToDo, shouldDumpSimplPhase )
+import DynFlags                ( DynFlags, DynFlag(..), dopt )

 import CoreSyn
 import CoreSyn

+import CoreSubst

 import HscTypes
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
 import HscTypes
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,

@@ -27,25 +26,23 @@ import Rules                ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
                          addSpecInfo, addIdSpecialisations )
 import PprCore         ( pprCoreBindings, pprCoreExpr, pprRules )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )
                          addSpecInfo, addIdSpecialisations )
 import PprCore         ( pprCoreBindings, pprCoreExpr, pprRules )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )

-import IdInfo          ( setNewStrictnessInfo, newStrictnessInfo, 
-                         setUnfoldingInfo, unfoldingInfo, setSpecInfoHead,
-                         setInlinePragInfo, inlinePragInfo,
-                         setSpecInfo, specInfo, specInfoRules )
+import IdInfo

 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )

-import SimplEnv                ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
+import SimplUtils      ( simplEnvForGHCi, simplEnvForRules )
+import SimplEnv

 import SimplMonad
 import CoreMonad
 import SimplMonad
 import CoreMonad

-import qualified ErrUtils as Err        ( dumpIfSet_dyn, dumpIfSet, showPass )
-import CoreLint                ( showPass, endPass, endPassIf, endIteration )
+import qualified ErrUtils as Err 
+import CoreLint

 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
 import FamInstEnv
 import Id
 import DataCon
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
 import FamInstEnv
 import Id
 import DataCon

-import TyCon           ( tyConSelIds, tyConDataCons )
+import TyCon           ( tyConDataCons )

 import Class           ( classSelIds )
 import Class           ( classSelIds )

-import BasicTypes       ( CompilerPhase, isActive )
+import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )

 import VarSet
 import VarEnv
 import NameEnv         ( lookupNameEnv )
 import VarSet
 import VarEnv
 import NameEnv         ( lookupNameEnv )

@@ -55,19 +52,15 @@ import Specialise   ( specProgram)
 import SpecConstr      ( specConstrProgram)
 import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )
 import SpecConstr      ( specConstrProgram)
 import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )

-#ifdef OLD_STRICTNESS
-import StrictAnal      ( saBinds )
-import CprAnalyse       ( cprAnalyse )
-#endif

 import Vectorise        ( vectorise )
 import FastString
 import Util
 
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import Vectorise        ( vectorise )
 import FastString
 import Util
 
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )

-import IO              ( hPutStr, stderr )

 import Outputable
 import Control.Monad
 import Outputable
 import Control.Monad

-import List            ( partition, intersperse )
+import Data.List
+import System.IO

 import Maybes
 \end{code}
 
 import Maybes
 \end{code}
 

@@ -88,11 +81,9 @@ core2core hsc_env guts = do
     us <- mkSplitUniqSupply 's'
     let (cp_us, ru_us) = splitUniqSupply us
 
     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
     -- COMPUTE THE RULE BASE TO USE

-    (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+    -- See Note [Overall plumbing for rules] in Rules.lhs
+    (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_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
 
     -- 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

@@ -100,7 +91,7 @@ core2core hsc_env guts = do
     -- _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
     -- _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

-    (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+    (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do

         -- FIND BUILT-IN PASSES
         let builtin_core_todos = getCoreToDo dflags
 
         -- FIND BUILT-IN PASSES
         let builtin_core_todos = getCoreToDo dflags
 

@@ -121,6 +112,8 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
             -> IO CoreExpr
 -- simplifyExpr is called by the driver to simplify an
 -- expression typed in at the interactive prompt
             -> IO CoreExpr
 -- simplifyExpr is called by the driver to simplify an
 -- expression typed in at the interactive prompt

+--
+-- Also used by Template Haskell

 simplifyExpr dflags expr
   = do {
        ; Err.showPass dflags "Simplify"
 simplifyExpr dflags expr
   = do {
        ; Err.showPass dflags "Simplify"

@@ -128,7 +121,7 @@ simplifyExpr dflags expr
        ; us <-  mkSplitUniqSupply 's'
 
        ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
        ; us <-  mkSplitUniqSupply 's'
 
        ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $

-                                simplExprGently gentleSimplEnv expr
+                                simplExprGently simplEnvForGHCi expr

 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')

@@ -136,79 +129,58 @@ simplifyExpr dflags expr
        ; return expr'
        }
 
        ; return expr'
        }
 

-gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
-

 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts

-doCorePasses passes guts = foldM (flip doCorePass) guts passes
+doCorePasses passes guts 
+  = foldM do_pass guts passes
+  where
+    do_pass guts CoreDoNothing = return guts
+    do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
+    do_pass guts pass 
+       = do { dflags <- getDynFlags
+                   ; liftIO $ showPass dflags pass
+                   ; guts' <- doCorePass pass guts
+                   ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
+                   ; return guts' }

 
 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
 
 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts

-doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
-                                       simplifyPgm mode sws
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass

 
 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
 
 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   

-                                      describePass "Common sub-expression" Opt_D_dump_cse $ 

                                       doPass cseProgram
 
 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                       doPass cseProgram
 
 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}

-                                      describePass "Liberate case" Opt_D_verbose_core2core $ 

                                        doPassD liberateCase
 
 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
                                        doPassD liberateCase
 
 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}

-                                       describePass "Float inwards" Opt_D_verbose_core2core $ 

                                        doPass floatInwards
 
 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                        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" #-}
                                        doPassDUM (floatOutwards f)
 
 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}

-                                       describePass "Static argument" Opt_D_verbose_core2core $ 

                                        doPassU doStaticArgs
 
 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
                                        doPassU doStaticArgs
 
 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}

-                                       describePass "Demand analysis" Opt_D_dump_stranal $

                                        doPassDM dmdAnalPgm
 
 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                        doPassDM dmdAnalPgm
 
 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}

-                                       describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $

                                        doPassU wwTopBinds
 
 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                        doPassU wwTopBinds
 
 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}

-                                       describePassR "Specialise" Opt_D_dump_spec $ 

                                        doPassU specProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        doPassU specProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}

-                                       describePassR "SpecConstr" Opt_D_dump_spec $
-                                       doPassDU  specConstrProgram
+                                       specConstrProgram

 
 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
 
 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}

-                                       describePass "Vectorisation" Opt_D_dump_vect $ 

                                        vectorise be
 
                                        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 CoreDoGlomBinds              = doPassDM  glomBinds
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat

 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes

-
-#ifdef OLD_STRICTNESS
-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
-

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -218,39 +190,14 @@ doOldStrictness guts
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
 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"
     rb <- getRuleBase
     dflags <- getDynFlags
     liftIO $ Err.showPass dflags "RuleCheck"

-    liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
+    liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))

     return guts
 
 
     return guts
 
 

@@ -334,7 +281,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
        ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
                -- from the local binders, to avoid warnings from Simplify.simplVar
              local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
        ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
                -- from the local binders, to avoid warnings from Simplify.simplVar
              local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))

-             env              = setInScopeSet gentleSimplEnv local_ids 
+             env              = setInScopeSet simplEnvForRules local_ids 

              (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
                                 mapM (simplRule env) local_rules
 
              (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
                                 mapM (simplRule env) local_rules
 

@@ -342,18 +289,16 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 
              home_pkg_rules = hptRules hsc_env (dep_mods deps)
              hpt_rule_base  = mkRuleBase home_pkg_rules
 
              home_pkg_rules = hptRules hsc_env (dep_mods deps)
              hpt_rule_base  = mkRuleBase home_pkg_rules

-             imp_rule_base  = extendRuleBaseList hpt_rule_base rules_for_imps
-
-             binds_w_rules = updateBinders rules_for_locals binds
+             binds_w_rules  = updateBinders rules_for_locals binds

 
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
 
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $

-                vcat [text "Local rules", pprRules simpl_rules,
-                      text "",
-                      text "Imported rules", pprRuleBase imp_rule_base])
+                vcat [text "Local rules for local Ids", pprRules simpl_rules,
+                      blankLine,
+                      text "Local rules for imported Ids", pprRuleBase hpt_rule_base])

 
 

-       ; return (imp_rule_base, guts { mg_binds = binds_w_rules, 
+       ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, 

                                        mg_rules = rules_for_imps })
     }
 
                                        mg_rules = rules_for_imps })
     }
 

@@ -412,13 +357,15 @@ The simplifier does indeed do eta reduction (it's in
 Simplify.completeLam) but only if -O is on.
 
 \begin{code}
 Simplify.completeLam) but only if -O is on.
 
 \begin{code}

+simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule

 simplRule env rule@(BuiltinRule {})
   = return rule
 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
   = do (env, bndrs') <- simplBinders env bndrs
        args' <- mapM (simplExprGently env) args
        rhs' <- simplExprGently env rhs
 simplRule env rule@(BuiltinRule {})
   = return rule
 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
   = do (env, bndrs') <- simplBinders env bndrs
        args' <- mapM (simplExprGently env) args
        rhs' <- simplExprGently env rhs

-       return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
+       return (rule { ru_bndrs = bndrs', ru_args = args'
+                    , ru_rhs = occurAnalyseExpr rhs' })

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -495,79 +442,81 @@ glomBinds dflags binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
-simplifyPgm mode switches
-  = describePassD doc Opt_D_dump_simpl_phases $ \guts -> 
-    do { hsc_env <- getHscEnv
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv

        ; us <- getUniqueSupplyM
        ; rb <- getRuleBase
        ; 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
-           -> FamInstEnv
-           -> [CoreBind]
-           -> IO (SimplCount, [CoreBind])  -- New bindings
-
-simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
-  = do {
-       (termination_msg, it_count, counts_out, binds') 
-          <- do_iteration us 1 (zeroSimplCount dflags) binds ;
-
-       Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+       ; liftIOWithCount $  
+                simplifyPgmIO pass hsc_env us rb guts }
+
+simplifyPgmIO :: CoreToDo
+             -> HscEnv
+             -> UniqSupply
+             -> RuleBase
+             -> ModGuts
+             -> IO (SimplCount, ModGuts)  -- New bindings
+
+simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+              hsc_env us hpt_rule_base 
+              guts@(ModGuts { mg_binds = binds, mg_rules = rules
+                            , mg_fam_inst_env = fam_inst_env })
+  = do { (termination_msg, it_count, counts_out, guts') 
+          <- do_iteration us 1 [] binds rules 
+
+       ; 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",
                  "Simplifier statistics for following pass"
                  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",

-                        text "",
-                        pprSimplCount counts_out]);
+                        blankLine,
+                        pprSimplCount counts_out])

 
 

-       return (counts_out, binds')
+       ; return (counts_out, guts')

     }
   where
     }
   where

-    dflags        = hsc_dflags hsc_env
-                  
-    sw_chkr       = isAmongSimpl switches
-    max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
- 
-    do_iteration us iteration_no counts binds
+    dflags              = hsc_dflags hsc_env
+    dump_phase          = dumpSimplPhase dflags mode
+    sw_chkr     = isAmongSimpl switches
+    do_iteration :: UniqSupply
+                 -> Int                 -- Counts iterations
+                -> [SimplCount] -- Counts from earlier iterations, reversed
+                -> [CoreBind]   -- Bindings in
+                -> [CoreRule]   -- and orphan rules
+                -> IO (String, Int, SimplCount, ModGuts)
+
+    do_iteration us iteration_no counts_so_far binds rules

        -- iteration_no is the number of the iteration we are
        -- about to begin, with '1' for the first
       | iteration_no > max_iterations  -- Stop if we've run out of iterations
        -- iteration_no is the number of the iteration we are
        -- about to begin, with '1' for the first
       | iteration_no > max_iterations  -- Stop if we've run out of iterations

-      =  WARN(debugIsOn && (max_iterations > 2),
-                text ("Simplifier still going after " ++
-                               show max_iterations ++
-                               " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
+      = WARN( debugIsOn && (max_iterations > 2)
+            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
+              <+> ptext (sLit "iterations") 
+              <+> brackets (pprWithCommas (int . simplCountN) (reverse counts_so_far))
+              <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
+

                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed

-           return ("Simplifier bailed out", iteration_no - 1, counts, binds)
+       return ("Simplifier baled out", iteration_no - 1, total_counts, 
+                 guts { mg_binds = binds, mg_rules = rules })

 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
       | let sz = coreBindsSize binds in sz == sz
       = do {
                -- Occurrence analysis
 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
       | let sz = coreBindsSize binds in sz == sz
       = do {
                -- Occurrence analysis

-          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
+          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;

           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 
                -- Get any new rules, and extend the rule base
           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 
                -- Get any new rules, and extend the rule base

+               -- See Note [Overall plumbing for rules] in Rules.lhs

                -- We need to do this regularly, because simplification can
                -- poke on IdInfo thunks, which in turn brings in new rules
                -- behind the scenes.  Otherwise there's a danger we'll simply
                -- miss the rules for Ids hidden inside imported inlinings
           eps <- hscEPS hsc_env ;
                -- We need to do this regularly, because simplification can
                -- poke on IdInfo thunks, which in turn brings in new rules
                -- behind the scenes.  Otherwise there's a danger we'll simply
                -- miss the rules for Ids hidden inside imported inlinings
           eps <- hscEPS hsc_env ;

-          let  { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
-               ; simpl_env  = mkSimplEnv mode sw_chkr 
+          let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
+               ; rule_base2 = extendRuleBaseList rule_base1 rules
+               ; simpl_env  = mkSimplEnv sw_chkr mode

                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;

@@ -578,24 +527,22 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                -- With a let, we ended up with
                --   let
                --      t = initSmpl ...
                -- With a let, we ended up with
                --   let
                --      t = initSmpl ...

-               --      counts' = snd t
+               --      counts1 = snd t

                --   in
                --   in

-               --      case t of {(_,counts') -> if counts'=0 then ... }
-               -- So the conditional didn't force counts', because the
+               --      case t of {(_,counts1) -> if counts1=0 then ... }
+               -- So the conditional didn't force counts1, because the

                -- selection got duplicated.  Sigh!
                -- selection got duplicated.  Sigh!

-          case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
-               (binds', counts') -> do {
+          case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
+               (env1, counts1) -> do {

 
 

-          let  { all_counts = counts `plusSimplCount` counts'
-               ; herald     = "Simplifier mode " ++ showPpr mode ++ 
-                             ", iteration " ++ show iteration_no ++
-                             " out of " ++ show max_iterations
+          let  { binds1 = getFloats env1
+                ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules

                } ;
 
                -- Stop if nothing happened; don't dump output
                } ;
 
                -- Stop if nothing happened; don't dump output

-          if isZeroSimplCount counts' then
-               return ("Simplifier reached fixed point", iteration_no, 
-                       all_counts, binds')
+          if isZeroSimplCount counts1 then
+               return ("Simplifier reached fixed point", iteration_no, total_counts,
+                       guts { mg_binds = binds1, mg_rules = rules1 })

           else do {
                -- Short out indirections
                -- We do this *after* at least one run of the simplifier 
           else do {
                -- Short out indirections
                -- We do this *after* at least one run of the simplifier 

@@ -605,18 +552,31 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                --
                -- ToDo: alas, this means that indirection-shorting does not happen at all
                --       if the simplifier does nothing (not common, I know, but unsavoury)
                --
                -- ToDo: alas, this means that indirection-shorting does not happen at all
                --       if the simplifier does nothing (not common, I know, but unsavoury)

-          let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
+          let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;

 
                -- Dump the result of this iteration
 
                -- Dump the result of this iteration

-          Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
-                        (pprSimplCount counts') ;
-          endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
+          end_iteration dflags pass iteration_no counts1 binds2 rules1 ;

 
                -- Loop
 
                -- Loop

-          do_iteration us2 (iteration_no + 1) all_counts binds''
+          do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1

        }  } } }
       where
        }  } } }
       where

-         (us1, us2) = splitUniqSupply us
+       (us1, us2) = splitUniqSupply us
+
+       -- Remember the counts_so_far are reversed
+        total_counts = foldr (\c acc -> acc `plusSimplCount` c) 
+                             (zeroSimplCount dflags) counts_so_far
+
+-------------------
+end_iteration :: DynFlags -> CoreToDo -> Int 
+             -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
+-- Same as endIteration but with simplifier counts
+end_iteration dflags pass iteration_no counts binds rules
+  = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
+                   pass (ptext (sLit "Simplifier counts"))
+                  (pprSimplCount counts)
+
+       ; endIteration dflags pass iteration_no binds rules }

 \end{code}
 
 
 \end{code}
 
 

@@ -643,23 +603,21 @@ save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 makes strictness information propagate better.  This used to happen in
 the final phase, but it's tidier to do it here.
 
 makes strictness information propagate better.  This used to happen in
 the final phase, but it's tidier to do it here.
 

+Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to propagage any useful IdInfo on x_local to x_exported.
+

 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 
 RULES: we want to *add* any RULES for x_local to x_exported.
 
 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 
 RULES: we want to *add* any RULES for x_local to x_exported.
 

-Note [Rules and indirection-zapping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Problem: what if x_exported has a RULE that mentions something in ...bindings...?
-Then the things mentioned can be out of scope!  Solution
- a) Make sure that in this pass the usage-info from x_exported is 
-       available for ...bindings...
- b) If there are any such RULES, rec-ify the entire top-level. 
-    It'll get sorted out next time round

 
 

-Messing up the rules
-~~~~~~~~~~~~~~~~~~~~
-The example that went bad on me at one stage was this one:
+Note [Messing up the exported Id's RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must be careful about discarding (obviously) or even merging the
+RULES on the exported Id. The example that went bad on me at one stage
+was this one:

        
     iterate :: (a -> a) -> a -> [a]
        [Exported]
        
     iterate :: (a -> a) -> a -> [a]
        [Exported]

@@ -692,13 +650,28 @@ And now we get an infinite loop in the rule system
                    -> iterateFB (:) f x
                    -> iterate f x
 
                    -> iterateFB (:) f x
                    -> iterate f x
 

-Tiresome old solution: 
-       don't do shorting out if f has rewrite rules (see shortableIdInfo)
-
-New solution (I think): 
+Old "solution": 

        use rule switching-off pragmas to get rid 
        of iterateList in the first place
 
        use rule switching-off pragmas to get rid 
        of iterateList in the first place
 

+But in principle the user *might* want rules that only apply to the Id
+he says.  And inline pragmas are similar
+   {-# NOINLINE f #-}
+   f = local
+   local = <stuff>
+Then we do not want to get rid of the NOINLINE.
+
+Hence hasShortableIdinfo.
+
+
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope!  Solution
+ a) Make sure that in this pass the usage-info from x_exported is 
+       available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level. 
+    It'll get sorted out next time round

 
 Other remarks
 ~~~~~~~~~~~~~
 
 Other remarks
 ~~~~~~~~~~~~~

@@ -769,6 +742,7 @@ makeIndEnv binds
     add_pair (exported_id, rhs) env
        = env
                        
     add_pair (exported_id, rhs) env
        = env
                        

+-----------------

 shortMeOut ind_env exported_id local_id
 -- The if-then-else stuff is just so I can get a pprTrace to see
 -- how often I don't get shorting out becuase of IdInfo stuff
 shortMeOut ind_env exported_id local_id
 -- The if-then-else stuff is just so I can get a pprTrace to see
 -- how often I don't get shorting out becuase of IdInfo stuff

@@ -783,23 +757,27 @@ shortMeOut ind_env exported_id local_id
    
        not (local_id `elemVarEnv` ind_env)     -- Only if not already substituted for
     then
    
        not (local_id `elemVarEnv` ind_env)     -- Only if not already substituted for
     then

-       True
-
-{- No longer needed
-       if isEmptySpecInfo (specInfo (idInfo exported_id))      -- Only if no rules
-       then True       -- See note on "Messing up rules"
-       else 
-#ifdef DEBUG 
-          pprTrace "shortMeOut:" (ppr exported_id)
-#endif
-                                                False
--}
+       if hasShortableIdInfo exported_id
+       then True       -- See Note [Messing up the exported Id's IdInfo]
+       else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
+             False

     else
     else

-       False
+        False

 
 

+-----------------
+hasShortableIdInfo :: Id -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+hasShortableIdInfo id
+  =  isEmptySpecInfo (specInfo info)
+  && isDefaultInlinePragma (inlinePragInfo info)
+  where
+     info = idInfo id

 
 -----------------
 transferIdInfo :: Id -> Id -> Id
 
 -----------------
 transferIdInfo :: Id -> Id -> Id

+-- See Note [Transferring IdInfo]

 -- If we have
 --     lcl_id = e; exp_id = lcl_id
 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 -- If we have
 --     lcl_id = e; exp_id = lcl_id
 -- and lcl_id has useful IdInfo, we don't want to discard it by going

@@ -810,7 +788,7 @@ transferIdInfo exported_id local_id
   = modifyIdInfo transfer exported_id
   where
     local_info = idInfo local_id
   = modifyIdInfo transfer exported_id
   where
     local_info = idInfo local_id

-    transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+    transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info

                                 `setUnfoldingInfo`     unfoldingInfo local_info
                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
                                 `setUnfoldingInfo`     unfoldingInfo local_info
                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info