Added a VECTORISE pragma
[ghc-hetmet.git] / compiler / simplCore / SimplCore.lhs
index 2770784..1a634d5 100644 (file)
@@ -8,54 +8,43 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
-import DynFlags                ( CoreToDo(..), SimplifierSwitch(..),
-                         SimplifierMode(..), DynFlags, DynFlag(..), dopt,
-                         getCoreToDo )
+import DynFlags                ( DynFlags, DynFlag(..), dopt )
 import CoreSyn
 import CoreSyn
-import HscTypes                ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
-                         Dependencies( dep_mods ), 
-                         hscEPS, hptRules )
+import CoreSubst
+import HscTypes
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
-                         extendRuleBaseList, pprRuleBase, ruleCheckProgram,
-                         addSpecInfo, addIdSpecialisations )
-import PprCore         ( pprCoreBindings, pprCoreExpr, pprRules )
+                         extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
+import PprCore         ( pprCoreBindings, pprCoreExpr )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )
-import IdInfo          ( setNewStrictnessInfo, newStrictnessInfo, 
-                         setWorkerInfo, workerInfo,
-                         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, activeRule )
+import SimplEnv
 import SimplMonad
 import SimplMonad
-import ErrUtils                ( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint                ( endPass )
+import CoreMonad
+import qualified ErrUtils as Err 
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
 import FamInstEnv
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
 import FamInstEnv
-import Id              ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
-                         idSpecialisation, idName )
+import Id
+import BasicTypes       ( CompilerPhase, isDefaultInlinePragma )
 import VarSet
 import VarEnv
 import VarSet
 import VarEnv
-import NameEnv         ( lookupNameEnv )
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
 import SpecConstr      ( specConstrProgram)
 import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
 import SpecConstr      ( specConstrProgram)
 import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )
-#ifdef OLD_STRICTNESS
-import StrictAnal      ( saBinds )
-import CprAnalyse       ( cprAnalyse )
-#endif
 import Vectorise        ( vectorise )
 import Vectorise        ( vectorise )
+import FastString
+import Util
 
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
-import IO              ( hPutStr, stderr )
 import Outputable
 import Outputable
-import List            ( partition )
-import Maybes          ( orElse )
+import Control.Monad
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -65,252 +54,171 @@ import Maybes             ( orElse )
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-core2core :: HscEnv
-         -> ModGuts
-         -> IO ModGuts
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts 
+  = do { us <- mkSplitUniqSupply 's'
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ 
+                           doCorePasses (getCoreToDo dflags) guts
 
 
-core2core hsc_env guts
-  = do
-        let dflags = hsc_dflags hsc_env
-           core_todos = getCoreToDo dflags
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+             "Grand total simplifier statistics"
+             (pprSimplCount stats)
 
 
-       us <- mkSplitUniqSupply 's'
-       let (cp_us, ru_us) = splitUniqSupply us
+       ; return guts2 }
+  where
+    dflags         = hsc_dflags hsc_env
+    home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
+    hpt_rule_base  = mkRuleBase home_pkg_rules
+    mod            = mg_module guts
+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
+    -- This is very convienent for the users of the monad (e.g. plugins do not have to
+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
+    -- would mean our cached value would go out of date.
+
+
+type CorePass = CoreToDo
+
+doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
+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' }
 
 
-               -- COMPUTE THE RULE BASE TO USE
-       (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
+doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass
 
 
-               -- DO THE BUSINESS
-       (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
-                                       (zeroSimplCount dflags) 
-                                       guts' core_todos
+doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
+                                      doPass cseProgram
 
 
-       dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
-                 "Grand total simplifier statistics"
-                 (pprSimplCount stats)
+doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+                                       doPassD liberateCase
 
 
-       return guts''
+doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                       doPass floatInwards
 
 
+doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                       doPassDUM (floatOutwards f)
 
 
-simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-            -> CoreExpr
-            -> IO CoreExpr
--- simplifyExpr is called by the driver to simplify an
--- expression typed in at the interactive prompt
-simplifyExpr dflags expr
-  = do {
-       ; showPass dflags "Simplify"
+doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                       doPassU doStaticArgs
 
 
-       ; us <-  mkSplitUniqSupply 's'
+doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
+                                       doPassDM dmdAnalPgm
 
 
-       ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                simplExprGently gentleSimplEnv expr
+doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                       doPassU wwTopBinds
 
 
-       ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
-                       (pprCoreExpr expr')
+doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                       specProgram
 
 
-       ; return expr'
-       }
+doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                       specConstrProgram
 
 
-gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
-
-doCorePasses :: HscEnv
-             -> RuleBase        -- the imported main rule base
-             -> UniqSupply      -- uniques
-            -> SimplCount      -- simplifier stats
-             -> ModGuts                -- local binds in (with rules attached)
-             -> [CoreToDo]      -- which passes to do
-             -> IO (SimplCount, ModGuts)
-
-doCorePasses hsc_env rb us stats guts []
-  = return (stats, guts)
-
-doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) 
-  = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2) 
-
-doCorePasses hsc_env rb us stats guts (to_do : to_dos) 
-  = do
-       let (us1, us2) = splitUniqSupply us
-       (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
-       doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
-
-doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
-          -> ModGuts -> IO (SimplCount, ModGuts)
-doCorePass (CoreDoSimplify mode sws)   = {-# SCC "Simplify" #-}      simplifyPgm mode sws
-doCorePass CoreCSE                    = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
-doCorePass CoreLiberateCase           = {-# SCC "LiberateCase" #-}  liberateCase
-doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
-doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs           = {-# SCC "StaticArgs" #-}    trBinds  doStaticArgs
-doCorePass CoreDoStrictness           = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
-doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
-doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
-doCorePass CoreDoSpecConstr           = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
-doCorePass CoreDoGlomBinds            = trBinds glomBinds
-doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
-doCorePass CoreDoPrintCore            = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
-doCorePass CoreDoNothing              = observe (\ _ _ -> return ())
-#ifdef OLD_STRICTNESS                 
-doCorePass CoreDoOldStrictness        = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
-#else
-doCorePass CoreDoOldStrictness        = panic "CoreDoOldStrictness"
-#endif
-doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
-
-#ifdef OLD_STRICTNESS
-doOldStrictness dfs binds
-  = do binds1 <- saBinds dfs binds
-       binds2 <- cprAnalyse dfs binds1
-       return binds2
-#endif
-
-printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-
-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
-                                     printDump (ruleCheckProgram phase pat binds)
-
--- Most passes return no stats and don't change rules
-trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
-       -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-       -> IO (SimplCount, ModGuts)
-trBinds do_pass hsc_env us rb guts
-  = do { binds' <- do_pass dflags (mg_binds guts)
-       ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
-  where
-    dflags = hsc_dflags hsc_env
-
-trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
-       -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-       -> IO (SimplCount, ModGuts)
-trBindsU do_pass hsc_env us rb guts
-  = do { binds' <- do_pass dflags us (mg_binds guts)
-       ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
-  where
-    dflags = hsc_dflags hsc_env
+doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
+                                       vectorise
 
 
--- Observer passes just peek; don't modify the bindings at all
-observe :: (DynFlags -> [CoreBind] -> IO a)
-       -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
-       -> IO (SimplCount, ModGuts)
-observe do_pass hsc_env us rb guts 
-  = do { binds <- do_pass dflags (mg_binds guts)
-       ; return (zeroSimplCount dflags, guts) }
-  where
-    dflags = hsc_dflags hsc_env
+doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
+doCorePass CoreDoNothing                = return
+doCorePass (CoreDoPasses passes)        = doCorePasses passes
+doCorePass pass = pprPanic "doCorePass" (ppr pass)
 \end{code}
 
 \end{code}
 
-
-
 %************************************************************************
 %*                                                                     *
 %************************************************************************
 %*                                                                     *
-\subsection{Dealing with rules}
+\subsection{Core pass combinators}
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet.  
-
 \begin{code}
 \begin{code}
-prepareRules :: HscEnv 
-            -> ModGuts
-            -> UniqSupply
-            -> IO (RuleBase,           -- Rule base for imported things, incl
-                                       -- (a) rules defined in this module (orphans)
-                                       -- (b) rules from other modules in home package
-                                       -- but not things from other packages
-
-                   ModGuts)            -- Modified fields are 
-                                       --      (a) Bindings have rules attached,
-                                       --      (b) Rules are now just orphan rules
-
-prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
-            guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
-            us 
-  = do { 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 
-             (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                (mapSmpl (simplRule env) local_rules)
-             home_pkg_rules   = hptRules hsc_env (dep_mods deps)
-
-               -- Find the rules for locally-defined Ids; then we can attach them
-               -- to the binders in the top-level bindings
-               -- 
-               -- Reason
-               --      - It makes the rules easier to look up
-               --      - It means that transformation rules and specialisations for
-               --        locally defined Ids are handled uniformly
-               --      - It keeps alive things that are referred to only from a rule
-               --        (the occurrence analyser knows about rules attached to Ids)
-               --      - It makes sure that, when we apply a rule, the free vars
-               --        of the RHS are more likely to be in scope
-               --      - The imported rules are carried in the in-scope set
-               --        which is extended on each iteration by the new wave of
-               --        local binders; any rules which aren't on the binding will
-               --        thereby get dropped
-             (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
-             local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
-             binds_w_rules   = updateBinders local_rule_base binds
-
-             hpt_rule_base = mkRuleBase home_pkg_rules
-             imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
-
-       ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-               (vcat [text "Local rules", pprRules better_rules,
-                      text "",
-                      text "Imported rules", pprRuleBase imp_rule_base])
-
-       ; return (imp_rule_base, guts { mg_binds = binds_w_rules, 
-                                       mg_rules = rules_for_imps })
-    }
+printCore :: a -> [CoreBind] -> IO ()
+printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 
 
-updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
-updateBinders local_rules binds
-  = map update_bndrs binds
-  where
-    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
-    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
-
-    update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
-                         Nothing    -> bndr
-                         Just rules -> bndr `addIdSpecialisations` rules
-                               -- The binder might have some existing rules,
-                               -- arising from specialisation pragmas
+ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheck current_phase pat guts = do
+    rb <- getRuleBase
+    dflags <- getDynFlags
+    liftIO $ Err.showPass dflags "RuleCheck"
+    liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
+    return guts
+
+
+doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDUM do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    liftIO $ do_pass dflags us binds
+
+doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
+
+doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
+
+doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
+
+doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassU do_pass = doPassDU (const do_pass)
+
+-- Most passes return no stats and don't change rules: these combinators
+-- let us lift them to the full blown ModGuts+CoreM world
+doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassM bind_f guts = do
+    binds' <- bind_f (mg_binds guts)
+    return (guts { mg_binds = binds' })
+
+doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
+
+-- Observer passes just peek; don't modify the bindings at all
+observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
+observe do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    _ <- liftIO $ do_pass dflags binds
+    return binds
 \end{code}
 
 
 \end{code}
 
 
-We must do some gentle simplification on the template (but not the RHS)
-of each rule.  The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
-       fold k z (build (/\a. g a))  ==>  ...
-This doesn't match unless you do eta reduction on the build argument.
+%************************************************************************
+%*                                                                     *
+       Gentle simplification
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
 
 \begin{code}
-simplRule env rule@(BuiltinRule {})
-  = returnSmpl rule
-simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
-  = simplBinders env bndrs             `thenSmpl` \ (env, bndrs') -> 
-    mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
-    simplExprGently env rhs            `thenSmpl` \ rhs' ->
-    returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
-
--- It's important that simplExprGently does eta reduction.
--- For example, in a rule like:
---     augment g (build h) 
--- we do not want to get
---     augment (\a. g a) (build h)
--- otherwise we don't match when given an argument like
---     (\a. h a a)
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+            -> CoreExpr
+            -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
 --
 --
--- The simplifier does indeed do eta reduction (it's in
--- Simplify.completeLam) but only if -O is on.
-\end{code}
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+  = do {
+       ; Err.showPass dflags "Simplify"
+
+       ; us <-  mkSplitUniqSupply 's'
+
+       ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+                                simplExprGently simplEnvForGHCi expr
+
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+                       (pprCoreExpr expr')
+
+       ; return expr'
+       }
 
 
-\begin{code}
 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- Simplifies an expression 
 --     does occurrence analysis, then simplification
 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- Simplifies an expression 
 --     does occurrence analysis, then simplification
@@ -318,13 +226,19 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 --     alone leaves tons of crud.
 -- Used (a) for user expressions typed in at the interactive prompt
 --     (b) the LHS and RHS of a RULE
 --     alone leaves tons of crud.
 -- Used (a) for user expressions typed in at the interactive prompt
 --     (b) the LHS and RHS of a RULE
+--     (c) Template Haskell splices
 --
 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 -- enforce that; it just simplifies the expression twice
 
 --
 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 -- enforce that; it just simplifies the expression twice
 
-simplExprGently env expr
-  = simplExpr env (occurAnalyseExpr expr)      `thenSmpl` \ expr1 ->
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above.  The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
+simplExprGently env expr = do
+    expr1 <- simplExpr env (occurAnalyseExpr expr)
     simplExpr env (occurAnalyseExpr expr1)
 \end{code}
 
     simplExpr env (occurAnalyseExpr expr1)
 \end{code}
 
@@ -363,7 +277,7 @@ glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
 -- analyser as free in f.
 
 glomBinds dflags binds
 -- analyser as free in f.
 
 glomBinds dflags binds
-  = do { showPass dflags "GlomBinds" ;
+  = do { Err.showPass dflags "GlomBinds" ;
         let { recd_binds = [Rec (flattenBinds binds)] } ;
         return recd_binds }
        -- Not much point in printing the result... 
         let { recd_binds = [Rec (flattenBinds binds)] } ;
         return recd_binds }
        -- Not much point in printing the result... 
@@ -378,79 +292,88 @@ glomBinds dflags binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-simplifyPgm :: SimplifierMode
-           -> [SimplifierSwitch]
-           -> HscEnv
-           -> UniqSupply
-           -> RuleBase
-           -> ModGuts
-           -> IO (SimplCount, ModGuts)  -- New bindings
-
-simplifyPgm mode switches hsc_env us imp_rule_base guts
-  = do {
-       showPass dflags "Simplify";
-
-       (termination_msg, it_count, counts_out, binds') 
-          <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
-
-       dumpIfSet (dopt Opt_D_verbose_core2core dflags 
-                   && dopt Opt_D_dump_simpl_stats dflags)
-                 "Simplifier statistics"
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv
+       ; us <- getUniqueSupplyM
+       ; rb <- getRuleBase
+       ; liftIOWithCount $  
+                simplifyPgmIO pass hsc_env us rb guts }
+
+simplifyPgmIO :: CoreToDo
+             -> HscEnv
+             -> UniqSupply
+             -> RuleBase
+             -> ModGuts
+             -> IO (SimplCount, ModGuts)  -- New bindings
+
+simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
+              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",
                  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
-                        text "",
-                        pprSimplCount counts_out]);
-
-       endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
+                        blankLine,
+                        pprSimplCount counts_out])
 
 
-       return (counts_out, guts { mg_binds = binds' })
+       ; return (counts_out, guts')
     }
   where
     }
   where
-    dflags        = hsc_dflags hsc_env
-    phase_info    = case mode of
-                         SimplGently  -> "gentle"
-                         SimplPhase n -> show n
-                  
-    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
+    simpl_env   = mkSimplEnv mode
+    active_rule = activeRule dflags simpl_env
+
+    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
-      = do {
-#ifdef DEBUG
-           if  max_iterations > 2 then
-               hPutStr stderr ("NOTE: Simplifier still going after " ++ 
-                               show max_iterations ++ 
-                               " iterations; bailing out.\n")
-           else 
-               return ();
-#endif
+      = WARN( debugIsOn && (max_iterations > 2)
+            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
+              <+> ptext (sLit "iterations") 
+              <+> (brackets $ hsep $ punctuate comma $ 
+                   map (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 baled out", iteration_no - 1, counts, binds)
-       }
+       return ( "Simplifier baled out", iteration_no - 1 
+               , totalise counts_so_far
+               , 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 } ;
-          dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+          let { tagged_binds = {-# SCC "OccAnal" #-} 
+                     occurAnalysePgm active_rule rules binds } ;
+          Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 
                -- Get any new rules, and extend the rule base
                     (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_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
-               ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
+               ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
           
                -- Simplify the program
                -- We do this with a *case* not a *let* because lazy pattern
           
                -- Simplify the program
                -- We do this with a *case* not a *let* because lazy pattern
@@ -458,24 +381,23 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
                -- 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 phase " ++ phase_info ++ 
-                             ", 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
+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks   
+                      , 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 
@@ -485,18 +407,35 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
                --
                -- 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
-          dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
-                        (pprSimplCount counts') ;
-          endPass 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
+           } } } }
+      | otherwise = panic "do_iteration"
       where
       where
-         (us1, us2) = splitUniqSupply us
+       (us1, us2) = splitUniqSupply us
+
+       -- Remember the counts_so_far are reversed
+        totalise :: [SimplCount] -> SimplCount
+        totalise = foldr (\c acc -> acc `plusSimplCount` c) 
+                         (zeroSimplCount dflags) 
+
+simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
+
+-------------------
+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}
 
 
@@ -523,23 +462,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]
@@ -572,13 +509,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
 ~~~~~~~~~~~~~
@@ -646,9 +598,10 @@ makeIndEnv binds
     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
     add_pair (exported_id, Var local_id) env
        | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
     add_pair (exported_id, Var local_id) env
        | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
-    add_pair (exported_id, rhs) env
-       = env
+    add_pair _ env = env
                        
                        
+-----------------
+shortMeOut :: IndEnv -> Id -> Id -> Bool
 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
@@ -663,23 +616,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
@@ -690,9 +647,12 @@ 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
-                                `setWorkerInfo`        workerInfo local_info
+    transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
+                                `setUnfoldingInfo`     unfoldingInfo local_info
                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setInlinePragInfo`    inlinePragInfo local_info
-                                `setSpecInfo`          addSpecInfo (specInfo exp_info)
-                                                                   (specInfo local_info)
+                                `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
+    new_info = setSpecInfoHead (idName exported_id) 
+                              (specInfo local_info)
+       -- Remember to set the function-name field of the
+       -- rules as we transfer them from one function to another
 \end{code}
 \end{code}